diff --git a/metadata/entries/Distributed_Distinct_Elements.toml b/metadata/entries/Distributed_Distinct_Elements.toml
--- a/metadata/entries/Distributed_Distinct_Elements.toml
+++ b/metadata/entries/Distributed_Distinct_Elements.toml
@@ -1,28 +1,28 @@
 title = "Distributed Distinct Elements"
 date = 2023-04-03
 topics = [
   "Computer science/Algorithms/Distributed",
   "Computer science/Algorithms/Approximation",
   "Computer science/Algorithms/Randomized",
 ]
 abstract = "This entry formalizes a randomized cardinality estimation data structure with asymptotically optimal space usage. It is inspired by the streaming algorithm presented by <a href=\"https://doi.org/10.1145/3309193\">B&lstrok;asiok</a> in 2018. His work closed the gap between the best-known lower bound and upper bound after a long line of research started by <a href=\"https://doi.org/10.1016/0022-0000(85)90041-8\">Flajolet and Martin</a> in 1984 and was to first to apply expander graphs (in addition to hash families) to the problem. The formalized algorithm has two improvements compared to the algorithm by B&lstrok;asiok. It supports operation in parallel mode, and it relies on a simpler pseudo-random construction avoiding the use of code based extractors."
 license = "bsd"
 note = ""
 
 [authors]
 
 [authors.karayel]
 email = "karayel_email"
 
 [contributors]
 
 [notify]
 karayel = "karayel_email"
 
 [history]
 
 [extra]
 
 [related]
-dois = []
+dois = ["10.4230/LIPIcs.APPROX/RANDOM.2023.35","10.48550/arXiv.2307.00985"]
 pubs = []
diff --git a/metadata/entries/Finite_Fields.toml b/metadata/entries/Finite_Fields.toml
--- a/metadata/entries/Finite_Fields.toml
+++ b/metadata/entries/Finite_Fields.toml
@@ -1,37 +1,40 @@
 title = "Finite Fields"
 date = 2022-06-08
 topics = [
   "Mathematics/Algebra",
 ]
 abstract = """
 This entry formalizes the classification of the finite fields (also
 called Galois fields): For each prime power $p^n$ there exists exactly
 one (up to isomorphisms) finite field of that size and there are no
 other finite fields. The derivation includes a formalization of the
-characteristic of rings, the Frobenius endomorphism, formal
-differentiation for polynomials in HOL-Algebra and Gauss' formula
-for the number of monic irreducible polynomials over finite fields: \\[
+characteristic of rings, the Frobenius endomorphism, formal differentiation
+for polynomials in HOL-Algebra, Rabin's test for the irreducibility of
+polynomials and Gauss' formula for the number of monic irreducible
+polynomials over finite fields: \\[
 \\frac{1}{n} \\sum_{d | n} \\mu(d) p^{n/d} \\textrm{.} \\] The proofs are
-based on the books from <a
+based on the books and publications from <a
 href=\"https://doi.org/10.1007/978-1-4757-2103-4\">Ireland
-and Rosen</a>, as well as, <a
-href=\"https://doi.org/10.1017/CBO9781139172769\">Lidl and
+and Rosen</a>, <a href=\"https://doi.org/10.1137/0209024\">Rabin</a>, as
+well as, <a href=\"https://doi.org/10.1017/CBO9781139172769\">Lidl and
 Niederreiter</a>."""
 license = "bsd"
 note = ""
 
 [authors]
 
 [authors.karayel]
 homepage = "karayel_homepage"
 
 [contributors]
 
 [notify]
 karayel = "karayel_email"
 
 [history]
+2024-01-17 = "Added Rabin's test for the irreducibility of polynomials in finite fields."
+2024-01-18 = "Added exectuable algorithms for the construction of (and calculations in) finite fields."
 
 [extra]
 
 [related]
diff --git a/thys/Automatic_Refinement/Lib/Misc.thy b/thys/Automatic_Refinement/Lib/Misc.thy
--- a/thys/Automatic_Refinement/Lib/Misc.thy
+++ b/thys/Automatic_Refinement/Lib/Misc.thy
@@ -1,4507 +1,4495 @@
 (*  Title:       Miscellaneous Definitions and Lemmas
     Author:      Peter Lammich <peter.lammich@uni-muenster.de>
     Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
                  Thomas Tuerk <tuerk@in.tum.de>
 *)
 
 (*
   CHANGELOG:
     2010-05-09: Removed AC, AI locales, they are superseeded by concepts
                   from OrderedGroups
     2010-09-22: Merges with ext/Aux
     2017-06-12: Added a bunch of lemmas from various other projects
 
 *)
 
 section \<open>Miscellaneous Definitions and Lemmas\<close>
 
 theory Misc
 imports Main
   "HOL-Library.Multiset"
   "HOL-ex.Quicksort"
   "HOL-Library.Option_ord"
   "HOL-Library.Infinite_Set"
   "HOL-Eisbach.Eisbach"
 begin
 text_raw \<open>\label{thy:Misc}\<close>
 
   
 subsection \<open>Isabelle Distribution Move Proposals\<close>  
 
 subsubsection \<open>Pure\<close>  
 lemma TERMI: "TERM x" unfolding Pure.term_def .
   
   
 subsubsection \<open>HOL\<close>  
 (* Stronger disjunction elimination rules. *)
 lemma disjE1: "\<lbrakk> P \<or> Q; P \<Longrightarrow> R; \<lbrakk>\<not>P;Q\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by metis
 lemma disjE2: "\<lbrakk> P \<or> Q; \<lbrakk>P; \<not>Q\<rbrakk> \<Longrightarrow> R; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by blast
 
 lemma imp_mp_iff[simp]: 
   "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b" 
   "(a \<longrightarrow> b) \<and> a \<longleftrightarrow> a \<and> b" (* is Inductive.imp_conj_iff, but not in simpset by default *)
   by blast+
     
 lemma atomize_Trueprop_eq[atomize]: "(Trueprop x \<equiv> Trueprop y) \<equiv> Trueprop (x=y)"
   apply rule
   apply (rule)
   apply (erule equal_elim_rule1)
   apply assumption
   apply (erule equal_elim_rule2)
   apply assumption
   apply simp
   done
   
 subsubsection \<open>Set\<close>    
 lemma inter_compl_diff_conv[simp]: "A \<inter> -B = A - B" by auto
 lemma pair_set_inverse[simp]: "{(a,b). P a b}\<inverse> = {(b,a). P a b}"
   by auto
 
 lemma card_doubleton_eq_2_iff[simp]: "card {a,b} = 2 \<longleftrightarrow> a\<noteq>b" by auto
 
     
 subsubsection \<open>List\<close>  
 (* TODO: Move, analogous to List.length_greater_0_conv *) 
 thm List.length_greater_0_conv  
 lemma length_ge_1_conv[iff]: "Suc 0 \<le> length l \<longleftrightarrow> l\<noteq>[]"
   by (cases l) auto
   
 \<comment> \<open>Obtains a list from the pointwise characterization of its elements\<close>
 lemma obtain_list_from_elements:
   assumes A: "\<forall>i<n. (\<exists>li. P li i)"
   obtains l where
     "length l = n"
     "\<forall>i<n. P (l!i) i"
 proof -
   from A have "\<exists>l. length l=n \<and> (\<forall>i<n. P (l!i) i)"
   proof (induct n)
     case 0 thus ?case by simp
   next
     case (Suc n)
     then obtain l where IH: "length l = n" "(\<forall>i<n. P(l!i) i)" by auto
     moreover from Suc.prems obtain ln where "P ln n" by auto
     ultimately have "length (l@[ln]) = Suc n" "(\<forall>i<Suc n. P((l@[ln])!i) i)"
       by (auto simp add: nth_append dest: less_antisym)
     thus ?case by blast
   qed
   thus ?thesis using that by (blast)
 qed
   
 lemma distinct_sorted_mono:
   assumes S: "sorted l"
   assumes D: "distinct l"
   assumes B: "i<j" "j<length l"
   shows "l!i < l!j"
 proof -
   from S B have "l!i \<le> l!j"
     by (simp add: sorted_iff_nth_mono)
   also from nth_eq_iff_index_eq[OF D] B have "l!i \<noteq> l!j"
     by auto
   finally show ?thesis .
 qed
 
 lemma distinct_sorted_strict_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i<l!j \<longleftrightarrow> i<j"
   using assms
   by (metis distinct_sorted_mono leI less_le_not_le
     order.strict_iff_order)
 
 lemma distinct_sorted_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i\<le>l!j \<longleftrightarrow> i\<le>j"
   by (metis assms distinct_sorted_strict_mono_iff leD le_less_linear)
   
     
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] 
 
   We could, analogously, declare rules for "map _ _ = _@_" as dest!,
   or use elim!, or declare the _conv-rule as simp
 *)  
    
 lemma map_eq_appendE: 
   assumes "map f ls = fl@fl'"
   obtains l l' where "ls=l@l'" and "map f l=fl" and  "map f l' = fl'"
   using assms  
 proof (induction fl arbitrary: ls thesis)
   case (Cons x xs)
     then obtain l ls' where [simp]: "ls = l#ls'" "f l = x" by force
     with Cons.prems(2) have "map f ls' = xs @ fl'" by simp
     from Cons.IH[OF _ this] obtain ll ll' where "ls' = ll @ ll'" "map f ll = xs" "map f ll' = fl'" .
     with Cons.prems(1)[of "l#ll" ll'] show thesis by simp
 qed simp
 
 lemma map_eq_append_conv: "map f ls = fl@fl' \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: map_eq_appendE)
   
 lemmas append_eq_mapE = map_eq_appendE[OF sym]
   
 lemma append_eq_map_conv: "fl@fl' = map f ls \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: append_eq_mapE)
   
   
 lemma distinct_mapI: "distinct (map f l) \<Longrightarrow> distinct l"
   by (induct l) auto
     
 lemma map_distinct_upd_conv: 
   "\<lbrakk>i<length l; distinct l\<rbrakk> \<Longrightarrow> (map f l)[i := x] = map (f(l!i := x)) l"
   \<comment> \<open>Updating a mapped distinct list is equal to updating the 
     mapping function\<close>
   by (auto simp: nth_eq_iff_index_eq intro: nth_equalityI)
 
     
 lemma zip_inj: "\<lbrakk>length a = length b; length a' = length b'; zip a b = zip a' b'\<rbrakk> \<Longrightarrow> a=a' \<and> b=b'"
 proof (induct a b arbitrary: a' b' rule: list_induct2)
   case Nil
   then show ?case by (cases a'; cases b'; auto)
 next
   case (Cons x xs y ys)
   then show ?case by (cases a'; cases b'; auto)
 qed
 
 lemma zip_eq_zip_same_len[simp]:
   "\<lbrakk> length a = length b; length a' = length b' \<rbrakk> \<Longrightarrow>
   zip a b = zip a' b' \<longleftrightarrow> a=a' \<and> b=b'"
   by (auto dest: zip_inj)
     
     
 lemma upt_merge[simp]: "i\<le>j \<and> j\<le>k \<Longrightarrow> [i..<j]@[j..<k] = [i..<k]"
   by (metis le_Suc_ex upt_add_eq_append)
   
 (* Maybe this should go into List.thy, next to snoc_eq_iff_butlast *)
 lemma snoc_eq_iff_butlast':
   "(ys = xs @ [x]) \<longleftrightarrow> (ys \<noteq> [] \<and> butlast ys = xs \<and> last ys = x)"
   by auto
 
 (* Case distinction how two elements of a list can be related to each other *)
 lemma list_match_lel_lel:
   assumes "c1 @ qs # c2 = c1' @ qs' # c2'"
   obtains
     (left) c21' where "c1 = c1' @ qs' # c21'" "c2' = c21' @ qs # c2"
   | (center) "c1' = c1" "qs' = qs" "c2' = c2"
   | (right) c21 where "c1' = c1 @ qs # c21" "c2 = c21 @ qs' # c2'"
   using assms  
   apply (clarsimp simp: append_eq_append_conv2)  
   subgoal for us by (cases us) auto
   done    
     
 lemma xy_in_set_cases[consumes 2, case_names EQ XY YX]:
   assumes A: "x\<in>set l" "y\<in>set l"
   and C:
   "!!l1 l2. \<lbrakk> x=y; l=l1@y#l2 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@x#l2@y#l3 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@y#l2@x#l3 \<rbrakk> \<Longrightarrow> P"
   shows P
 proof (cases "x=y")
   case True with A(1) obtain l1 l2 where "l=l1@y#l2" by (blast dest: split_list)
   with C(1) True show ?thesis by blast
 next
   case False
   from A(1) obtain l1 l2 where S1: "l=l1@x#l2" by (blast dest: split_list)
   from A(2) obtain l1' l2' where S2: "l=l1'@y#l2'" by (blast dest: split_list)
   from S1 S2 have M: "l1@x#l2 = l1'@y#l2'" by simp
   thus P proof (cases rule: list_match_lel_lel[consumes 1, case_names 1 2 3])
     case (1 c) with S1 have "l=l1'@y#c@x#l2" by simp
     with C(3) False show ?thesis by blast
   next
     case 2 with False have False by blast
     thus ?thesis ..
   next
     case (3 c) with S1 have "l=l1@x#c@y#l2'" by simp
     with C(2) False show ?thesis by blast
   qed
 qed
     
     
 lemma list_e_eq_lel[simp]:
   "[e] = l1@e'#l2 \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   "l1@e'#l2 = [e] \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 lemma list_ee_eq_leel[simp]:
   "([e1,e2] = l1@e1'#e2'#l2) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   "(l1@e1'#e2'#l2 = [e1,e2]) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 subsubsection \<open>Transitive Closure\<close>
 
 text \<open>A point-free induction rule for elements reachable from an initial set\<close>
 lemma rtrancl_reachable_induct[consumes 0, case_names base step]:
   assumes I0: "I \<subseteq> INV"
   assumes IS: "E``INV \<subseteq> INV"
   shows "E\<^sup>*``I \<subseteq> INV"
   by (metis I0 IS Image_closed_trancl Image_mono subset_refl)
   
 
 lemma acyclic_empty[simp, intro!]: "acyclic {}" by (unfold acyclic_def) auto
 
 lemma acyclic_union:
   "acyclic (A\<union>B) \<Longrightarrow> acyclic A"
   "acyclic (A\<union>B) \<Longrightarrow> acyclic B"
   by (metis Un_upper1 Un_upper2 acyclic_subset)+
     
    
 text \<open>Here we provide a collection of miscellaneous definitions and helper lemmas\<close>
 
 subsection "Miscellaneous (1)"
 
 text \<open>This stuff is used in this theory itself, and thus occurs in first place or is simply not sorted into any other section of this theory.\<close>
 
 lemma IdD: "(a,b)\<in>Id \<Longrightarrow> a=b" by simp
 
 text \<open>Conversion Tag\<close>    
 definition [simp]: "CNV x y \<equiv> x=y"
 lemma CNV_I: "CNV x x" by simp
 lemma CNV_eqD: "CNV x y \<Longrightarrow> x=y" by simp
 lemma CNV_meqD: "CNV x y \<Longrightarrow> x\<equiv>y" by simp
    
 (* TODO: Move. Shouldn't this be detected by simproc? *)
 lemma ex_b_b_and_simp[simp]: "(\<exists>b. b \<and> Q b) \<longleftrightarrow> Q True" by auto
 lemma ex_b_not_b_and_simp[simp]: "(\<exists>b. \<not>b \<and> Q b) \<longleftrightarrow> Q False" by auto
     
 method repeat_all_new methods m = m;(repeat_all_new \<open>m\<close>)?
     
     
 subsubsection "AC-operators"
 
 text \<open>Locale to declare AC-laws as simplification rules\<close>
 locale Assoc =
   fixes f
   assumes assoc[simp]: "f (f x y) z = f x (f y z)"
 
 locale AC = Assoc +
   assumes commute[simp]: "f x y = f y x"
 
 lemma (in AC) left_commute[simp]: "f x (f y z) = f y (f x z)"
   by (simp only: assoc[symmetric]) simp
 
 lemmas (in AC) AC_simps = commute assoc left_commute
 
 text \<open>Locale to define functions from surjective, unique relations\<close>
 locale su_rel_fun =
   fixes F and f
   assumes unique: "\<lbrakk>(A,B)\<in>F; (A,B')\<in>F\<rbrakk> \<Longrightarrow> B=B'"
   assumes surjective: "\<lbrakk>!!B. (A,B)\<in>F \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   assumes f_def: "f A == THE B. (A,B)\<in>F"
 
 lemma (in su_rel_fun) repr1: "(A,f A)\<in>F" proof (unfold f_def)
   obtain B where "(A,B)\<in>F" by (rule surjective)
   with theI[where P="\<lambda>B. (A,B)\<in>F", OF this] show "(A, THE x. (A, x) \<in> F) \<in> F" by (blast intro: unique)
 qed
 
 lemma (in su_rel_fun) repr2: "(A,B)\<in>F \<Longrightarrow> B=f A" using repr1
   by (blast intro: unique)
 
 lemma (in su_rel_fun) repr: "(f A = B) = ((A,B)\<in>F)" using repr1 repr2
   by (blast)
 
     \<comment> \<open>Contract quantification over two variables to pair\<close>
 lemma Ex_prod_contract: "(\<exists>a b. P a b) \<longleftrightarrow> (\<exists>z. P (fst z) (snd z))"
   by auto
 
 lemma All_prod_contract: "(\<forall>a b. P a b) \<longleftrightarrow> (\<forall>z. P (fst z) (snd z))"
   by auto
 
 
 lemma nat_geq_1_eq_neqz: "x\<ge>1 \<longleftrightarrow> x\<noteq>(0::nat)"
   by auto
 
 lemma nat_in_between_eq:
   "(a<b \<and> b\<le>Suc a) \<longleftrightarrow> b = Suc a"
   "(a\<le>b \<and> b<Suc a) \<longleftrightarrow> b = a"
   by auto
 
 lemma Suc_n_minus_m_eq: "\<lbrakk> n\<ge>m; m>1 \<rbrakk> \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma Suc_to_right: "Suc n = m \<Longrightarrow> n = m - Suc 0" by simp
 lemma Suc_diff[simp]: "\<And>n m. n\<ge>m \<Longrightarrow> m\<ge>1 \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma if_not_swap[simp]: "(if \<not>c then a else b) = (if c then b else a)" by auto
 lemma all_to_meta: "Trueprop (\<forall>a. P a) \<equiv> (\<And>a. P a)"
   apply rule
   by auto
 
 lemma imp_to_meta: "Trueprop (P\<longrightarrow>Q) \<equiv> (P\<Longrightarrow>Q)"
   apply rule
   by auto
 
 
 (* for some reason, there is no such rule in HOL *)
 lemma iffI2: "\<lbrakk>P \<Longrightarrow> Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q"
 by metis
 
 lemma iffExI:
   "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x; \<And>x. Q x \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> (\<exists>x. P x) \<longleftrightarrow> (\<exists>x. Q x)"
 by metis
 
 lemma bex2I[intro?]: "\<lbrakk> (a,b)\<in>S; (a,b)\<in>S \<Longrightarrow> P a b \<rbrakk> \<Longrightarrow> \<exists>a b. (a,b)\<in>S \<and> P a b"
   by blast
 
     
 (* TODO: Move lemma to HOL! *)  
 lemma cnv_conj_to_meta: "(P \<and> Q \<Longrightarrow> PROP X) \<equiv> (\<lbrakk>P;Q\<rbrakk> \<Longrightarrow> PROP X)"
   by (rule BNF_Fixpoint_Base.conj_imp_eq_imp_imp)
     
     
 
 subsection \<open>Sets\<close>
   lemma remove_subset: "x\<in>S \<Longrightarrow> S-{x} \<subset> S" by auto
 
   lemma subset_minus_empty: "A\<subseteq>B \<Longrightarrow> A-B = {}" by auto
 
   lemma insert_minus_eq: "x\<noteq>y \<Longrightarrow> insert x A - {y} = insert x (A - {y})" by auto
       
   lemma set_notEmptyE: "\<lbrakk>S\<noteq>{}; !!x. x\<in>S \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (metis equals0I)
 
   lemma subset_Collect_conv: "S \<subseteq> Collect P \<longleftrightarrow> (\<forall>x\<in>S. P x)"
     by auto
 
   lemma memb_imp_not_empty: "x\<in>S \<Longrightarrow> S\<noteq>{}"
     by auto
 
   lemma disjoint_mono: "\<lbrakk> a\<subseteq>a'; b\<subseteq>b'; a'\<inter>b'={} \<rbrakk> \<Longrightarrow> a\<inter>b={}" by auto
 
   lemma disjoint_alt_simp1: "A-B = A \<longleftrightarrow> A\<inter>B = {}" by auto
   lemma disjoint_alt_simp2: "A-B \<noteq> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
   lemma disjoint_alt_simp3: "A-B \<subset> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
 
   lemma disjointI[intro?]: "\<lbrakk> \<And>x. \<lbrakk>x\<in>a; x\<in>b\<rbrakk> \<Longrightarrow> False \<rbrakk> \<Longrightarrow> a\<inter>b={}"
     by auto
 
 
   lemmas set_simps = subset_minus_empty disjoint_alt_simp1 disjoint_alt_simp2 disjoint_alt_simp3 Un_absorb1 Un_absorb2
 
   lemma set_minus_singleton_eq: "x\<notin>X \<Longrightarrow> X-{x} = X"
     by auto
 
   lemma set_diff_diff_left: "A-B-C = A-(B\<union>C)"
     by auto
 
 
   lemma image_update[simp]: "x\<notin>A \<Longrightarrow> f(x:=n)`A = f`A"
     by auto
 
   lemma eq_or_mem_image_simp[simp]: "{f l |l. l = a \<or> l\<in>B} = insert (f a) {f l|l. l\<in>B}" by blast
       
   lemma set_union_code [code_unfold]:
     "set xs \<union> set ys = set (xs @ ys)"
     by auto
 
   lemma in_fst_imageE:
     assumes "x \<in> fst`S"
     obtains y where "(x,y)\<in>S"
     using assms by auto
 
   lemma in_snd_imageE:
     assumes "y \<in> snd`S"
     obtains x where "(x,y)\<in>S"
     using assms by auto
 
   lemma fst_image_mp: "\<lbrakk>fst`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> x\<in>B"
     by (metis Domain.DomainI fst_eq_Domain in_mono)
 
   lemma snd_image_mp: "\<lbrakk>snd`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> y\<in>B"
     by (metis Range.intros rev_subsetD snd_eq_Range)
 
   lemma inter_eq_subsetI: "\<lbrakk> S\<subseteq>S'; A\<inter>S' = B\<inter>S' \<rbrakk> \<Longrightarrow> A\<inter>S = B\<inter>S"
     by auto
 
 text \<open>
   Decompose general union over sum types.
 \<close>
 lemma Union_plus:
   "(\<Union> x \<in> A <+> B. f x) = (\<Union> a \<in> A. f (Inl a)) \<union> (\<Union>b \<in> B. f (Inr b))"
 by auto
 
 lemma Union_sum:
   "(\<Union>x. f (x::'a+'b)) = (\<Union>l. f (Inl l)) \<union> (\<Union>r. f (Inr r))"
   (is "?lhs = ?rhs")
 proof -
   have "?lhs = (\<Union>x \<in> UNIV <+> UNIV. f x)"
     by simp
   thus ?thesis
     by (simp only: Union_plus)
 qed
 
   
 
 
   subsubsection \<open>Finite Sets\<close>
 
   lemma card_1_singletonI: "\<lbrakk>finite S; card S = 1; x\<in>S\<rbrakk> \<Longrightarrow> S={x}"
   proof (safe, rule ccontr, goal_cases)
     case prems: (1 x')
     hence "finite (S-{x})" "S-{x} \<noteq> {}" by auto
     hence "card (S-{x}) \<noteq> 0" by auto
     moreover from prems(1-3) have "card (S-{x}) = 0" by auto
     ultimately have False by simp
     thus ?case ..
   qed
 
   lemma card_insert_disjoint': "\<lbrakk>finite A; x \<notin> A\<rbrakk> \<Longrightarrow> card (insert x A) - Suc 0 = card A"
     by (drule (1) card_insert_disjoint) auto
 
   lemma card_eq_UNIV[simp]: "card (S::'a::finite set) = card (UNIV::'a set) \<longleftrightarrow> S=UNIV"
   proof (auto)
     fix x
     assume A: "card S = card (UNIV::'a set)"
     show "x\<in>S" proof (rule ccontr)
       assume "x\<notin>S" hence "S\<subset>UNIV" by auto
       with psubset_card_mono[of UNIV S] have "card S < card (UNIV::'a set)" by auto
       with A show False by simp
     qed
   qed
 
   lemma card_eq_UNIV2[simp]: "card (UNIV::'a set) = card (S::'a::finite set) \<longleftrightarrow> S=UNIV"
     using card_eq_UNIV[of S] by metis
 
   lemma card_ge_UNIV[simp]: "card (UNIV::'a::finite set) \<le> card (S::'a set) \<longleftrightarrow> S=UNIV"
     using card_mono[of "UNIV::'a::finite set" S, simplified]
     by auto
 
   lemmas length_remdups_card = length_remdups_concat[of "[l]", simplified] for l
 
   lemma fs_contract: "fst ` { p | p. f (fst p) (snd p) \<in> S } = { a . \<exists>b. f a b \<in> S }"
     by (simp add: image_Collect)
 
-lemma finite_Collect: "finite S \<Longrightarrow> inj f \<Longrightarrow> finite {a. f a : S}"
-by(simp add: finite_vimageI vimage_def[symmetric])
-
   \<comment> \<open>Finite sets have an injective mapping to an initial segments of the
       natural numbers\<close>
   (* This lemma is also in the standard library (from Isabelle2009-1 on)
       as @{thm [source] Finite_Set.finite_imp_inj_to_nat_seg}. However, it is formulated with HOL's
       \<exists> there rather then with the meta-logic obtain *)
   lemma finite_imp_inj_to_nat_seg':
     fixes A :: "'a set"
     assumes A: "finite A"
     obtains f::"'a \<Rightarrow> nat" and n::"nat" where
       "f`A = {i. i<n}"
       "inj_on f A"
     by (metis A finite_imp_inj_to_nat_seg)
 
   lemma lists_of_len_fin1: "finite P \<Longrightarrow> finite (lists P \<inter> { l. length l = n })"
   proof (induct n)
     case 0 thus ?case by auto
   next
     case (Suc n)
     have "lists P \<inter> { l. length l = Suc n }
           = (\<lambda>(a,l). a#l) ` (P \<times> (lists P \<inter> {l. length l = n}))"
       apply auto
       apply (case_tac x)
       apply auto
       done
     moreover from Suc have "finite \<dots>" by auto
     ultimately show ?case by simp
   qed
 
   lemma lists_of_len_fin2: "finite P \<Longrightarrow> finite (lists P \<inter> { l. n = length l })"
   proof -
     assume A: "finite P"
     have S: "{ l. n = length l } = { l. length l = n }" by auto
     have "finite (lists P \<inter> { l. n = length l })
       \<longleftrightarrow> finite (lists P \<inter> { l. length l = n })"
       by (subst S) simp
 
     thus ?thesis using lists_of_len_fin1[OF A] by auto
   qed
 
   lemmas lists_of_len_fin = lists_of_len_fin1 lists_of_len_fin2
 
 
   (* Try (simp only: cset_fin_simps, fastforce intro: cset_fin_intros) when reasoning about finiteness of collected sets *)
   lemmas cset_fin_simps = Ex_prod_contract fs_contract[symmetric] image_Collect[symmetric]
-  lemmas cset_fin_intros = finite_imageI finite_Collect inj_onI
+  lemmas cset_fin_intros = finite_imageI finite_inverse_image inj_onI
 
 
 lemma Un_interval:
   fixes b1 :: "'a::linorder"
   assumes "b1\<le>b2" and "b2\<le>b3"
   shows "{ f i | i. b1\<le>i \<and> i<b2 } \<union> { f i | i. b2\<le>i \<and> i<b3 }
     = {f i | i. b1\<le>i \<and> i<b3}"
   using assms
   apply -
   apply rule
   apply safe []
   apply (rule_tac x=i in exI, auto) []
   apply (rule_tac x=i in exI, auto) []
   apply rule
   apply simp
   apply (elim exE, simp)
   apply (case_tac "i<b2")
   apply (rule disjI1)
   apply (rule_tac x=i in exI, auto) []
   apply (rule disjI2)
   apply (rule_tac x=i in exI, auto) []
   done
 
 text \<open>
   The standard library proves that a generalized union is finite
   if the index set is finite and if for every index the component
   set is itself finite. Conversely, we show that every component
   set must be finite when the union is finite.
 \<close>
 lemma finite_UNION_then_finite:
   "finite (\<Union>(B ` A)) \<Longrightarrow> a \<in> A \<Longrightarrow> finite (B a)"
 by (metis Set.set_insert UN_insert Un_infinite)
 
 lemma finite_if_eq_beyond_finite: "finite S \<Longrightarrow> finite {s. s - S = s' - S}"
 proof (rule finite_subset[where B="(\<lambda>s. s \<union> (s' - S)) ` Pow S"], clarsimp)
   fix s
   have "s = (s \<inter> S) \<union> (s - S)"
     by auto
   also assume "s - S = s' - S"
   finally show "s \<in> (\<lambda>s. s \<union> (s' - S)) ` Pow S" by blast
 qed blast
 
-lemma distinct_finite_subset:
-  assumes "finite x"
-  shows "finite {ys. set ys \<subseteq> x \<and> distinct ys}" (is "finite ?S")
-proof (rule finite_subset)
-  from assms show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
-    by clarsimp (metis distinct_card card_mono)
-  from assms show "finite ..." by (rule finite_lists_length_le)
-qed
-
 lemma distinct_finite_set:
   shows "finite {ys. set ys = x \<and> distinct ys}" (is "finite ?S")
 proof (cases "finite x")
   case False hence "{ys. set ys = x} = {}" by auto
   thus ?thesis by simp
 next
   case True show ?thesis
   proof (rule finite_subset)
     show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
       using distinct_card by force
     from True show "finite ..." by (rule finite_lists_length_le)
   qed
 qed
 
 lemma finite_set_image:
   assumes f: "finite (set ` A)"
   and dist: "\<And>xs. xs \<in> A \<Longrightarrow> distinct xs"
   shows "finite A"
 proof (rule finite_subset)
   from f show "finite (set -` (set ` A) \<inter> {xs. distinct xs})"
   proof (induct rule: finite_induct)
     case (insert x F)
     have "finite (set -` {x} \<inter> {xs. distinct xs})"
       apply (simp add: vimage_def)
       by (metis Collect_conj_eq distinct_finite_set)
     with insert show ?case
       apply (subst vimage_insert)
       apply (subst Int_Un_distrib2)
       apply (rule finite_UnI)
         apply simp_all
       done
   qed simp
   moreover from dist show "A \<subseteq> ..."
     by (auto simp add: vimage_image_eq)
 qed
 
 
 subsubsection \<open>Infinite Set\<close>
 lemma INFM_nat_inductI:
   assumes P0: "P (0::nat)"
   assumes PS: "\<And>i. P i \<Longrightarrow> \<exists>j>i. P j \<and> Q j"
   shows "\<exists>\<^sub>\<infinity>i. Q i"
 proof -
   have "\<forall>i. \<exists>j>i. P j \<and> Q j" proof
     fix i
     show "\<exists>j>i. P j \<and> Q j"
       apply (induction i)
       using PS[OF P0] apply auto []
       by (metis PS Suc_lessI)
   qed
   thus ?thesis unfolding INFM_nat by blast
 qed
 
 subsection \<open>Functions\<close>
 
 lemma fun_neq_ext_iff: "m\<noteq>m' \<longleftrightarrow> (\<exists>x. m x \<noteq> m' x)" by auto  
 
 definition "inv_on f A x == SOME y. y\<in>A \<and> f y = x"
 
 lemma inv_on_f_f[simp]: "\<lbrakk>inj_on f A; x\<in>A\<rbrakk> \<Longrightarrow> inv_on f A (f x) = x"
   by (auto simp add: inv_on_def inj_on_def)
 
 lemma f_inv_on_f: "\<lbrakk> y\<in>f`A \<rbrakk> \<Longrightarrow> f (inv_on f A y) = y"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inv_on_f_range: "\<lbrakk> y \<in> f`A \<rbrakk> \<Longrightarrow> inv_on f A y \<in> A"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inj_on_map_inv_f [simp]: "\<lbrakk>set l \<subseteq> A; inj_on f A\<rbrakk> \<Longrightarrow> map (inv_on f A) (map f l) = l"
   apply (simp)
   apply (induct l)
   apply auto
   done
 
 lemma comp_cong_right: "x = y \<Longrightarrow> f o x = f o y" by (simp)
 lemma comp_cong_left: "x = y \<Longrightarrow> x o f = y o f" by (simp)
 
 lemma fun_comp_eq_conv: "f o g = fg \<longleftrightarrow> (\<forall>x. f (g x) = fg x)"
   by auto
 
 abbreviation comp2 (infixl "oo" 55) where "f oo g \<equiv> \<lambda>x. f o (g x)"
 abbreviation comp3 (infixl "ooo" 55) where "f ooo g \<equiv> \<lambda>x. f oo (g x)"
 
 notation
   comp2  (infixl "\<circ>\<circ>" 55) and
   comp3  (infixl "\<circ>\<circ>\<circ>" 55)
 
 definition [code_unfold, simp]: "swap_args2 f x y \<equiv> f y x"
   
 
 subsection \<open>Multisets\<close>
 
 (*
   The following is a syntax extension for multisets. Unfortunately, it depends on a change in the Library/Multiset.thy, so it is commented out here, until it will be incorporated
   into Library/Multiset.thy by its maintainers.
 
   The required change in Library/Multiset.thy is removing the syntax for single:
      - single :: "'a => 'a multiset"    ("{#_#}")
      + single :: "'a => 'a multiset"
 
   And adding the following translations instead:
 
      + syntax
      + "_multiset" :: "args \<Rightarrow> 'a multiset" ("{#(_)#}")
 
      + translations
      +   "{#x, xs#}" == "{#x#} + {#xs#}"
      +   "{# x #}" == "single x"
 
   This translates "{# \<dots> #}" into a sum of singletons, that is parenthesized to the right. ?? Can we also achieve left-parenthesizing ??
 
 *)
 
 
   (* Let's try what happens if declaring AC-rules for multiset union as simp-rules *)
 (*declare union_ac[simp] -- don't do it !*)
 
 
 lemma count_mset_set_finite_iff:
   "finite S \<Longrightarrow> count (mset_set S) a = (if a \<in> S then 1 else 0)"
   by simp
 
 lemma ex_Melem_conv: "(\<exists>x. x \<in># A) = (A \<noteq> {#})"
   by (simp add: ex_in_conv)
 
 subsubsection \<open>Count\<close>
         lemma count_ne_remove: "\<lbrakk> x ~= t\<rbrakk> \<Longrightarrow> count S x = count (S-{#t#}) x"
           by (auto)
   lemma mset_empty_count[simp]: "(\<forall>p. count M p = 0) = (M={#})"
     by (auto simp add: multiset_eq_iff)
 
 subsubsection \<open>Union, difference and intersection\<close>
 
   lemma size_diff_se: "t \<in># S \<Longrightarrow> size S = size (S - {#t#}) + 1" proof (unfold size_multiset_overloaded_eq)
                 let ?SIZE = "sum (count S) (set_mset S)"
                 assume A: "t \<in># S"
                 from A have SPLITPRE: "finite (set_mset S) & {t}\<subseteq>(set_mset S)" by auto
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + sum (count S) {t}" by (blast dest: sum.subset_diff)
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + count (S) t" by auto
                 moreover with A have "count S t = count (S-{#t#}) t + 1" by auto
                 ultimately have D: "?SIZE = sum (count S) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (arith)
                 moreover have "sum (count S) (set_mset S - {t}) = sum (count (S-{#t#})) (set_mset S - {t})" proof -
                         have "\<forall>x\<in>(set_mset S - {t}). count S x = count (S-{#t#}) x" by (auto iff add: count_ne_remove)
                         thus ?thesis by simp
                 qed
                 ultimately have D: "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (simp)
                 moreover
                 { assume CASE: "t \<notin># S - {#t#}"
                         from CASE have "set_mset S - {t} = set_mset (S - {#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         with CASE D have "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1"
                           by (simp add: not_in_iff)
                 }
                 moreover
                 { assume CASE: "t \<in># S - {#t#}"
                         from CASE have "t \<in># S" by (rule in_diffD)
                         with CASE have 1: "set_mset S = set_mset (S-{#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         moreover from D have "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t} + 1" by simp
                         moreover from SPLITPRE sum.subset_diff have "sum (count (S-{#t#})) (set_mset S) = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t}" by (blast)
                         ultimately have "?SIZE = sum (count (S-{#t#})) (set_mset (S-{#t#})) + 1" by simp
                 }
                 ultimately show "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1" by blast
         qed
 
   (* TODO: Check whether this proof can be done simpler *)
   lemma mset_union_diff_comm: "t \<in># S \<Longrightarrow> T + (S - {#t#}) = (T + S) - {#t#}" proof -
     assume "t \<in># S"
     then obtain S' where S: "S = add_mset t S'"
       by (metis insert_DiffM)
     then show ?thesis
       by auto
   qed
 
 (*  lemma mset_diff_diff_left: "A-B-C = A-((B::'a multiset)+C)" proof -
     have "\<forall>e . count (A-B-C) e = count (A-(B+C)) e" by auto
     thus ?thesis by (simp add: multiset_eq_conv_count_eq)
   qed
 
   lemma mset_diff_commute: "A-B-C = A-C-(B::'a multiset)" proof -
     have "A-B-C = A-(B+C)" by (simp add: mset_diff_diff_left)
     also have "\<dots> = A-(C+B)" by (simp add: union_commute)
     thus ?thesis by (simp add: mset_diff_diff_left)
   qed
 
   lemma mset_diff_same_empty[simp]: "(S::'a multiset) - S = {#}"
   proof -
     have "\<forall>e . count (S-S) e = 0" by auto
     hence "\<forall>e . ~ (e : set_mset (S-S))" by auto
     hence "set_mset (S-S) = {}" by blast
     thus ?thesis by (auto)
   qed
 *)
     
   lemma mset_right_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># B)\<rbrakk> \<Longrightarrow> a\<in>#A"
     by (simp)
   lemma mset_left_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># A)\<rbrakk> \<Longrightarrow> a\<in>#B"
     by (simp)
 
   lemmas mset_cancel_union = mset_right_cancel_union mset_left_cancel_union
 
   lemma mset_right_cancel_elem: "\<lbrakk>a \<in># A+{#b#}; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemma mset_left_cancel_elem: "\<lbrakk>a \<in># {#b#}+A; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemmas mset_cancel_elem = mset_right_cancel_elem mset_left_cancel_elem
 
   lemma mset_diff_cancel1elem[simp]: "~(a \<in># B) \<Longrightarrow> {#a#}-B = {#a#}"
     by (auto simp add: not_in_iff intro!: multiset_eqI)
 
 (*  lemma diff_union_inverse[simp]: "A + B - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 
   lemma diff_union_inverse2[simp]: "B + A - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 *)
   (*lemma union_diff_assoc_se2: "t \<in># A \<Longrightarrow> (A+B)-{#t#} = (A-{#t#}) + B"
     by (auto iff add: multiset_eq_conv_count_eq)
   lemmas union_diff_assoc_se = union_diff_assoc_se1 union_diff_assoc_se2*)
 
         lemma union_diff_assoc: "C-B={#} \<Longrightarrow> (A+B)-C = A + (B-C)"
           by (simp add: multiset_eq_iff)
 
   lemmas mset_neutral_cancel1 = union_left_cancel[where N="{#}", simplified] union_right_cancel[where N="{#}", simplified]
   declare mset_neutral_cancel1[simp]
 
   lemma mset_union_2_elem: "{#a, b#} = add_mset c M \<Longrightarrow> {#a#}=M & b=c | a=c & {#b#}=M"
     by (auto simp: add_eq_conv_diff)
 
   lemma mset_un_cases[cases set, case_names left right]:
     "\<lbrakk>a \<in># A + B; a \<in># A \<Longrightarrow> P; a \<in># B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (auto)
 
   lemma mset_unplusm_dist_cases[cases set, case_names left right]:
     assumes A: "{#s#}+A = B+C"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
   proof -
     from A[symmetric] have "s \<in># B+C" by simp
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence 1: "B={#s#}+(B-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+((B-{#s#})+C)" by (simp add: union_ac)
       hence 2: "A = (B-{#s#})+C" by (simp)
       from L[OF 1 2] show ?thesis .
     next
       case right hence 1: "C={#s#}+(C-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+(B+(C-{#s#}))" by (simp add: union_ac)
       hence 2: "A = B+(C-{#s#})" by (simp)
       from R[OF 1 2] show ?thesis .
     qed
   qed
 
   lemma mset_unplusm_dist_cases2[cases set, case_names left right]:
     assumes A: "B+C = {#s#}+A"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
     using mset_unplusm_dist_cases[OF A[symmetric]] L R by blast
 
   lemma mset_single_cases[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'={#s#}+(c'-{#s#}); c={#r'#}+(c-{#r'#}); c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume CASE: "s=r'"
       with A have "c=c'" by simp
       with CASE CASES have ?thesis by auto
     } moreover {
       assume CASE: "s\<noteq>r'"
       have "s \<in># {#s#}+c" by simp
       with A have "s \<in># {#r'#}+c'" by simp
       with CASE have "s \<in># c'" by simp
       hence 1: "c' = {#s#} + (c' - {#s#})" by simp
       with A have "{#s#}+c = {#s#}+({#r'#}+(c' - {#s#}))" by (auto simp add: union_ac)
       hence 2: "c={#r'#}+(c' - {#s#})" by (auto)
       hence 3: "c-{#r'#} = (c' - {#s#})" by auto
       from 1 2 3 CASES have ?thesis by auto
     } ultimately show ?thesis by blast
   qed
 
   lemma mset_single_cases'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'={#s#}+cc; c={#r'#}+cc; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases)
 
   lemma mset_single_cases2[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'=(c'-{#s#})+{#s#}; c=(c-{#r'#})+{#r'#}; c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     from A have "add_mset s c = add_mset r' c'" by (simp add: union_ac)
     thus ?thesis using CASES by (cases rule: mset_single_cases) simp_all
   qed
 
   lemma mset_single_cases2'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'=cc+{#s#}; c=cc+{#r'#}; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases2)
 
   lemma mset_un_single_un_cases [consumes 1, case_names left right]:
     assumes A: "add_mset a A = B + C"
       and CASES: "a \<in># B \<Longrightarrow> A = (B - {#a#}) + C \<Longrightarrow> P"
         "a \<in># C \<Longrightarrow> A = B + (C - {#a#}) \<Longrightarrow> P" shows "P"
   proof -
     have "a \<in># A+{#a#}" by simp
     with A have "a \<in># B+C" by auto
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence "B=B-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = (B-{#a#})+C+{#a#}" by (auto simp add: union_ac)
       hence "A=(B-{#a#})+C" by simp
       with CASES(1)[OF left] show ?thesis by blast
     next
       case right hence "C=C-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = B+(C-{#a#})+{#a#}" by (auto simp add: union_ac)
       hence "A=B+(C-{#a#})" by simp
       with CASES(2)[OF right] show ?thesis by blast
     qed
   qed
 
       (* TODO: Can this proof be done more automatically ? *)
   lemma mset_distrib[consumes 1, case_names dist]: assumes A: "(A::'a multiset)+B = M+N" "!!Am An Bm Bn. \<lbrakk>A=Am+An; B=Bm+Bn; M=Am+Bm; N=An+Bn\<rbrakk> \<Longrightarrow> P" shows "P"
   proof -
     have BN_MA: "B - N = M - A"
       by (metis (no_types) add_diff_cancel_right assms(1) union_commute)
     have H: "A = A\<inter># C + (A - C) \<inter># D" if "A + B = C + D" for A B C D :: "'a multiset"
       by (metis add.commute diff_intersect_left_idem mset_subset_eq_add_left subset_eq_diff_conv
           subset_mset.add_diff_inverse subset_mset.inf_absorb1 subset_mset.inf_le1 that)
     have A': "A = A\<inter># M + (A - M) \<inter># N"
       using A(1) H by blast
     moreover have B': "B = (B - N) \<inter># M + B\<inter># N"
       using A(1) H[of B A N M] by (auto simp: ac_simps)
     moreover have "M = A \<inter># M + (B - N) \<inter># M"
       using H[of M N A B] BN_MA[symmetric] A(1) by (metis (no_types) diff_intersect_left_idem
           diff_union_cancelR multiset_inter_commute subset_mset.diff_add subset_mset.inf.cobounded1
           union_commute)
     moreover have "N = (A - M) \<inter># N + B \<inter># N"
       by (metis A' assms(1) diff_union_cancelL inter_union_distrib_left inter_union_distrib_right
           mset_subset_eq_multiset_union_diff_commute subset_mset.inf.cobounded1 subset_mset.inf.commute)
     ultimately show P
       using A(2) by blast
   qed
 
 
 subsubsection \<open>Singleton multisets\<close>
 
 lemma mset_size_le1_cases[case_names empty singleton,consumes 1]: "\<lbrakk> size M \<le> Suc 0; M={#} \<Longrightarrow> P; !!m. M={#m#} \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by (cases M) auto
 
 lemma diff_union_single_conv2: "a \<in># J \<Longrightarrow> J + I - {#a#} = (J - {#a#}) + I"
   by simp
 
 lemmas diff_union_single_convs = diff_union_single_conv diff_union_single_conv2
 
 lemma mset_contains_eq: "(m \<in># M) = ({#m#}+(M-{#m#})=M)"
   using diff_single_trivial by fastforce
 
 
 subsubsection \<open>Pointwise ordering\<close>
 
 
   (*declare mset_le_trans[trans] Seems to be in there now. Why is this not done in Multiset.thy or order-class ? *)
 
   lemma mset_le_incr_right1: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b+c" using mset_subset_eq_mono_add[of a b "{#}" c, simplified] .
   lemma mset_le_incr_right2: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#c+b" using mset_le_incr_right1
     by (auto simp add: union_commute)
   lemmas mset_le_incr_right = mset_le_incr_right1 mset_le_incr_right2
 
   lemma mset_le_decr_left1: "a+c\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_incr_right1 mset_subset_eq_mono_add_right_cancel
     by blast
   lemma mset_le_decr_left2: "c+a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_decr_left1
     by (auto simp add: union_ac)
   lemma mset_le_add_mset_decr_left1: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
   lemma mset_le_add_mset_decr_left2: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> {#c#}\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
 
   lemmas mset_le_decr_left = mset_le_decr_left1 mset_le_decr_left2 mset_le_add_mset_decr_left1
     mset_le_add_mset_decr_left2
 
   lemma mset_le_subtract: "A\<subseteq>#B \<Longrightarrow> A-C \<subseteq># B-(C::'a multiset)"
     apply (unfold subseteq_mset_def count_diff)
     apply clarify
     apply (subgoal_tac "count A a \<le> count B a")
     apply arith
     apply simp
     done
 
   lemma mset_union_subset: "A+B \<subseteq># C \<Longrightarrow> A\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_add_mset: "add_mset x B \<subseteq># C \<Longrightarrow> {#x#}\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_subtract_left: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-A \<and> A\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "A"] mset_union_subset)
   lemma mset_le_subtract_right: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> A \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "B"] mset_union_subset)
 
   lemma mset_le_subtract_add_mset_left: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-{#x#} \<and> {#x#}\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "{#x#}"] mset_le_add_mset)
 
   lemma mset_le_subtract_add_mset_right: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> {#x#} \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "B"] mset_le_add_mset)
 
   lemma mset_le_addE: "\<lbrakk> xs \<subseteq># (ys::'a multiset); !!zs. ys=xs+zs \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" using mset_subset_eq_exists_conv
     by blast
 
   declare subset_mset.diff_add[simp, intro]
 
   lemma mset_2dist2_cases:
     assumes A: "{#a#}+{#b#} \<subseteq># A+B"
     assumes CASES: "{#a#}+{#b#} \<subseteq># A \<Longrightarrow> P" "{#a#}+{#b#} \<subseteq># B \<Longrightarrow> P" "\<lbrakk>a \<in># A; b \<in># B\<rbrakk> \<Longrightarrow> P" "\<lbrakk>a \<in># B; b \<in># A\<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume C: "a \<in># A" "b \<in># A-{#a#}"
       with mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "A-{#a#}"] have "{#a#}+{#b#} \<subseteq># A" by auto
     } moreover {
       assume C: "a \<in># A" "\<not> (b \<in># A-{#a#})"
       with A have "b \<in># B"
         by (metis diff_union_single_conv2 mset_le_subtract_left mset_subset_eq_insertD mset_un_cases)
     } moreover {
       assume C: "\<not> (a \<in># A)" "b \<in># B-{#a#}"
       with A have "a \<in># B"
         by (auto dest: mset_subset_eqD)
        with C mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "B-{#a#}"] have "{#a#}+{#b#} \<subseteq># B" by auto
     } moreover {
       assume C: "\<not> (a \<in># A)" "\<not> (b \<in># B-{#a#})"
       with A have "a \<in># B \<and> b \<in># A"
         apply (intro conjI)
          apply (auto dest!: mset_subset_eq_insertD simp: insert_union_subset_iff; fail)[]
         by (metis mset_diff_cancel1elem mset_le_subtract_left multiset_diff_union_assoc
             single_subset_iff subset_eq_diff_conv)
     } ultimately show P using CASES by blast
   qed
 
 
   lemma mset_union_subset_s: "{#a#}+B \<subseteq># C \<Longrightarrow> a \<in># C \<and> B \<subseteq># C"
     by (drule mset_union_subset) simp
 
   (* TODO: Check which of these lemmas are already introduced by order-classes ! *)
 
 
   lemma mset_le_single_cases[consumes 1, case_names empty singleton]: "\<lbrakk>M\<subseteq>#{#a#}; M={#} \<Longrightarrow> P; M={#a#} \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (induct M) auto
 
   lemma mset_le_distrib[consumes 1, case_names dist]: "\<lbrakk>(X::'a multiset)\<subseteq>#A+B; !!Xa Xb. \<lbrakk>X=Xa+Xb; Xa\<subseteq>#A; Xb\<subseteq>#B\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto elim!: mset_le_addE mset_distrib)
 
 lemma mset_le_mono_add_single: "\<lbrakk>a \<in># ys; b \<in># ws\<rbrakk> \<Longrightarrow> {#a#} + {#b#} \<subseteq># ys + ws"
   by (meson mset_subset_eq_mono_add single_subset_iff)
 
   lemma mset_size1elem: "\<lbrakk>size P \<le> 1; q \<in># P\<rbrakk> \<Longrightarrow> P={#q#}"
     by (auto elim: mset_size_le1_cases)
   lemma mset_size2elem: "\<lbrakk>size P \<le> 2; {#q#}+{#q'#} \<subseteq># P\<rbrakk> \<Longrightarrow> P={#q#}+{#q'#}"
     by (auto elim: mset_le_addE)
 
 
 subsubsection \<open>Image under function\<close>
 
 notation image_mset (infixr "`#" 90)
 
 lemma mset_map_split_orig: "!!M1 M2. \<lbrakk>f `# P = M1+M2; !!P1 P2. \<lbrakk>P=P1+P2; f `# P1 = M1; f `# P2 = M2\<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   by (induct P) (force elim!: mset_un_single_un_cases)+
 
 lemma mset_map_id: "\<lbrakk>!!x. f (g x) = x\<rbrakk> \<Longrightarrow> f `# g `# X = X"
   by (induct X) auto
 
 text \<open>The following is a very specialized lemma. Intuitively, it splits the original multiset
   by a splitting of some pointwise supermultiset of its image.
 
   Application:
   This lemma came in handy when proving the correctness of a constraint system that collects at most k sized submultisets of the sets of spawned threads.
 \<close>
 lemma mset_map_split_orig_le: assumes A: "f `# P \<subseteq># M1+M2" and EX: "!!P1 P2. \<lbrakk>P=P1+P2; f `# P1 \<subseteq># M1; f `# P2 \<subseteq># M2\<rbrakk> \<Longrightarrow> Q" shows "Q"
   using A EX by (auto elim: mset_le_distrib mset_map_split_orig)
 
 
 subsection \<open>Lists\<close>
 
 
 lemma len_greater_imp_nonempty[simp]: "length l > x \<Longrightarrow> l\<noteq>[]"
   by auto
 
 lemma list_take_induct_tl2:
   "\<lbrakk>length xs = length ys; \<forall>n<length xs. P (ys ! n) (xs ! n)\<rbrakk>
     \<Longrightarrow> \<forall>n < length (tl xs). P ((tl ys) ! n) ((tl xs) ! n)"
 by (induct xs ys rule: list_induct2) auto
 
 lemma not_distinct_split_distinct:
   assumes "\<not> distinct xs"
   obtains y ys zs where "distinct ys" "y \<in> set ys" "xs = ys@[y]@zs"
 using assms
 proof (induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs) thus ?case by (cases "distinct xs") auto
 qed
 
 lemma distinct_length_le:
   assumes d: "distinct ys"
   and eq: "set ys = set xs"
   shows "length ys \<le> length xs"
 proof -
   from d have "length ys = card (set ys)" by (simp add: distinct_card)
   also from eq List.card_set have "card (set ys) = length (remdups xs)" by simp
   also have "... \<le> length xs" by simp
   finally show ?thesis .
 qed
 
 lemma find_SomeD:
   "List.find P xs = Some x \<Longrightarrow> P x"
   "List.find P xs = Some x \<Longrightarrow> x\<in>set xs"
   by (auto simp add: find_Some_iff)
 
 lemma in_hd_or_tl_conv[simp]: "l\<noteq>[] \<Longrightarrow> x=hd l \<or> x\<in>set (tl l) \<longleftrightarrow> x\<in>set l"
   by (cases l) auto
 
 lemma length_dropWhile_takeWhile:
   assumes "x < length (dropWhile P xs)"
   shows "x + length (takeWhile P xs) < length xs"
   using assms
   by (induct xs) auto
 
 text \<open>Elim-version of @{thm neq_Nil_conv}.\<close>  
 lemma neq_NilE: 
   assumes "l\<noteq>[]"
   obtains x xs where "l=x#xs" 
   using assms by (metis list.exhaust)
 
     
 lemma length_Suc_rev_conv: "length xs = Suc n \<longleftrightarrow> (\<exists>ys y. xs=ys@[y] \<and> length ys = n)"
   by (cases xs rule: rev_cases) auto
 
     
 subsubsection \<open>List Destructors\<close>
 lemma not_hd_in_tl:
   "x \<noteq> hd xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set (tl xs)"
 by (induct xs) simp_all
 
 lemma distinct_hd_tl:
   "distinct xs \<Longrightarrow> x = hd xs \<Longrightarrow> x \<notin> set (tl (xs))"
 by (induct xs) simp_all
 
 lemma in_set_tlD: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
 by (induct xs) simp_all
 
 lemma nth_tl: "xs \<noteq> [] \<Longrightarrow> tl xs ! n = xs ! Suc n"
 by (induct xs) simp_all
 
 lemma tl_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (tl xs) \<subseteq> A"
 by (metis in_set_tlD rev_subsetD subsetI)
 
 lemma tl_last:
   "tl xs \<noteq> [] \<Longrightarrow> last xs = last (tl xs)"
 by (induct xs) simp_all
 
 lemma tl_obtain_elem:
   assumes "xs \<noteq> []" "tl xs = []"
   obtains e where "xs = [e]"
 using assms
 by (induct xs rule: list_nonempty_induct) simp_all
 
 lemma butlast_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (butlast xs) \<subseteq> A"
 by (metis in_set_butlastD rev_subsetD subsetI)
 
 lemma butlast_rev_tl:
   "xs \<noteq> [] \<Longrightarrow> butlast (rev xs) = rev (tl xs)"
 by (induct xs rule: rev_induct) simp_all
 
 lemma hd_butlast:
   "length xs > 1 \<Longrightarrow> hd (butlast xs) = hd xs"
 by (induct xs) simp_all
 
 lemma butlast_upd_last_eq[simp]: "length l \<ge> 2 \<Longrightarrow>
   (butlast l) [ length l - 2 := x ] = take (length l - 2) l @ [x]"
   apply (case_tac l rule: rev_cases)
   apply simp
   apply simp
   apply (case_tac ys rule: rev_cases)
   apply simp
   apply simp
   done
 
 lemma distinct_butlast_swap[simp]: 
   "distinct pq \<Longrightarrow> distinct (butlast (pq[i := last pq]))"
   apply (cases pq rule: rev_cases)
   apply (auto simp: list_update_append distinct_list_update split: nat.split)
   done
 
 subsubsection \<open>Splitting list according to structure of other list\<close>
 context begin
 private definition "SPLIT_ACCORDING m l \<equiv> length l = length m"
 
 private lemma SPLIT_ACCORDINGE: 
   assumes "length m = length l"
   obtains "SPLIT_ACCORDING m l"
   unfolding SPLIT_ACCORDING_def using assms by auto
 
 private lemma SPLIT_ACCORDING_simp:
   "SPLIT_ACCORDING m (l1@l2) \<longleftrightarrow> (\<exists>m1 m2. m=m1@m2 \<and> SPLIT_ACCORDING m1 l1 \<and> SPLIT_ACCORDING m2 l2)"
   "SPLIT_ACCORDING m (x#l') \<longleftrightarrow> (\<exists>y m'. m=y#m' \<and> SPLIT_ACCORDING m' l')"
   apply (fastforce simp: SPLIT_ACCORDING_def intro: exI[where x = "take (length l1) m"] exI[where x = "drop (length l1) m"])
   apply (cases m;auto simp: SPLIT_ACCORDING_def)
   done
 
 text \<open>Split structure of list @{term m} according to structure of list @{term l}.\<close>
 method split_list_according for m :: "'a list" and l :: "'b list" =
   (rule SPLIT_ACCORDINGE[of m l],
     (simp; fail),
     ( simp only: SPLIT_ACCORDING_simp,
       elim exE conjE, 
       simp only: SPLIT_ACCORDING_def
     )
   ) 
 end
   
     
     
 subsubsection \<open>\<open>list_all2\<close>\<close>
 lemma list_all2_induct[consumes 1, case_names Nil Cons]:
   assumes "list_all2 P l l'"
   assumes "Q [] []"
   assumes "\<And>x x' ls ls'. \<lbrakk> P x x'; list_all2 P ls ls'; Q ls ls' \<rbrakk>
     \<Longrightarrow> Q (x#ls) (x'#ls')"
   shows "Q l l'"
   using list_all2_lengthD[OF assms(1)] assms
   apply (induct rule: list_induct2)
   apply auto
   done
 
 
 subsubsection \<open>Indexing\<close>    
 
 lemma ran_nth_set_encoding_conv[simp]: 
   "ran (\<lambda>i. if i<length l then Some (l!i) else None) = set l"
   apply safe
   apply (auto simp: ran_def split: if_split_asm) []
   apply (auto simp: in_set_conv_nth intro: ranI) []
   done
 
 lemma nth_image_indices[simp]: "(!) l ` {0..<length l} = set l"
   by (auto simp: in_set_conv_nth)
 
 lemma nth_update_invalid[simp]:"\<not>i<length l \<Longrightarrow> l[j:=x]!i = l!i"  
   apply (induction l arbitrary: i j)
   apply (auto split: nat.splits)
   done
 
 lemma nth_list_update': "l[i:=x]!j = (if i=j \<and> i<length l then x else l!j)"  
   by auto
 
 lemma last_take_nth_conv: "n \<le> length l \<Longrightarrow> n\<noteq>0 \<Longrightarrow> last (take n l) = l!(n - 1)"
   apply (induction l arbitrary: n)
   apply (auto simp: take_Cons split: nat.split)
   done
 
 lemma nth_append_first[simp]: "i<length l \<Longrightarrow> (l@l')!i = l!i"
   by (simp add: nth_append) 
     
 lemma in_set_image_conv_nth: "f x \<in> f`set l \<longleftrightarrow> (\<exists>i<length l. f (l!i) = f x)"
   by (auto simp: in_set_conv_nth) (metis image_eqI nth_mem)
 
 lemma set_image_eq_pointwiseI: 
   assumes "length l = length l'"
   assumes "\<And>i. i<length l \<Longrightarrow> f (l!i) = f (l'!i)"  
   shows "f`set l = f`set l'"
   using assms
   by (fastforce simp: in_set_conv_nth in_set_image_conv_nth)
   
 lemma insert_swap_set_eq: "i<length l \<Longrightarrow> insert (l!i) (set (l[i:=x])) = insert x (set l)"
   by (auto simp: in_set_conv_nth nth_list_update split: if_split_asm)
     
     
 subsubsection \<open>Reverse lists\<close>
   lemma neq_Nil_revE: 
     assumes "l\<noteq>[]" 
     obtains ll e  where "l = ll@[e]"
     using assms by (cases l rule: rev_cases) auto
       
   lemma neq_Nil_rev_conv: "l\<noteq>[] \<longleftrightarrow> (\<exists>xs x. l = xs@[x])"
     by (cases l rule: rev_cases) auto
 
   text \<open>Caution: Same order of case variables in snoc-case as @{thm [source] rev_exhaust}, the other way round than @{thm [source] rev_induct} !\<close>
   lemma length_compl_rev_induct[case_names Nil snoc]: "\<lbrakk>P []; !! l e . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (l@[e])\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs" rule: rev_cases)
     apply(auto)
   done
 
   lemma list_append_eq_Cons_cases[consumes 1]: "\<lbrakk>ys@zs = x#xs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: append_eq_Cons_conv)
   lemma list_Cons_eq_append_cases[consumes 1]: "\<lbrakk>x#xs = ys@zs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: Cons_eq_append_conv)
 
 lemma map_of_rev_distinct[simp]:
   "distinct (map fst m) \<Longrightarrow> map_of (rev m) = map_of m"
   apply (induct m)
     apply simp
 
     apply simp
     apply (subst map_add_comm)
       apply force
       apply simp
   done
 
 
 \<comment> \<open>Tail-recursive, generalized @{const rev}. May also be used for
       tail-recursively getting a list with all elements of the two
       operands, if the order does not matter, e.g. when implementing
       sets by lists.\<close>
 fun revg where
   "revg [] b = b" |
   "revg (a#as) b = revg as (a#b)"
 
 lemma revg_fun[simp]: "revg a b = rev a @ b"
   by (induct a arbitrary: b)
       auto
 
 lemma rev_split_conv[simp]:
   "l \<noteq> [] \<Longrightarrow> rev (tl l) @ [hd l] = rev l"
 by (induct l) simp_all
 
 lemma rev_butlast_is_tl_rev: "rev (butlast l) = tl (rev l)"
   by (induct l) auto
 
 lemma hd_last_singletonI:
   "\<lbrakk>xs \<noteq> []; hd xs = last xs; distinct xs\<rbrakk> \<Longrightarrow> xs = [hd xs]"
   by (induct xs rule: list_nonempty_induct) auto
 
 lemma last_filter:
   "\<lbrakk>xs \<noteq> []; P (last xs)\<rbrakk> \<Longrightarrow> last (filter P xs) = last xs"
   by (induct xs rule: rev_nonempty_induct) simp_all
 
 (* As the following two rules are similar in nature to list_induct2',
    they are named accordingly. *)
 lemma rev_induct2' [case_names empty snocl snocr snoclr]:
   assumes empty: "P [] []"
   and snocl: "\<And>x xs. P (xs@[x]) []"
   and snocr: "\<And>y ys. P [] (ys@[y])"
   and snoclr: "\<And>x xs y ys.  P xs ys  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
 proof (induct xs arbitrary: ys rule: rev_induct)
   case Nil thus ?case using empty snocr
     by (cases ys rule: rev_exhaust) simp_all
 next
   case snoc thus ?case using snocl snoclr
     by (cases ys rule: rev_exhaust) simp_all
 qed
 
 lemma rev_nonempty_induct2' [case_names single snocl snocr snoclr, consumes 2]:
   assumes "xs \<noteq> []" "ys \<noteq> []"
   assumes single': "\<And>x y. P [x] [y]"
   and snocl: "\<And>x xs y. xs \<noteq> [] \<Longrightarrow> P (xs@[x]) [y]"
   and snocr: "\<And>x y ys. ys \<noteq> [] \<Longrightarrow> P [x] (ys@[y])"
   and snoclr: "\<And>x xs y ys. \<lbrakk>P xs ys; xs \<noteq> []; ys\<noteq>[]\<rbrakk>  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
   using assms(1,2)
 proof (induct xs arbitrary: ys rule: rev_nonempty_induct)
   case single then obtain z zs where "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using single' snocr
     by (cases "zs = []") simp_all
 next
   case (snoc x xs) then obtain z zs where zs: "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using snocl snoclr snoc
     by (cases "zs = []") simp_all
 qed
 
 
 subsubsection "Folding"
 
 text "Ugly lemma about foldl over associative operator with left and right neutral element"
 lemma foldl_A1_eq: "!!i. \<lbrakk> !! e. f n e = e; !! e. f e n = e; !!a b c. f a (f b c) = f (f a b) c \<rbrakk> \<Longrightarrow> foldl f i ww = f i (foldl f n ww)"
 proof (induct ww)
   case Nil thus ?case by simp
 next
   case (Cons a ww i) note IHP[simplified]=this
   have "foldl f i (a # ww) = foldl f (f i a) ww" by simp
   also from IHP have "\<dots> = f (f i a) (foldl f n ww)" by blast
   also from IHP(4) have "\<dots> = f i (f a (foldl f n ww))" by simp
   also from IHP(1)[OF IHP(2,3,4), where i=a] have "\<dots> = f i (foldl f a ww)" by simp
   also from IHP(2)[of a] have "\<dots> = f i (foldl f (f n a) ww)" by simp
   also have "\<dots> = f i (foldl f n (a#ww))" by simp
   finally show ?case .
 qed
 
 
 lemmas foldl_conc_empty_eq = foldl_A1_eq[of "(@)" "[]", simplified]
 lemmas foldl_un_empty_eq = foldl_A1_eq[of "(\<union>)" "{}", simplified, OF Un_assoc[symmetric]]
 
 lemma foldl_set: "foldl (\<union>) {} l = \<Union>{x. x\<in>set l}"
   apply (induct l)
   apply simp_all
   apply (subst foldl_un_empty_eq)
   apply auto
   done
 
 lemma (in monoid_mult) foldl_absorb1: "x*foldl (*) 1 zs = foldl (*) x zs"
   apply (rule sym)
   apply (rule foldl_A1_eq)
   apply (auto simp add: mult.assoc)
 done
 
 text \<open>Towards an invariant rule for foldl\<close>
 lemma foldl_rule_aux:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   shows "I (foldl f \<sigma>0 l0) []"
   using initial step
   apply (induct l0 arbitrary: \<sigma>0)
   apply auto
   done
 
 lemma foldl_rule_aux_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   assumes final: "!!\<sigma>. I \<sigma> [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
 using foldl_rule_aux[of I \<sigma>0 l0, OF initial, OF step] final
 by simp
 
 
 lemma foldl_rule:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 [] l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   shows "I (foldl f \<sigma>0 l0) l0 []"
   using initial step
   apply (rule_tac I="\<lambda>\<sigma> lr. \<exists>ll. l0=ll@lr \<and> I \<sigma> ll lr" in foldl_rule_aux_P)
   apply auto
   done
 
 text \<open>
   Invariant rule for foldl. The invariant is parameterized with
   the state, the list of items that have already been processed and
   the list of items that still have to be processed.
 \<close>
 lemma foldl_rule_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   \<comment> \<open>The invariant holds for the initial state, no items processed yet and all items to be processed:\<close>
   assumes initial: "I \<sigma>0 [] l0"
   \<comment> \<open>The invariant remains valid if one item from the list is processed\<close>
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   \<comment> \<open>The proposition follows from the invariant in the final state, i.e. all items processed and nothing to be processed\<close>
   assumes final: "!!\<sigma>. I \<sigma> l0 [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
   using foldl_rule[of I, OF initial step] by (simp add: final)
 
 
 text \<open>Invariant reasoning over @{const foldl} for distinct lists. Invariant rule makes no
   assumptions about ordering.\<close>
 lemma distinct_foldl_invar:
   "\<lbrakk> distinct S; I (set S) \<sigma>0;
      \<And>x it \<sigma>. \<lbrakk>x \<in> it; it \<subseteq> set S; I it \<sigma>\<rbrakk> \<Longrightarrow> I (it - {x}) (f \<sigma> x)
    \<rbrakk> \<Longrightarrow> I {} (foldl f \<sigma>0 S)"
 proof (induct S arbitrary: \<sigma>0)
   case Nil thus ?case by auto
 next
   case (Cons x S)
 
   note [simp] = Cons.prems(1)[simplified]
 
   show ?case
     apply simp
     apply (rule Cons.hyps)
   proof -
     from Cons.prems(1) show "distinct S" by simp
     from Cons.prems(3)[of x "set (x#S)", simplified,
                        OF Cons.prems(2)[simplified]]
     show "I (set S) (f \<sigma>0 x)" .
     fix xx it \<sigma>
     assume A: "xx\<in>it" "it \<subseteq> set S" "I it \<sigma>"
     show "I (it - {xx}) (f \<sigma> xx)" using A(2)
       apply (rule_tac Cons.prems(3))
       apply (simp_all add: A(1,3))
       apply blast
       done
   qed
 qed
 
 lemma foldl_length_aux: "foldl (\<lambda>i x. Suc i) a l = a + length l"
   by (induct l arbitrary: a) auto
 
 lemmas foldl_length[simp] = foldl_length_aux[where a=0, simplified]
 
 lemma foldr_length_aux: "foldr (\<lambda>x i. Suc i) l a = a + length l"
   by (induct l arbitrary: a rule: rev_induct) auto
 
 lemmas foldr_length[simp] = foldr_length_aux[where a=0, simplified]
 
 context comp_fun_commute begin
 
 lemma foldl_f_commute: "f a (foldl (\<lambda>a b. f b a) b xs) = foldl (\<lambda>a b. f b a) (f a b) xs"
 by(induct xs arbitrary: b)(simp_all add: fun_left_comm)
 
 lemma foldr_conv_foldl: "foldr f xs a = foldl (\<lambda>a b. f b a) a xs"
 by(induct xs arbitrary: a)(simp_all add: foldl_f_commute)
 
 end
 
 lemma filter_conv_foldr:
   "filter P xs = foldr (\<lambda>x xs. if P x then x # xs else xs) xs []"
 by(induct xs) simp_all
 
 lemma foldr_Cons: "foldr Cons xs [] = xs"
 by(induct xs) simp_all
 
 lemma foldr_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldr (\<lambda>(x, y). f y) (zip xs ys) b = foldr f ys b"
 proof(induct ys arbitrary: xs)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma foldl_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldl (\<lambda>b (x, y). f b y) b (zip xs ys) = foldl f b ys"
 proof(induct ys arbitrary: xs b)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma fst_foldl: "fst (foldl (\<lambda>(a, b) x. (f a x, g a b x)) (a, b) xs) = foldl f a xs"
 by(induct xs arbitrary: a b) simp_all
 
 lemma foldl_foldl_conv_concat: "foldl (foldl f) a xs = foldl f a (concat xs)"
 by(induct xs arbitrary: a) simp_all
 
 lemma foldl_list_update:
   "n < length xs \<Longrightarrow> foldl f a (xs[n := x]) = foldl f (f (foldl f a (take n xs)) x) (drop (Suc n) xs)"
 by(simp add: upd_conv_take_nth_drop)
 
 lemma map_by_foldl:
   fixes l :: "'a list" and f :: "'a \<Rightarrow> 'b"
   shows "foldl (\<lambda>l x. l@[f x]) [] l = map f l"
 proof -
   {
     fix l'
     have "foldl (\<lambda>l x. l@[f x]) l' l = l'@map f l"
       by (induct l arbitrary: l') auto
   } thus ?thesis by simp
 qed
 
 
 subsubsection \<open>Sorting\<close>
 
 lemma sorted_in_between:
   assumes A: "0\<le>i" "i<j" "j<length l"
   assumes S: "sorted l"
   assumes E: "l!i \<le> x" "x<l!j"
   obtains k where "i\<le>k" and "k<j" and "l!k\<le>x" and "x<l!(k+1)"
 proof -
   from A E have "\<exists>k. i\<le>k \<and> k<j \<and> l!k\<le>x \<and> x<l!(k+1)"
   proof (induct "j-i" arbitrary: i j)
     case (Suc d)
     show ?case proof (cases "l!(i+1) \<le> x")
       case True
       from True Suc.hyps have "d = j - (i + 1)" by simp
       moreover from True have "i+1 < j"
         by (metis Suc.prems Suc_eq_plus1 Suc_lessI not_less)
       moreover from True have "0\<le>i+1" by simp
       ultimately obtain k where
         "i+1\<le>k" "k<j" "l!k \<le> x" "x<l!(k+1)"
         using Suc.hyps(1)[of j "i+1"] Suc.prems True
         by auto
       thus ?thesis by (auto dest: Suc_leD)
     next
       case False
       show ?thesis proof (cases "x<(l!(j - 1))")
         case True
         from True Suc.hyps have "d = j - (i + 1)" by simp
         moreover from True Suc.prems have "i < j - 1"
           by (metis Suc_eq_plus1 Suc_lessI diff_Suc_1 less_diff_conv not_le)
         moreover from True Suc.prems have "j - 1 < length l" by simp
         ultimately obtain k where
           "i\<le>k" "k<j - 1" "l!k \<le> x" "x<l!(k+1)"
           using Suc.hyps(1)[of "j - 1" i] Suc.prems True
           by auto
         thus ?thesis by (auto dest: Suc_leD)
       next
         case False thus ?thesis using Suc
           apply clarsimp
           by (metis Suc_leI add_0_iff add_diff_inverse diff_Suc_1 le_add2 lessI
               not0_implies_Suc not_less)
       qed
     qed
   qed simp
   thus ?thesis by (blast intro: that)
 qed
 
 lemma sorted_hd_last:
   "\<lbrakk>sorted l; l\<noteq>[]\<rbrakk> \<Longrightarrow> hd l \<le> last l"
 by (metis eq_iff hd_Cons_tl last_in_set not_hd_in_tl sorted_wrt.simps(2))
 
 lemma (in linorder) sorted_hd_min:
   "\<lbrakk>xs \<noteq> []; sorted xs\<rbrakk> \<Longrightarrow> \<forall>x \<in> set xs. hd xs \<le> x"
 by (induct xs, auto)
 
 lemma sorted_append_bigger:
   "\<lbrakk>sorted xs; \<forall>x \<in> set xs. x \<le> y\<rbrakk> \<Longrightarrow> sorted (xs @ [y])"
 proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have s: "sorted xs" by (cases xs) simp_all
   from Cons have a: "\<forall>x\<in>set xs. x \<le> y" by simp
   from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
 qed
 
 lemma sorted_filter':
   "sorted l \<Longrightarrow> sorted (filter P l)"
   using sorted_filter[where f=id, simplified] .
 
 subsubsection \<open>Map\<close>
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] *)  
 lemma map_eq_consE: "\<lbrakk>map f ls = fa#fl; !!a l. \<lbrakk> ls=a#l; f a=fa; map f l = fl \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by auto
 
 lemma map_fst_mk_snd[simp]: "map fst (map (\<lambda>x. (x,k)) l) = l" by (induct l) auto
 lemma map_snd_mk_fst[simp]: "map snd (map (\<lambda>x. (k,x)) l) = l" by (induct l) auto
 lemma map_fst_mk_fst[simp]: "map fst (map (\<lambda>x. (k,x)) l) = replicate (length l) k" by (induct l) auto
 lemma map_snd_mk_snd[simp]: "map snd (map (\<lambda>x. (x,k)) l) = replicate (length l) k" by (induct l) auto
 
 lemma map_zip1: "map (\<lambda>x. (x,k)) l = zip l (replicate (length l) k)" by (induct l) auto
 lemma map_zip2: "map (\<lambda>x. (k,x)) l = zip (replicate (length l) k) l" by (induct l) auto
 lemmas map_zip=map_zip1 map_zip2
 
 (* TODO/FIXME: hope nobody changes nth to be underdefined! *)
 lemma map_eq_nth_eq:
   assumes A: "map f l = map f l'"
   shows "f (l!i) = f (l'!i)"
 proof -
   from A have "length l = length l'"
     by (metis length_map)
   thus ?thesis using A
     apply (induct arbitrary: i rule: list_induct2)
     apply simp
     apply (simp add: nth_def split: nat.split)
     done
 qed
 
 lemma map_upd_eq:
   "\<lbrakk>i<length l \<Longrightarrow> f (l!i) = f x\<rbrakk> \<Longrightarrow> map f (l[i:=x]) = map f l"
   by (metis list_update_beyond list_update_id map_update not_le_imp_less)
 
 
 
 
 lemma inj_map_inv_f [simp]: "inj f \<Longrightarrow> map (inv f) (map f l) = l"
   by (simp)
 
 lemma inj_on_map_the: "\<lbrakk>D \<subseteq> dom m; inj_on m D\<rbrakk> \<Longrightarrow> inj_on (the\<circ>m) D"
   apply (rule inj_onI)
   apply simp
   apply (case_tac "m x")
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply (auto intro: inj_onD) [1]
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply simp
   apply (rule inj_onD)
   apply assumption
   apply auto
   done
 
     
 
 lemma map_consI:
   "w=map f ww \<Longrightarrow> f a#w = map f (a#ww)"
   "w@l=map f ww@l \<Longrightarrow> f a#w@l = map f (a#ww)@l"
   by auto
 
 
 lemma restrict_map_subset_eq:
   fixes R
   shows "\<lbrakk>m |` R = m'; R'\<subseteq>R\<rbrakk> \<Longrightarrow> m|` R' = m' |` R'"
   by (auto simp add: Int_absorb1)
 
 lemma restrict_map_self[simp]: "m |` dom m = m"
   apply (rule ext)
   apply (case_tac "m x")
   apply (auto simp add: restrict_map_def)
   done
 
 lemma restrict_map_UNIV[simp]: "f |` UNIV = f"
   by (auto simp add: restrict_map_def)
 
 lemma restrict_map_inv[simp]: "f |` (- dom f) = Map.empty"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma restrict_map_upd: "(f |` S)(k \<mapsto> v) = f(k\<mapsto>v) |` (insert k S)"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma map_upd_eq_restrict: "m (x:=None) = m |` (-{x})"
   by (auto intro: ext)
 
 declare Map.finite_dom_map_of [simp, intro!]
 
 lemma dom_const'[simp]: "dom (\<lambda>x. Some (f x)) = UNIV"
   by auto
 
 lemma restrict_map_eq :
   "((m |` A) k = None) \<longleftrightarrow> (k \<notin> dom m \<inter> A)"
   "((m |` A) k = Some v) \<longleftrightarrow> (m k = Some v \<and> k \<in> A)"
 unfolding restrict_map_def
 by (simp_all add: dom_def)
 
 
 definition "rel_of m P == {(k,v). m k = Some v \<and> P (k, v)}"
 lemma rel_of_empty[simp]: "rel_of Map.empty P = {}"
     by (auto simp add: rel_of_def)
 
 lemma remove1_tl: "xs \<noteq> [] \<Longrightarrow> remove1 (hd xs) xs = tl xs"
   by (cases xs) auto
 
 lemma set_oo_map_alt: "(set \<circ>\<circ> map) f = (\<lambda>l. f ` set l)" by auto
     
 subsubsection "Filter and Revert"
 primrec filter_rev_aux where
   "filter_rev_aux a P [] = a"
 | "filter_rev_aux a P (x#xs) = (
      if P x then filter_rev_aux (x#a) P xs else filter_rev_aux a P xs)"
 
 lemma filter_rev_aux_alt: "filter_rev_aux a P l = filter P (rev l) @ a"
   by (induct l arbitrary: a) auto
 
 definition "filter_rev == filter_rev_aux []"
 lemma filter_rev_alt: "filter_rev P l = filter P (rev l)"
   unfolding filter_rev_def by (simp add: filter_rev_aux_alt)
 
 definition "remove_rev x == filter_rev (Not o (=) x)"
 lemma remove_rev_alt_def :
   "remove_rev x xs = (filter (\<lambda>y. y \<noteq> x) (rev xs))"
   unfolding remove_rev_def
   apply (simp add: filter_rev_alt comp_def)
   by metis
 
 subsubsection "zip"
 
 declare zip_map_fst_snd[simp]  
 
 lemma pair_list_split: "\<lbrakk> !!l1 l2. \<lbrakk> l = zip l1 l2; length l1=length l2; length l=length l2 \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
 proof (induct l arbitrary: P)
   case Nil thus ?case by auto
 next
   case (Cons a l) from Cons.hyps obtain l1 l2 where IHAPP: "l=zip l1 l2" "length l1 = length l2" "length l=length l2" .
   obtain a1 a2 where [simp]: "a=(a1,a2)" by (cases a) auto
   from IHAPP have "a#l = zip (a1#l1) (a2#l2)" "length (a1#l1) = length (a2#l2)" "length (a#l) = length (a2#l2)"
     by (simp_all only:) (simp_all (no_asm_use))
   with Cons.prems show ?case by blast
 qed
 
 lemma set_zip_cart: "x\<in>set (zip l l') \<Longrightarrow> x\<in>set l \<times> set l'"
   by (auto simp add: set_zip)
 
 
 lemma map_prod_fun_zip: "map (\<lambda>(x, y). (f x, g y)) (zip xs ys) = zip (map f xs) (map g ys)"
 proof(induct xs arbitrary: ys)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by(cases ys) simp_all
 qed
 
 
 subsubsection \<open>Generalized Zip\<close>
 text \<open>Zip two lists element-wise, where the combination of two elements is specified by a function. Note that this function is underdefined for lists of different length.\<close>
 fun zipf :: "('a\<Rightarrow>'b\<Rightarrow>'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
   "zipf f [] [] = []" |
   "zipf f (a#as) (b#bs) = f a b # zipf f as bs"
 
 
 lemma zipf_zip: "\<lbrakk>length l1 = length l2\<rbrakk> \<Longrightarrow> zipf Pair l1 l2 = zip l1 l2"
   apply (induct l1 arbitrary: l2)
   apply auto
   apply (case_tac l2)
   apply auto
   done
 
   \<comment> \<open>All quantification over zipped lists\<close>
 fun list_all_zip where
   "list_all_zip P [] [] \<longleftrightarrow> True" |
   "list_all_zip P (a#as) (b#bs) \<longleftrightarrow> P a b \<and> list_all_zip P as bs" |
   "list_all_zip P _ _ \<longleftrightarrow> False"
 
 lemma list_all_zip_alt: "list_all_zip P as bs \<longleftrightarrow> length as = length bs \<and> (\<forall>i<length as. P (as!i) (bs!i))"
   apply (induct P\<equiv>P as bs rule: list_all_zip.induct)
   apply auto
   apply (case_tac i)
   apply auto
   done
 
 lemma list_all_zip_map1: "list_all_zip P (List.map f as) bs \<longleftrightarrow> list_all_zip (\<lambda>a b. P (f a) b) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 lemma list_all_zip_map2: "list_all_zip P as (List.map f bs) \<longleftrightarrow> list_all_zip (\<lambda>a b. P a (f b)) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 declare list_all_zip_alt[mono]
 
 lemma lazI[intro?]: "\<lbrakk> length a = length b; !!i. i<length b \<Longrightarrow> P (a!i) (b!i) \<rbrakk>
   \<Longrightarrow> list_all_zip P a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_conj[simp]: "list_all_zip (\<lambda>x y. P x y \<and> Q x y) a b
                        \<longleftrightarrow> list_all_zip P a b \<and> list_all_zip Q a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_len: "list_all_zip P a b \<Longrightarrow> length a = length b"
   by (simp add: list_all_zip_alt)
 
 lemma laz_eq: "list_all_zip (=) a b \<longleftrightarrow> a=b"
   apply (induct a arbitrary: b)
   apply (case_tac b)
   apply simp
   apply simp
   apply (case_tac b)
   apply simp
   apply simp
   done
 
 
 lemma laz_swap_ex:
   assumes A: "list_all_zip (\<lambda>a b. \<exists>c. P a b c) A B"
   obtains C where
     "list_all_zip (\<lambda>a c. \<exists>b. P a b c) A C"
     "list_all_zip (\<lambda>b c. \<exists>a. P a b c) B C"
 proof -
   from A have
     [simp]: "length A = length B" and
     IC: "\<forall>i<length B. \<exists>ci. P (A!i) (B!i) ci"
     by (auto simp add: list_all_zip_alt)
   from obtain_list_from_elements[OF IC] obtain C where
     "length C = length B"
     "\<forall>i<length B. P (A!i) (B!i) (C!i)" .
   thus ?thesis
     by (rule_tac that) (auto simp add: list_all_zip_alt)
 qed
 
 lemma laz_weak_Pa[simp]:
   "list_all_zip (\<lambda>a b. P a) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>a\<in>set A. P a)"
   by (auto simp add: list_all_zip_alt set_conv_nth)
 
 lemma laz_weak_Pb[simp]:
   "list_all_zip (\<lambda>a b. P b) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>b\<in>set B. P b)"
   by (force simp add: list_all_zip_alt set_conv_nth)
 
 
 
 subsubsection "Collecting Sets over Lists"
 
 definition "list_collect_set f l == \<Union>{ f a | a. a\<in>set l }"
 lemma list_collect_set_simps[simp]:
   "list_collect_set f [] = {}"
   "list_collect_set f [a] = f a"
   "list_collect_set f (a#l) = f a \<union> list_collect_set f l"
   "list_collect_set f (l@l') = list_collect_set f l \<union> list_collect_set f l'"
 by (unfold list_collect_set_def) auto
 
 lemma list_collect_set_map_simps[simp]:
   "list_collect_set f (map x []) = {}"
   "list_collect_set f (map x [a]) = f (x a)"
   "list_collect_set f (map x (a#l)) = f (x a) \<union> list_collect_set f (map x l)"
   "list_collect_set f (map x (l@l')) = list_collect_set f (map x l) \<union> list_collect_set f (map x l')"
 by simp_all
 
 lemma list_collect_set_alt: "list_collect_set f l = \<Union>{ f (l!i) | i. i<length l }"
   apply (induct l)
   apply simp
   apply safe
   apply auto
   apply (rule_tac x="f (l!i)" in exI)
   apply simp
   apply (rule_tac x="Suc i" in exI)
   apply simp
   apply (case_tac i)
   apply auto
   done
 
 lemma list_collect_set_as_map: "list_collect_set f l = \<Union>(set (map f l))"
   by (unfold list_collect_set_def) auto
 
 subsubsection \<open>Sorted List with arbitrary Relations\<close>
 
 lemma (in linorder) sorted_wrt_rev_linord [simp] :
   "sorted_wrt (\<ge>) l \<longleftrightarrow> sorted (rev l)"
 by (simp add: sorted_wrt_rev)
 
 lemma (in linorder) sorted_wrt_map_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<le> fst y) l
   \<longleftrightarrow> sorted (map fst l)"
 by (simp add: sorted_wrt_map)
 
 lemma (in linorder) sorted_wrt_map_rev_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<ge> fst y) l
   \<longleftrightarrow> sorted (rev (map fst l))"
 by (induct l) (auto simp add: sorted_append)
 
     
 subsubsection \<open>Take and Drop\<close>
   lemma take_update[simp]: "take n (l[i:=x]) = (take n l)[i:=x]"
     apply (induct l arbitrary: n i)
     apply (auto split: nat.split)
     apply (case_tac n)
     apply simp_all
     apply (case_tac n)
     apply simp_all
     done
 
   lemma take_update_last: "length list>n \<Longrightarrow> (take (Suc n) list) [n:=x] = take n list @ [x]"
     by (induct list arbitrary: n)
        (auto split: nat.split)
 
   lemma drop_upd_irrelevant: "m < n \<Longrightarrow> drop n (l[m:=x]) = drop n l"
     apply (induct n arbitrary: l m)
     apply simp
     apply (case_tac l)
     apply (auto split: nat.split)
     done
 
 lemma set_drop_conv:
   "set (drop n l) =  { l!i | i. n\<le>i \<and> i < length l }" (is "?L=?R")
 proof (intro equalityI subsetI)
   fix x
   assume "x\<in>?L"
   then obtain i where L: "i<length l - n" and X: "x = drop n l!i"
     by (auto simp add: in_set_conv_nth)
   note X
   also have "\<dots> = l!(n+i)" using L by simp
   finally show "x\<in>?R" using L by auto
 next
   fix x
   assume "x\<in>?R"
   then obtain i where L: "n\<le>i" "i<length l" and X: "x=l!i" by blast
   note X
   moreover have "l!i = drop n l ! (i - n)" and "(i-n) < length l - n" using L
     by (auto)
   ultimately show "x\<in>?L"
     by (auto simp add: in_set_conv_nth)
 qed
 
 lemma filter_upt_take_conv:
   "[i\<leftarrow>[n..<m]. P (take m l ! i) ] = [i\<leftarrow>[n..<m]. P (l ! i) ]"
   by (rule filter_cong) (simp_all)
 
 lemma in_set_drop_conv_nth: "x\<in>set (drop n l) \<longleftrightarrow> (\<exists>i. n\<le>i \<and> i<length l \<and> x = l!i)"
   apply (clarsimp simp: in_set_conv_nth)
   apply safe
   apply simp
   apply (metis le_add2 less_diff_conv add.commute)
   apply (rule_tac x="i-n" in exI)
   apply auto []
   done
 
 lemma Union_take_drop_id: "\<Union>(set (drop n l)) \<union> \<Union>(set (take n l)) = \<Union>(set l)"
   by (metis Union_Un_distrib append_take_drop_id set_union_code sup_commute)
 
 
 lemma Un_set_drop_extend: "\<lbrakk>j\<ge>Suc 0; j < length l\<rbrakk>
   \<Longrightarrow> l ! (j - Suc 0) \<union> \<Union>(set (drop j l)) = \<Union>(set (drop (j - Suc 0) l))"
   apply safe
   apply simp_all
   apply (metis diff_Suc_Suc diff_zero gr0_implies_Suc in_set_drop_conv_nth
     le_refl less_eq_Suc_le order.strict_iff_order)
   apply (metis Nat.diff_le_self set_drop_subset_set_drop subset_code(1))
   by (metis diff_Suc_Suc gr0_implies_Suc in_set_drop_conv_nth
     less_eq_Suc_le order.strict_iff_order minus_nat.diff_0)
 
 lemma drop_take_drop_unsplit:
   "i\<le>j \<Longrightarrow> drop i (take j l) @ drop j l = drop i l"
 proof -
   assume "i \<le> j"
   then obtain skf where "i + skf = j"
     by (metis le_iff_add)
   thus "drop i (take j l) @ drop j l = drop i l"
     by (metis append_take_drop_id diff_add_inverse drop_drop drop_take
       add.commute)
 qed
 
 lemma drop_last_conv[simp]: "l\<noteq>[] \<Longrightarrow> drop (length l - Suc 0) l = [last l]"
   by (cases l rule: rev_cases) auto
 
 lemma take_butlast_conv[simp]: "take (length l - Suc 0) l = butlast l"
   by (cases l rule: rev_cases) auto
 
   lemma drop_takeWhile:
     assumes "i\<le>length (takeWhile P l)"
     shows "drop i (takeWhile P l) = takeWhile P (drop i l)"  
     using assms
   proof (induction l arbitrary: i)
     case Nil thus ?case by auto
   next
     case (Cons x l) thus ?case  
       by (cases i) auto
   qed    
   
 lemma less_length_takeWhile_conv: "i < length (takeWhile P l) \<longleftrightarrow> (i<length l \<and> (\<forall>j\<le>i. P (l!j)))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (metis dual_order.strict_trans2 nth_mem set_takeWhileD takeWhile_nth)
   subgoal by (meson less_le_trans not_le_imp_less nth_length_takeWhile)
   done
   
 lemma eq_len_takeWhile_conv: "i=length (takeWhile P l) 
   \<longleftrightarrow> i\<le>length l \<and> (\<forall>j<i. P (l!j)) \<and> (i<length l \<longrightarrow> \<not>P (l!i))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (auto simp: less_length_takeWhile_conv)
   subgoal using nth_length_takeWhile by blast 
   subgoal by (metis length_takeWhile_le nth_length_takeWhile order.order_iff_strict) 
   subgoal by (metis dual_order.strict_trans2 leI less_length_takeWhile_conv linorder_neqE_nat nth_length_takeWhile) 
   done
     
     
 subsubsection \<open>Up-to\<close>
 
 lemma upt_eq_append_conv: "i\<le>j \<Longrightarrow> [i..<j] = xs@ys \<longleftrightarrow> (\<exists>k. i\<le>k \<and> k\<le>j \<and> [i..<k] = xs \<and> [k..<j] = ys)"
 proof (rule iffI)
   assume "[i..<j] = xs @ ys"  
   and "i\<le>j"
   thus "\<exists>k\<ge>i. k \<le> j \<and> [i..<k] = xs \<and> [k..<j] = ys"
     apply (induction xs arbitrary: i)
     apply (auto; fail)
     apply (clarsimp simp: upt_eq_Cons_conv)
     by (meson Suc_le_eq less_imp_le_nat)
 qed auto
   
 lemma map_nth_upt_drop_take_conv: "N \<le> length l \<Longrightarrow> map (nth l) [M..<N] = drop M (take N l)"
   by (induction N) (auto simp: take_Suc_conv_app_nth)
     
 lemma upt_eq_lel_conv:
   "[l..<h] = is1@i#is2 \<longleftrightarrow> is1 = [l..<i] \<and> is2 = [Suc i..<h] \<and> l\<le>i \<and> i<h"
   apply (rule)
   subgoal
     apply (induction is1 arbitrary: l)
     apply (auto simp: upt_eq_Cons_conv) []
     apply (clarsimp simp: upt_eq_Cons_conv)
     using Suc_le_eq upt_rec by auto
   subgoal by (auto simp: upt_conv_Cons[symmetric])
   done
 
    
 lemma map_add_upt': "map (\<lambda>i. i + ofs) [a..<b] = [a+ofs..<b + ofs]"
   by (induct b) simp_all
     
     
 subsubsection \<open>Last and butlast\<close>
 lemma butlast_upt: "butlast [m..<n] = [m..<n - 1]"
   apply (cases "m<n")
     apply (cases n)
       apply simp
     apply simp
   apply simp
   done
 
 (*lemma butlast_upt: "n<m \<Longrightarrow> butlast [n..<m] = [n..<m - 1]"
   apply (cases "[n..<m]" rule: rev_cases)
   apply simp
   apply (cases m)
   apply simp
   apply simp
   done*)
 
 lemma butlast_update': "(butlast l) [i:=x] = butlast (l[i:=x])"
   by (metis butlast_conv_take butlast_list_update length_butlast take_update)
 
 
 lemma take_minus_one_conv_butlast:
   "n\<le>length l \<Longrightarrow> take (n - Suc 0) l = butlast (take n l)"
   by (simp add: butlast_take)
 
 lemma butlast_eq_cons_conv: "butlast l = x#xs \<longleftrightarrow> (\<exists>xl. l=x#xs@[xl])"
   by (metis Cons_eq_appendI append_butlast_last_id butlast.simps
     butlast_snoc eq_Nil_appendI)
 
 lemma butlast_eq_consE:
   assumes "butlast l = x#xs"
   obtains xl where "l=x#xs@[xl]"
   using assms
   by (auto simp: butlast_eq_cons_conv)
 
 lemma drop_eq_ConsD: "drop n xs = x # xs' \<Longrightarrow> drop (Suc n) xs = xs'"
 by(induct xs arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
 
 subsubsection \<open>List Slices\<close>  
   text \<open>Based on Lars Hupel's code.\<close>  
 definition slice :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "slice from to list = take (to - from) (drop from list)"
 
 lemma slice_len[simp]: "\<lbrakk> from \<le> to; to \<le> length xs \<rbrakk> \<Longrightarrow> length (slice from to xs) = to - from"
 unfolding slice_def
 by simp
 
 lemma slice_head: "\<lbrakk> from < to; to \<le> length xs \<rbrakk> \<Longrightarrow> hd (slice from to xs) = xs ! from"
 unfolding slice_def
 proof -
   assume a1: "from < to"
   assume "to \<le> length xs"
   then have "\<And>n. to - (to - n) \<le> length (take to xs)"
     by (metis (no_types) slice_def diff_le_self drop_take length_drop slice_len)
   then show "hd (take (to - from) (drop from xs)) = xs ! from"
     using a1 by (metis diff_diff_cancel drop_take hd_drop_conv_nth leI le_antisym less_or_eq_imp_le nth_take)
 qed
 
 lemma slice_eq_bounds_empty[simp]: "slice i i xs = []"
 unfolding slice_def by auto
 
 lemma slice_nth: "\<lbrakk> from < to; to \<le> length xs; i < to - from \<rbrakk> \<Longrightarrow> slice from to xs ! i = xs ! (from + i)"
 unfolding slice_def
 by (induction "to - from" arbitrary: "from" to i) simp+
 
 lemma slice_prepend: "\<lbrakk> i \<le> k; k \<le> length xs \<rbrakk> \<Longrightarrow> let p = length ys in slice i k xs = slice (i + p) (k + p) (ys @ xs)"
 unfolding slice_def Let_def
 by force
 
 lemma slice_Nil[simp]: "slice begin end [] = []"  
   unfolding slice_def by auto
   
 lemma slice_Cons: "slice begin end (x#xs) 
   = (if begin=0 \<and> end>0 then x#slice begin (end-1) xs else slice (begin - 1) (end - 1) xs)"
   unfolding slice_def
   by (auto simp: take_Cons' drop_Cons')
 
 lemma slice_complete[simp]: "slice 0 (length xs) xs = xs"
   unfolding slice_def
   by simp
 
   
   
 subsubsection \<open>Miscellaneous\<close>
   lemma length_compl_induct[case_names Nil Cons]: "\<lbrakk>P []; !! e l . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (e#l)\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs")
     apply(auto)
   done
 
   lemma in_set_list_format: "\<lbrakk> e\<in>set l; !!l1 l2. l=l1@e#l2 \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof (induct l arbitrary: P)
     case Nil thus ?case by auto
   next
     case (Cons a l) show ?case proof (cases "a=e")
       case True with Cons show ?thesis by force
     next
       case False with Cons.prems(1) have "e\<in>set l" by auto
       with Cons.hyps obtain l1 l2 where "l=l1@e#l2" by blast
       hence "a#l = (a#l1)@e#l2" by simp
       with Cons.prems(2) show P by blast
     qed
   qed
 
 lemma in_set_upd_cases:
   assumes "x\<in>set (l[i:=y])"
   obtains "i<length l" and "x=y" | "x\<in>set l"
   by (metis assms in_set_conv_nth length_list_update nth_list_update_eq
     nth_list_update_neq)
 
 lemma in_set_upd_eq_aux:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (\<forall>y. x\<in>set (l[i:=y]))"
   by (metis in_set_upd_cases assms list_update_overwrite
     set_update_memI)
 
 lemma in_set_upd_eq:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (x\<in>set l \<and> (\<forall>y. x\<in>set (l[i:=y])))"
   by (metis in_set_upd_cases in_set_upd_eq_aux assms)
 
 
   text \<open>Simultaneous induction over two lists, prepending an element to one of the lists in each step\<close>
   lemma list_2pre_induct[case_names base left right]: assumes BASE: "P [] []" and LEFT: "!!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2" and RIGHT: "!!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2')" shows "P w1 w2"
   proof -
     { \<comment> \<open>The proof is done by induction over the sum of the lengths of the lists\<close>
       fix n
       have "!!w1 w2. \<lbrakk>length w1 + length w2 = n; P [] []; !!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2; !!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2') \<rbrakk> \<Longrightarrow> P w1 w2 "
         apply (induct n)
         apply simp
         apply (case_tac w1)
         apply auto
         apply (case_tac w2)
         apply auto
         done
     } from this[OF _ BASE LEFT RIGHT] show ?thesis by blast
   qed
 
 
   lemma list_decomp_1: "length l=1 \<Longrightarrow> \<exists>a. l=[a]"
     by (case_tac l, auto)
 
   lemma list_decomp_2: "length l=2 \<Longrightarrow> \<exists>a b. l=[a,b]"
     by (case_tac l, auto simp add: list_decomp_1)
 
 
 
   lemma list_rest_coinc: "\<lbrakk>length s2 \<le> length s1; s1@r1 = s2@r2\<rbrakk> \<Longrightarrow> \<exists>r1p. r2=r1p@r1"
     by (metis append_eq_append_conv_if)
 
   lemma list_tail_coinc: "n1#r1 = n2#r2 \<Longrightarrow> n1=n2 & r1=r2"
     by (auto)
 
 
   lemma last_in_set[intro]: "\<lbrakk>l\<noteq>[]\<rbrakk> \<Longrightarrow> last l \<in> set l"
     by (induct l) auto
 
   lemma empty_append_eq_id[simp]: "(@) [] = (\<lambda>x. x)" by auto
       
   lemma op_conc_empty_img_id[simp]: "((@) [] ` L) = L" by auto
 
 
   lemma distinct_match: "\<lbrakk> distinct (al@e#bl) \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e#bl') \<longleftrightarrow> (al=al' \<and> bl=bl')"
   proof (rule iffI, induct al arbitrary: al')
     case Nil thus ?case by (cases al') auto
   next
     case (Cons a al) note Cprems=Cons.prems note Chyps=Cons.hyps
     show ?case proof (cases al')
       case Nil with Cprems have False by auto
       thus ?thesis ..
     next
       case [simp]: (Cons a' all')
       with Cprems have [simp]: "a=a'" and P: "al@e#bl = all'@e#bl'" by auto
       from Cprems(1) have D: "distinct (al@e#bl)" by auto
       from Chyps[OF D P] have [simp]: "al=all'" "bl=bl'" by auto
       show ?thesis by simp
     qed
   qed simp
 
 
   lemma prop_match: "\<lbrakk> list_all P al; \<not>P e; \<not>P e'; list_all P bl \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e'#bl') \<longleftrightarrow> (al=al' \<and> e=e' \<and> bl=bl')"
     apply (rule iffI, induct al arbitrary: al')
     apply (case_tac al', fastforce, fastforce)+
     done
 
   lemmas prop_matchD = rev_iffD1[OF _ prop_match[where P=P]] for P
 
   declare distinct_tl[simp]
 
 
 lemma list_se_match[simp]:
   "l1 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   "l1 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   apply (cases l1, simp_all)
   apply (cases l1, simp_all)
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 
 
 
     (* Placed here because it depends on xy_in_set_cases *)
 lemma distinct_map_eq: "\<lbrakk> distinct (List.map f l); f x = f y; x\<in>set l; y\<in>set l \<rbrakk> \<Longrightarrow> x=y"
   by (erule (2) xy_in_set_cases) auto
 
 
 
 lemma upt_append:
   assumes "i<j"
   shows "[0..<i]@[i..<j] = [0..<j]"
   using assms
   apply (induct j)
   apply simp
   apply (case_tac "i=j")
   apply auto
   done
 
 
 
 lemma upt_filter_extend:
   assumes LE: "u\<le>u'"
   assumes NP: "\<forall>i. u\<le>i \<and> i<u' \<longrightarrow> \<not>P i"
   shows "[i\<leftarrow>[0..<u]. P i] = [i\<leftarrow>[0..<u']. P i]"
 proof (cases "u=u'")
   case True thus ?thesis by simp
 next
   case False hence "u<u'" using LE by simp
   hence "[0..<u'] = [0..<u]@[u ..<u']"
     by (simp add: upt_append)
   hence "[i\<leftarrow>[0..<u']. P i] = [i\<leftarrow>[0..<u]. P i] @ [i\<leftarrow>[u..<u']. P i]"
     by simp
   also have "[i\<leftarrow>[u..<u']. P i] = []" using NP
     by (auto simp: filter_empty_conv)
   finally show ?thesis by simp
 qed
 
 
 lemma filter_upt_last:
   assumes E: "[k\<leftarrow>[0..<length l] . P (l!k)] = js @ [j]"
   assumes "j<i" and "i<length l"
   shows "\<not> P (l!i)"
 proof
   assume A: "P (l!i)"
   have "[0..<length l] = [0..<i]@[i..<length l]" using \<open>i<length l\<close>
     by (simp add: upt_append)
   also have "[i..<length l] = i#[Suc i..<length l]" using \<open>i<length l\<close>
     by (auto simp: upt_conv_Cons)
   finally
   have "[k\<leftarrow>[0..<i] . P (l!k)]@i#[k\<leftarrow>[Suc i..<length l] . P (l!k)] = js@[j]"
     unfolding E[symmetric]
     using \<open>P (l!i)\<close> by simp
   hence "j = last (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])"
     by (metis last_appendR last_snoc list.distinct(1))
   also have "\<dots> \<ge> i"
   proof -
     have "sorted (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])" (is "sorted ?l")
       by (simp add: sorted_filter[where f=id, simplified])
     hence "hd ?l \<le> last ?l"
       by (rule sorted_hd_last) simp
     thus ?thesis by simp
   qed
   finally have "i\<le>j" . thus False using \<open>j<i\<close> by simp
 qed
 
 lemma all_set_conv_nth: "(\<forall>x\<in>set l. P x) \<longleftrightarrow> (\<forall>i<length l. P (l!i))"
   by (auto intro: all_nth_imp_all_set)
 
 (* TODO: Special case of upt_eq_Nil_conv. Find cases where the latter does not work \<dots>
 *)    
 lemma upt_0_eq_Nil_conv[simp]: "[0..<j] = [] \<longleftrightarrow> j=0"
   by auto
 
 lemma filter_eq_snocD: "filter P l = l'@[x] \<Longrightarrow> x\<in>set l \<and> P x"
 proof -
   assume A: "filter P l = l'@[x]"
   hence "x\<in>set (filter P l)" by simp
   thus ?thesis by simp
 qed
 
 lemma lists_image_witness:
   assumes A: "x\<in>lists (f`Q)"
   obtains xo where "xo\<in>lists Q" "x=map f xo"
 proof -
   have "\<lbrakk> x\<in>lists (f`Q) \<rbrakk> \<Longrightarrow> \<exists>xo\<in>lists Q. x=map f xo"
   proof (induct x)
     case Nil thus ?case by auto
   next
     case (Cons x xs)
     then obtain xos where "xos\<in>lists Q" "xs=map f xos" by force
     moreover from Cons.prems have "x\<in>f`Q" by auto
     then obtain xo where "xo\<in>Q" "x=f xo" by auto
     ultimately show ?case
       by (rule_tac x="xo#xos" in bexI) auto
   qed
   thus ?thesis
     apply (simp_all add: A)
     apply (erule_tac bexE)
     apply (rule_tac that)
     apply assumption+
     done
 qed
 
 
 lemma map_of_None_filterD:
   "map_of xs x = None \<Longrightarrow> map_of (filter P xs) x = None"
 by(induct xs) auto
 
 lemma map_of_concat: "map_of (concat xss) = foldr (\<lambda>xs f. f ++ map_of xs) xss Map.empty"
 by(induct xss) simp_all
 
 lemma map_of_Some_split:
   "map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None"
 proof(induct xs)
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by(cases x)
   show ?case
   proof(cases "k' = k")
     case True
     with \<open>map_of (x # xs) k = Some v\<close> x have "x # xs = [] @ (k, v) # xs" "map_of [] k = None" by simp_all
     thus ?thesis by blast
   next
     case False
     with \<open>map_of (x # xs) k = Some v\<close> x
     have "map_of xs k = Some v" by simp
     from \<open>map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None\<close>[OF this]
     obtain ys zs where "xs = ys @ (k, v) # zs" "map_of ys k = None" by blast
     with False x have "x # xs = (x # ys) @ (k, v) # zs" "map_of (x # ys) k = None" by simp_all
     thus ?thesis by blast
   qed
 qed simp
 
 lemma map_add_find_left:
   "g k = None \<Longrightarrow> (f ++ g) k = f k"
 by(simp add: map_add_def)
 
 lemma map_add_left_None:
   "f k = None \<Longrightarrow> (f ++ g) k = g k"
 by(simp add: map_add_def split: option.split)
 
 lemma map_of_Some_filter_not_in:
   "\<lbrakk> map_of xs k = Some v; \<not> P (k, v); distinct (map fst xs) \<rbrakk> \<Longrightarrow> map_of (filter P xs) k = None"
 apply(induct xs)
 apply(auto)
 apply(auto simp add: map_of_eq_None_iff)
 done
 
 lemma distinct_map_fst_filterI: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (filter P xs))"
 by(induct xs) auto
 
 lemma distinct_map_fstD: "\<lbrakk> distinct (map fst xs); (x, y) \<in> set xs; (x, z) \<in> set xs \<rbrakk> \<Longrightarrow> y = z"
 by(induct xs)(fastforce elim: notE rev_image_eqI)+
 
 
 
 lemma concat_filter_neq_Nil:
   "concat [ys\<leftarrow>xs. ys \<noteq> Nil] = concat xs"
 by(induct xs) simp_all
 
 lemma distinct_concat':
   "\<lbrakk>distinct [ys\<leftarrow>xs. ys \<noteq> Nil]; \<And>ys. ys \<in> set xs \<Longrightarrow> distinct ys;
    \<And>ys zs. \<lbrakk>ys \<in> set xs; zs \<in> set xs; ys \<noteq> zs\<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}\<rbrakk>
   \<Longrightarrow> distinct (concat xs)"
 by(erule distinct_concat[of "[ys\<leftarrow>xs. ys \<noteq> Nil]", unfolded concat_filter_neq_Nil]) auto
 
 lemma distinct_idx:
   assumes "distinct (map f l)"
   assumes "i<length l"
   assumes "j<length l"
   assumes "f (l!i) = f (l!j)"
   shows "i=j"
   by (metis assms distinct_conv_nth length_map nth_map)
 
 lemma replicate_Suc_conv_snoc:
   "replicate (Suc n) x = replicate n x @ [x]"
 by (metis replicate_Suc replicate_append_same)
 
 
 lemma filter_nth_ex_nth:
   assumes "n < length (filter P xs)"
   shows "\<exists>m. n \<le> m \<and> m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
 using assms
 proof(induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs)
   show ?case
   proof(cases "P x")
     case [simp]: False
     from \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
     hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)" by(rule snoc)
     thus ?thesis by(auto simp add: nth_append)
   next
     case [simp]: True
     show ?thesis
     proof(cases "n = length (filter P xs)")
       case False
       with \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
       moreover hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
         by(rule snoc)
       ultimately show ?thesis by(auto simp add: nth_append)
     next
       case [simp]: True
       hence "filter P (xs @ [x]) ! n = (xs @ [x]) ! length xs" by simp
       moreover have "length xs < length (xs @ [x])" by simp
       moreover have "length xs \<ge> n" by simp
       moreover have "filter P (take (length xs) (xs @ [x])) = take n (filter P (xs @ [x]))" by simp
       ultimately show ?thesis by blast
     qed
   qed
 qed
 
 lemma set_map_filter:
   "set (List.map_filter g xs) = {y. \<exists>x. x \<in> set xs \<and> g x = Some y}"
   by (induct xs) (auto simp add: List.map_filter_def set_eq_iff)
 
     
     
     
     
 
 subsection \<open>Quicksort by Relation\<close>
 
 text \<open>A functional implementation of quicksort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun partition_rev :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "partition_rev P (yes, no) [] = (yes, no)"
  | "partition_rev P (yes, no) (x # xs) =
       partition_rev P (if P x then (x # yes, no) else (yes, x # no)) xs"
 
 lemma partition_rev_filter_conv :
   "partition_rev P (yes, no) xs = (rev (filter P xs) @ yes,  rev (filter (Not \<circ> P) xs) @ no)"
 by (induct xs arbitrary: yes no) (simp_all)
 
 function quicksort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "quicksort_by_rel R sl [] = sl"
 | "quicksort_by_rel R sl (x#xs) =
    (let (xs_s, xs_b) = partition_rev (\<lambda>y. R y x) ([],[]) xs in
     quicksort_by_rel R (x # (quicksort_by_rel R sl xs_b)) xs_s)"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(_, _, xs). length xs)")
    (simp_all add: partition_rev_filter_conv less_Suc_eq_le)
 
 lemma quicksort_by_rel_remove_acc :
   "quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp1a = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2"]
     note ind_hyp1b = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2 @ sl"]
     note ind_hyp2 = ind_hyp[OF length_le(2), of sl]
 
     show ?thesis by (simp add: ind_hyp1a ind_hyp1b ind_hyp2)
   qed
 qed
 
 lemma quicksort_by_rel_remove_acc_guared :
   "sl \<noteq> [] \<Longrightarrow> quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 by (metis quicksort_by_rel_remove_acc)
 
 lemma quicksort_by_rel_permutes [simp]:
   "mset (quicksort_by_rel R sl xs) = mset (xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs'_multi_eq : "mset xs' = mset xs1 + mset xs2"
       unfolding partition_rev_filter_conv
       by (simp add: mset_filter)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis by (simp add: xs'_multi_eq union_assoc)
   qed
 qed
 
 lemma set_quicksort_by_rel [simp]: "set (quicksort_by_rel R sl xs) = set (xs @ sl)"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_quicksort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (quicksort_by_rel R [] xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs1_props: "\<And>y. y \<in> set xs1 \<Longrightarrow> (R y x)" and
                                      xs2_props: "\<And>y. y \<in> set xs2 \<Longrightarrow> \<not>(R y x)"
       unfolding partition_rev_filter_conv
       by simp_all
 
     from xs2_props lin have xs2_props': "\<And>y. y \<in> set xs2 \<Longrightarrow> (R x y)" by blast
     from xs2_props' xs1_props trans_R have xs1_props':
       "\<And>y1 y2. y1 \<in> set xs1 \<Longrightarrow> y2 \<in> set xs2 \<Longrightarrow> (R y1 y2)"
       by metis
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyps = ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis
       by (simp add: quicksort_by_rel_remove_acc_guared sorted_wrt_append Ball_def
                     xs1_props xs2_props' xs1_props')
   qed
 qed
 
 lemma sorted_quicksort_by_rel:
   "sorted (quicksort_by_rel (\<le>) [] xs)"
   by (rule sorted_wrt_quicksort_by_rel) auto
 
 lemma sort_quicksort_by_rel:
   "sort = quicksort_by_rel (\<le>) []"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_quicksort_by_rel)
 done
 
 lemma [code]: "quicksort = quicksort_by_rel (\<le>) []"
   apply (subst sort_quicksort[symmetric])
   by (rule sort_quicksort_by_rel)
 
 subsection \<open>Mergesort by Relation\<close>
 
 text \<open>A functional implementation of mergesort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun mergesort_by_rel_split :: "('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "mergesort_by_rel_split (xs1, xs2) [] = (xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) [x] = (x # xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) (x1 # x2 # xs) =
     mergesort_by_rel_split (x1 # xs1, x2 # xs2) xs"
 
 lemma list_induct_first2 [consumes 0, case_names Nil Sing Cons2]:
 assumes "P []" "\<And>x. P [x]" "\<And>x1 x2 xs. P xs \<Longrightarrow> P (x1 # x2 #xs)"
 shows "P xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis using assms(1) by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis using assms(2) by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
       show ?thesis
         by (simp add: ind_hyp assms(3))
     qed
   qed
 qed
 
 lemma mergesort_by_rel_split_length :
   "length (fst (mergesort_by_rel_split (xs1, xs2) xs)) = length xs1 + (length xs div 2) + (length xs mod 2) \<and>
    length (snd (mergesort_by_rel_split (xs1, xs2) xs)) = length xs2 + (length xs div 2)"
 by (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
    (simp_all)
 
 lemma mset_mergesort_by_rel_split [simp]:
   "mset (fst (mergesort_by_rel_split (xs1, xs2) xs)) +
    mset (snd (mergesort_by_rel_split (xs1, xs2) xs)) =
    mset xs + mset xs1 + mset xs2"
   apply (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
   apply (simp_all add: ac_simps)
 done
 
 fun mergesort_by_rel_merge :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
 | "mergesort_by_rel_merge R xs [] = xs"
 | "mergesort_by_rel_merge R [] ys = ys"
 
 declare mergesort_by_rel_merge.simps [simp del]
 
 lemma mergesort_by_rel_merge_simps[simp] :
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
   "mergesort_by_rel_merge R xs [] = xs"
   "mergesort_by_rel_merge R [] ys = ys"
   apply (simp_all add: mergesort_by_rel_merge.simps)
   apply (cases ys)
   apply (simp_all add: mergesort_by_rel_merge.simps)
 done
 
 lemma mergesort_by_rel_merge_induct [consumes 0, case_names Nil1 Nil2 Cons1 Cons2]:
 assumes "\<And>xs::'a list. P xs []" "\<And>ys::'b list. P [] ys"
         "\<And>x xs y ys. R x y \<Longrightarrow> P xs (y # ys) \<Longrightarrow> P (x # xs) (y # ys)"
         "\<And>x xs y ys. \<not>(R x y) \<Longrightarrow> P (x # xs) ys \<Longrightarrow> P (x # xs) (y # ys)"
 shows "P xs ys"
 proof (induct xs arbitrary: ys)
   case Nil thus ?case using assms(2) by simp
 next
   case (Cons x xs) note P_xs = this
   show ?case
   proof (induct ys)
     case Nil thus ?case using assms(1) by simp
   next
     case (Cons y ys) note P_x_xs_ys = this
     show ?case using assms(3,4)[of x y xs ys] P_x_xs_ys P_xs by metis
   qed
 qed
 
 lemma mset_mergesort_by_rel_merge [simp]:
   "mset (mergesort_by_rel_merge R xs ys) = mset xs + mset ys"
 by (induct R xs ys rule: mergesort_by_rel_merge.induct) (simp_all add: ac_simps)
 
 lemma set_mergesort_by_rel_merge [simp]:
   "set (mergesort_by_rel_merge R xs ys) = set xs \<union> set ys"
   by (induct R xs ys rule: mergesort_by_rel_merge.induct) auto
 
 lemma sorted_wrt_mergesort_by_rel_merge [simp]:
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows  "sorted_wrt R (mergesort_by_rel_merge R xs ys) \<longleftrightarrow>
           sorted_wrt R xs \<and> sorted_wrt R ys"
 proof (induct xs ys rule: mergesort_by_rel_merge_induct[where R = R])
   case Nil1 thus ?case by simp
 next
   case Nil2 thus ?case by simp
 next
   case (Cons1 x xs y ys) thus ?case
     by (simp add: Ball_def) (metis trans_R)
 next
   case (Cons2 x xs y ys) thus ?case
     apply (auto simp add: Ball_def)
     apply (metis lin)
     apply (metis lin trans_R)
   done
 qed
 
 function mergesort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel R xs =
     (if length xs < 2 then xs else
      (mergesort_by_rel_merge R
        (mergesort_by_rel R (fst (mergesort_by_rel_split ([], []) xs)))
        (mergesort_by_rel R (snd (mergesort_by_rel_split ([], []) xs)))))"
 by auto
 termination
 by (relation "measure (\<lambda>(_, xs). length xs)")
   (simp_all add: mergesort_by_rel_split_length not_less minus_div_mult_eq_mod [symmetric])
 
 declare mergesort_by_rel.simps [simp del]
 
 lemma mergesort_by_rel_simps [simp, code] :
   "mergesort_by_rel R [] = []"
   "mergesort_by_rel R [x] = [x]"
   "mergesort_by_rel R (x1 # x2 # xs) =
    (let (xs1, xs2) = (mergesort_by_rel_split ([x1], [x2]) xs) in
    mergesort_by_rel_merge R (mergesort_by_rel R xs1) (mergesort_by_rel R xs2))"
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps[of _ "x1 # x2 # xs"] split: prod.splits)
 done
 
 lemma mergesort_by_rel_permutes [simp]:
   "mset (mergesort_by_rel R xs) = mset xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     show ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: ac_simps)
     qed
   qed
 qed
 
 lemma set_mergesort_by_rel [simp]: "set (mergesort_by_rel R xs) = set xs"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_mergesort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (mergesort_by_rel R xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: sorted_wrt_mergesort_by_rel_merge[OF lin trans_R])
     qed
   qed
 qed
 
 lemma sorted_mergesort_by_rel:
   "sorted (mergesort_by_rel (\<le>) xs)"
 by (rule sorted_wrt_mergesort_by_rel) auto
 
 lemma sort_mergesort_by_rel:
   "sort = mergesort_by_rel (\<le>)"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_mergesort_by_rel)
 done
 
 definition "mergesort = mergesort_by_rel (\<le>)"
 
 lemma sort_mergesort: "sort = mergesort"
   unfolding mergesort_def by (rule sort_mergesort_by_rel)
 
 subsubsection \<open>Mergesort with Remdup\<close>
 term merge
 
 fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "merge [] l2 = l2"
  | "merge l1 [] = l1"
  | "merge (x1 # l1) (x2 # l2) =
     (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else
      (if (x1 = x2) then x1 # (merge l1 l2) else x2 # (merge (x1 # l1) l2)))"
 
 lemma merge_correct :
 assumes l1_OK: "distinct l1 \<and> sorted l1"
 assumes l2_OK: "distinct l2 \<and> sorted l2"
 shows "distinct (merge l1 l2) \<and> sorted (merge l1 l2) \<and> set (merge l1 l2) = set l1 \<union> set l2"
 using assms
 proof (induct l1 arbitrary: l2)
   case Nil thus ?case by simp
 next
   case (Cons x1 l1 l2)
   note x1_l1_props = Cons(2)
   note l2_props = Cons(3)
 
   from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                     and x1_nin_l1: "x1 \<notin> set l1"
                     and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
     by (simp_all add: Ball_def)
 
   note ind_hyp_l1 = Cons(1)[OF l1_props]
 
   show ?case
   using l2_props
   proof (induct l2)
     case Nil with x1_l1_props show ?case by simp
   next
     case (Cons x2 l2)
     note x2_l2_props = Cons(2)
     from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                     and x2_nin_l2: "x2 \<notin> set l2"
                     and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
     by (simp_all add: Ball_def)
 
     note ind_hyp_l2 = Cons(1)[OF l2_props]
     show ?case
     proof (cases "x1 < x2")
       case True note x1_less_x2 = this
 
       from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
       show ?thesis
         apply (auto simp add: Ball_def)
         apply (metis linorder_not_le)
         apply (metis linorder_not_less xt1(6) xt1(9))
       done
     next
       case False note x2_le_x1 = this
 
       show ?thesis
       proof (cases "x1 = x2")
         case True note x1_eq_x2 = this
 
         from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
         show ?thesis by (simp add: x1_eq_x2 Ball_def)
       next
         case False note x1_neq_x2 = this
         with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
 
         from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
         show ?thesis
           apply (simp add: x2_less_x1 Ball_def)
           apply (metis linorder_not_le x2_less_x1 xt1(7))
         done
       qed
     qed
   qed
 qed
 
 function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
    "merge_list [] [] = []"
  | "merge_list [] [l] = l"
  | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
  | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
  | "merge_list acc2 (l1 # l2 # ls) =
     merge_list ((merge l1 l2) # acc2) ls"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)") (simp_all)
 
 lemma merge_list_correct :
 assumes ls_OK: "\<And>l. l \<in> set ls \<Longrightarrow> distinct l \<and> sorted l"
 assumes as_OK: "\<And>l. l \<in> set as \<Longrightarrow> distinct l \<and> sorted l"
 shows "distinct (merge_list as ls) \<and> sorted (merge_list as ls) \<and>
        set (merge_list as ls) = set (concat (as @ ls))"
 using assms
 proof (induct as ls rule: merge_list.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by simp
 next
   case 3 thus ?case by simp
 next
   case 4 thus ?case by auto
 next
   case (5 acc l1 l2 ls)
   note ind_hyp = 5(1)
   note l12_l_OK = 5(2)
   note acc_OK = 5(3)
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
     have set_merge_eq: "set (merge l1 l2) = set l1 \<union> set l2" by auto
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
   have "distinct (merge_list (merge l1 l2 # acc) ls) \<and>
         sorted (merge_list (merge l1 l2 # acc) ls) \<and>
         set (merge_list (merge l1 l2 # acc) ls) =
         set (concat ((merge l1 l2 # acc) @ ls))"
     by (rule_tac ind_hyp) auto
   with set_merge_eq show ?case by auto
 qed
 
 
 definition mergesort_remdups where
   "mergesort_remdups xs = merge_list [] (map (\<lambda>x. [x]) xs)"
 
 lemma mergesort_remdups_correct :
   "distinct (mergesort_remdups l)
   \<and> sorted (mergesort_remdups l)
   \<and> (set (mergesort_remdups l) = set l)"
 proof -
   let ?l' = "map (\<lambda>x. [x]) l"
 
   { fix xs
     assume "xs \<in> set ?l'"
     then obtain x where xs_eq: "xs = [x]" by auto
     hence "distinct xs \<and> sorted xs" by simp
   } note l'_OK = this
 
   from merge_list_correct[of "?l'" "[]", OF l'_OK]
   show ?thesis unfolding mergesort_remdups_def by simp
 qed
 
 (* TODO: Move *)
 lemma ex1_eqI: "\<lbrakk>\<exists>!x. P x; P a; P b\<rbrakk> \<Longrightarrow> a=b"
   by blast
 
 lemma remdup_sort_mergesort_remdups:
   "remdups o sort = mergesort_remdups" (is "?lhs=?rhs")
 proof
   fix l
   have "set (?lhs l) = set l" and "sorted (?lhs l)" and "distinct (?lhs l)"
     by simp_all
   moreover note mergesort_remdups_correct
   ultimately show "?lhs l = ?rhs l"
     by (auto intro!: ex1_eqI[OF finite_sorted_distinct_unique[OF finite_set]])
 qed
 
 subsection \<open>Native Integers\<close>  
 lemma int_of_integer_less_iff: "int_of_integer x < int_of_integer y \<longleftrightarrow> x<y"
   by (simp add: less_integer_def)
 
 lemma nat_of_integer_less_iff: "x\<ge>0 \<Longrightarrow> y\<ge>0 \<Longrightarrow> nat_of_integer x < nat_of_integer y \<longleftrightarrow> x<y"
   unfolding nat_of_integer.rep_eq
   by (auto simp: int_of_integer_less_iff nat_less_eq_zless int_of_integer_less_iff[of 0, simplified])
   
   
 subsection "Natural Numbers"
 lemma exists_leI:
   assumes hyp: "(\<forall>n' < n. \<not> P n') \<Longrightarrow> P (n::nat)"
   shows "\<exists>n' \<le> n. P n'"
 proof (rule classical)
   assume contra: "\<not> (\<exists>n'\<le>n. P n')"
   hence "\<forall>n' < n. \<not> P n'" by auto
   hence "P n" by (rule hyp)
   thus "\<exists>n'\<le>n. P n'" by auto
 qed
 
 subsubsection \<open>Induction on nat\<close>
   lemma nat_compl_induct[case_names 0 Suc]: "\<lbrakk>P 0; \<And>n . \<forall>nn. nn \<le> n \<longrightarrow> P nn \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nat_compl_induct'[case_names 0 Suc]: "\<lbrakk>P 0; !! n . \<lbrakk>!! nn . nn \<le> n \<Longrightarrow> P nn\<rbrakk> \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nz_le_conv_less: "0<k \<Longrightarrow> k \<le> m \<Longrightarrow> k - Suc 0 < m"
     by auto
       
   lemma min_Suc_gt[simp]: 
     "a<b \<Longrightarrow> min (Suc a) b = Suc a"  
     "a<b \<Longrightarrow> min b (Suc a) = Suc a"  
     by auto
     
     
 subsection \<open>Integer\<close>
 
 text \<open>Some setup from \<open>int\<close> transferred to \<open>integer\<close>\<close>
 
 lemma atLeastLessThanPlusOne_atLeastAtMost_integer: "{l..<u+1} = {l..(u::integer)}"
   apply (auto simp add: atLeastAtMost_def atLeastLessThan_def)
   including integer.lifting
   apply transfer
   apply simp
   done
 
 lemma atLeastPlusOneAtMost_greaterThanAtMost_integer: "{l+1..u} = {l<..(u::integer)}"
   including integer.lifting
   by (auto simp add: atLeastAtMost_def greaterThanAtMost_def, transfer, simp)
 
 lemma atLeastPlusOneLessThan_greaterThanLessThan_integer:
     "{l+1..<u} = {l<..<u::integer}"
   including integer.lifting
   by (auto simp add: atLeastLessThan_def greaterThanLessThan_def, transfer, simp)
 
 lemma image_atLeastZeroLessThan_integer: "0 \<le> u \<Longrightarrow>
     {(0::integer)..<u} = of_nat ` {..<nat_of_integer u}"
   including integer.lifting
   apply (unfold image_def lessThan_def)
   apply auto
   apply (rule_tac x = "nat_of_integer x" in exI)
   apply transfer
   apply (auto simp add: zless_nat_eq_int_zless [THEN sym])
   apply transfer
   apply simp
   done
 
 lemma image_add_integer_atLeastLessThan:
     "(%x. x + (l::integer)) ` {0..<u-l} = {l..<u}"
   apply (auto simp add: image_def)
   apply (rule_tac x = "x - l" in bexI)
   apply auto
   done
 
 lemma finite_atLeastZeroLessThan_integer: "finite {(0::integer)..<u}"
   apply (cases "0 \<le> u")
   apply (subst image_atLeastZeroLessThan_integer, assumption)
   apply (rule finite_imageI)
   apply auto
   done
 
 lemma finite_atLeastLessThan_integer [iff]: "finite {l..<u::integer}"
   apply (subgoal_tac "(%x. x + l) ` {0..<u-l} = {l..<u}")
   apply (erule subst)
   apply (rule finite_imageI)
   apply (rule finite_atLeastZeroLessThan_integer)
   apply (rule image_add_integer_atLeastLessThan)
   done
 
 lemma finite_atLeastAtMost_integer [iff]: "finite {l..(u::integer)}"
   by (subst atLeastLessThanPlusOne_atLeastAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanAtMost_integer [iff]: "finite {l<..(u::integer)}"
   by (subst atLeastPlusOneAtMost_greaterThanAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanLessThan_integer [iff]: "finite {l<..<u::integer}"
   by (subst atLeastPlusOneLessThan_greaterThanLessThan_integer [THEN sym], simp)
 
 
 subsection \<open>Functions of type @{typ "bool\<Rightarrow>bool"}\<close>
   lemma boolfun_cases_helper: "g=(\<lambda>x. False) | g=(\<lambda>x. x) | g=(\<lambda>x. True) | g= (\<lambda>x. \<not>x)"
   proof -
     { assume "g False" "g True"
       hence "g = (\<lambda>x. True)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "g False" "\<not>g True"
       hence "g = (\<lambda>x. \<not>x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "g True"
       hence "g = (\<lambda>x. x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "\<not>g True"
       hence "g = (\<lambda>x. False)" by (rule_tac ext, case_tac x, auto)
     } ultimately show ?thesis by fast
   qed
 
   lemma boolfun_cases[case_names False Id True Neg]: "\<lbrakk>g=(\<lambda>x. False) \<Longrightarrow> P; g=(\<lambda>x. x) \<Longrightarrow> P; g=(\<lambda>x. True) \<Longrightarrow> P; g=(\<lambda>x. \<not>x) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   proof -
     note boolfun_cases_helper[of g]
     moreover assume "g=(\<lambda>x. False) \<Longrightarrow> P" "g=(\<lambda>x. x) \<Longrightarrow> P" "g=(\<lambda>x. True) \<Longrightarrow> P" "g=(\<lambda>x. \<not>x) \<Longrightarrow> P"
     ultimately show ?thesis by fast
   qed
 
 
 subsection \<open>Definite and indefinite description\<close>
         text "Combined definite and indefinite description for binary predicate"
   lemma some_theI: assumes EX: "\<exists>a b . P a b" and BUN: "!! b1 b2 . \<lbrakk>\<exists>a . P a b1; \<exists>a . P a b2\<rbrakk> \<Longrightarrow> b1=b2"
     shows "P (SOME a . \<exists>b . P a b) (THE b . \<exists>a . P a b)"
   proof -
                 from EX have "\<exists>b. P (SOME a. \<exists>b. P a b) b" by (rule someI_ex)
                 moreover from EX have "\<exists>b. \<exists>a. P a b" by blast
     with BUN theI'[of "\<lambda>b. \<exists>a. P a b"] have "\<exists>a. P a (THE b. \<exists>a. P a b)" by (unfold Ex1_def, blast)
                 moreover note BUN
                 ultimately show ?thesis by (fast)
         qed
 
   lemma some_insert_self[simp]: "S\<noteq>{} \<Longrightarrow> insert (SOME x. x\<in>S) S = S"
     by (auto intro: someI)
 
   lemma some_elem[simp]: "S\<noteq>{} \<Longrightarrow> (SOME x. x\<in>S) \<in> S"
     by (auto intro: someI)
 
 subsubsection\<open>Hilbert Choice with option\<close>
 
 definition Eps_Opt where
   "Eps_Opt P = (if (\<exists>x. P x) then Some (SOME x. P x) else None)"
 
 lemma some_opt_eq_trivial[simp] :
   "Eps_Opt (\<lambda>y. y = x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_sym_eq_trivial[simp] :
   "Eps_Opt ((=) x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_false_trivial[simp] :
   "Eps_Opt (\<lambda>_. False) = None"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_None[simp] :
   "Eps_Opt P = None \<longleftrightarrow> \<not>(Ex P)"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_Some_implies :
   "Eps_Opt P = Some x \<Longrightarrow> P x"
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 lemma Eps_Opt_eq_Some :
 assumes P_prop: "\<And>x'. P x \<Longrightarrow> P x' \<Longrightarrow> x' = x"
 shows "Eps_Opt P = Some x \<longleftrightarrow> P x"
 using P_prop
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 subsection \<open>Product Type\<close>
 
 lemma nested_case_prod_simp: "(\<lambda>(a,b) c. f a b c) x y =
   (case_prod (\<lambda>a b. f a b y) x)"
   by (auto split: prod.split)
 
 lemma fn_fst_conv: "(\<lambda>x. (f (fst x))) = (\<lambda>(a,_). f a)"
   by auto
 lemma fn_snd_conv: "(\<lambda>x. (f (snd x))) = (\<lambda>(_,b). f b)"
   by auto
 
 fun pairself where
   "pairself f (a,b) = (f a, f b)"
 
 lemma pairself_image_eq[simp]:
   "pairself f ` {(a,b). P a b} = {(f a, f b)| a b. P a b}"
   by force
 
 lemma pairself_image_cart[simp]: "pairself f ` (A\<times>B) = f`A \<times> f`B"
   by (auto simp: image_def)
 
 lemma in_prod_fst_sndI: "fst x \<in> A \<Longrightarrow> snd x \<in> B \<Longrightarrow> x\<in>A\<times>B"
   by (cases x) auto
 
 lemma inj_Pair[simp]:
   "inj_on (\<lambda>x. (x,c x)) S"
   "inj_on (\<lambda>x. (c x,x)) S"
   by (auto intro!: inj_onI)
 
 declare Product_Type.swap_inj_on[simp]
 
 lemma img_fst [intro]:
   assumes "(a,b) \<in> S"
   shows "a \<in> fst ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma img_snd [intro]:
   assumes "(a,b) \<in> S"
   shows "b \<in> snd ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma range_prod:
   "range f \<subseteq> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
 proof
   fix y
   assume "y \<in> range f"
   then obtain x where y: "y = f x" by auto
   hence "y = (fst(f x), snd(f x))"
     by simp
   thus "y \<in> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
     by (fastforce simp add: image_def)
 qed
 
 lemma finite_range_prod:
   assumes fst: "finite (range (fst \<circ> f))"
   and     snd: "finite (range (snd \<circ> f))"
   shows "finite (range f)"
 proof -
   from fst snd have "finite (range (fst \<circ> f) \<times> range (snd \<circ> f))"
     by (rule finite_SigmaI)
   thus ?thesis
     by (rule finite_subset[OF range_prod])
 qed
 
 lemma fstE:
   "x = (a,b) \<Longrightarrow> P (fst x) \<Longrightarrow> P a"
 by (metis fst_conv)
 
 lemma sndE:
   "x = (a,b) \<Longrightarrow> P (snd x) \<Longrightarrow> P b"
 by (metis snd_conv)
 
 subsubsection \<open>Uncurrying\<close>
 
 (* TODO: Move to HOL/Product_Type? Lars H: "It's equal to case_prod, should use an abbreviation"*)
 definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
   "uncurry f \<equiv> \<lambda>(a,b). f a b"
 
 lemma uncurry_apply[simp]: "uncurry f (a,b) = f a b"
   unfolding uncurry_def
   by simp
 
 lemma curry_uncurry_id[simp]: "curry (uncurry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma uncurry_curry_id[simp]: "uncurry (curry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma do_curry: "f (a,b) = curry f a b" by simp
 lemma do_uncurry: "f a b = uncurry f (a,b)" by simp
   
 subsection \<open>Sum Type\<close>    
 lemma map_sum_Inr_conv: "map_sum fl fr s = Inr y \<longleftrightarrow> (\<exists>x. s=Inr x \<and> y = fr x)"
   by (cases s) auto
 lemma map_sum_Inl_conv: "map_sum fl fr s = Inl y \<longleftrightarrow> (\<exists>x. s=Inl x \<and> y = fl x)"
   by (cases s) auto
   
   
 subsection \<open>Directed Graphs and Relations\<close>
 
   subsubsection "Reflexive-Transitive Closure"
   lemma r_le_rtrancl[simp]: "S\<subseteq>S\<^sup>*" by auto
   lemma rtrancl_mono_rightI: "S\<subseteq>S' \<Longrightarrow> S\<subseteq>S'\<^sup>*" by auto
 
   lemma trancl_sub:
     "R \<subseteq> R\<^sup>+"
   by auto
 
   lemma trancl_single[simp]:
     "{(a,b)}\<^sup>+ = {(a,b)}"
     by (auto simp: trancl_insert)
 
 
   text \<open>Pick first non-reflexive step\<close>
   lemma converse_rtranclE'[consumes 1, case_names base step]:
     assumes "(u,v)\<in>R\<^sup>*"
     obtains "u=v"
     | vh where "u\<noteq>vh" and "(u,vh)\<in>R" and "(vh,v)\<in>R\<^sup>*"
     using assms
     apply (induct rule: converse_rtrancl_induct)
     apply auto []
     apply (case_tac "y=z")
     apply auto
     done
 
   lemma in_rtrancl_insert: "x\<in>R\<^sup>* \<Longrightarrow> x\<in>(insert r R)\<^sup>*"
     by (metis in_mono rtrancl_mono subset_insertI)
 
 
   lemma rtrancl_apply_insert: "R\<^sup>*``(insert x S) = insert x (R\<^sup>*``(S\<union>R``{x}))"
     apply (auto)
     apply (erule converse_rtranclE)
     apply auto [2]
     apply (erule converse_rtranclE)
     apply (auto intro: converse_rtrancl_into_rtrancl) [2]
     done
 
 
 
 
   text \<open>A path in a graph either does not use nodes from S at all, or it has a prefix leading to a node in S and a suffix that does not use nodes in S\<close>
   lemma rtrancl_last_visit[cases set, case_names no_visit last_visit_point]:
     shows
     "\<lbrakk> (q,q')\<in>R\<^sup>*;
        (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P;
        !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>+; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P
      \<rbrakk> \<Longrightarrow> P"
   proof (induct rule: converse_rtrancl_induct[case_names refl step])
     case refl thus ?case by auto
   next
     case (step q qh)
     show P proof (rule step.hyps(3))
       assume A: "(qh,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       show P proof (cases "qh\<in>S")
         case False
         with step.hyps(1) A have "(q,q')\<in>(R-UNIV\<times>S)\<^sup>*"
           by (auto intro: converse_rtrancl_into_rtrancl)
         with step.prems(1) show P .
       next
         case True
         from step.hyps(1) have "(q,qh)\<in>R\<^sup>+" by auto
         with step.prems(2) True A show P by blast
       qed
     next
       fix qt
       assume A: "qt\<in>S" "(qh,qt)\<in>R\<^sup>+" "(qt,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       with step.hyps(1) have "(q,qt)\<in>R\<^sup>+" by auto
       with step.prems(2) A(1,3) show P by blast
     qed
   qed
 
   text \<open>Less general version of \<open>rtrancl_last_visit\<close>, but there's a short automatic proof\<close>
   lemma rtrancl_last_visit': "\<lbrakk> (q,q')\<in>R\<^sup>*; (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (induct rule: converse_rtrancl_induct) (auto intro: converse_rtrancl_into_rtrancl)
 
   lemma rtrancl_last_visit_node:
     assumes "(s,s')\<in>R\<^sup>*"
     shows "s\<noteq>sh \<and> (s,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>* \<or>
             (s,sh)\<in>R\<^sup>* \<and> (sh,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>*"
     using assms
   proof (induct rule: converse_rtrancl_induct)
     case base thus ?case by auto
   next
     case (step s st)
     moreover {
       assume P: "(st,s')\<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       {
         assume "st=sh" with step have ?case
           by auto
       } moreover {
         assume "st\<noteq>sh"
         with \<open>(s,st)\<in>R\<close> have "(s,st)\<in>(R \<inter> UNIV \<times> - {sh})\<^sup>*" by auto
         also note P
         finally have ?case by blast
       } ultimately have ?case by blast
     } moreover {
       assume P: "(st, sh) \<in> R\<^sup>* \<and> (sh, s') \<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       with step(1) have ?case
         by (auto dest: converse_rtrancl_into_rtrancl)
     } ultimately show ?case by blast
   qed
 
   text \<open>Find last point where a path touches a set\<close>
   lemma rtrancl_last_touch: "\<lbrakk> (q,q')\<in>R\<^sup>*; q\<in>S; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (erule rtrancl_last_visit') auto
 
   text \<open>A path either goes over edge once, or not at all\<close>
   lemma trancl_over_edgeE:
     assumes "(u,w)\<in>(insert (v1,v2) E)\<^sup>+"
     obtains "(u,w)\<in>E\<^sup>+"
     | "(u,v1)\<in>E\<^sup>*" and "(v2,w)\<in>E\<^sup>*"
     using assms
   proof induct
     case (base z) thus ?thesis
       by (metis insertE prod.inject r_into_trancl' rtrancl_eq_or_trancl)
   next
     case (step y z) thus ?thesis
       by (metis (opaque_lifting, no_types)
         Pair_inject insertE rtrancl.simps trancl.simps trancl_into_rtrancl)
   qed
 
   lemma rtrancl_image_advance: "\<lbrakk>q\<in>R\<^sup>* `` Q0; (q,x)\<in>R\<rbrakk> \<Longrightarrow> x\<in>R\<^sup>* `` Q0"
     by (auto intro: rtrancl_into_rtrancl)
 
   lemma trancl_image_by_rtrancl: "(E\<^sup>+)``Vi \<union> Vi = (E\<^sup>*)``Vi"
     by (metis Image_Id Un_Image rtrancl_trancl_reflcl)
 
   lemma reachable_mono: "\<lbrakk>R\<subseteq>R'; X\<subseteq>X'\<rbrakk> \<Longrightarrow> R\<^sup>*``X \<subseteq> R'\<^sup>*``X'"
     by (metis Image_mono rtrancl_mono)
 
   lemma finite_reachable_advance:
     "\<lbrakk> finite (E\<^sup>*``{v0}); (v0,v)\<in>E\<^sup>* \<rbrakk> \<Longrightarrow> finite (E\<^sup>*``{v})"
     by (erule finite_subset[rotated]) auto
 
 lemma rtrancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>* \<Longrightarrow> x\<in>V\<^sup>*" by (metis in_mono rtrancl_mono)
 lemma trancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>+ \<Longrightarrow> x\<in>V\<^sup>+" by (metis trancl_mono)
 
 lemma rtrancl_mapI: "(a,b)\<in>E\<^sup>* \<Longrightarrow> (f a, f b)\<in>(pairself f `E)\<^sup>*"
   apply (induction rule: rtrancl_induct)
   apply (force intro: rtrancl.intros)+
   done
 
 lemma rtrancl_image_advance_rtrancl:
   assumes "q \<in> R\<^sup>*``Q0"
   assumes "(q,x) \<in> R\<^sup>*"
   shows "x \<in> R\<^sup>*``Q0"
   using assms
   by (metis rtrancl_idemp rtrancl_image_advance)
 
 lemma nth_step_trancl:
   "\<And>n m. \<lbrakk> \<And> n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R \<rbrakk> \<Longrightarrow> n < length xs \<Longrightarrow> m < n \<Longrightarrow> (xs ! n, xs ! m) \<in> R\<^sup>+"
 proof (induction xs)
   case (Cons x xs)
   hence "\<And>n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R"
     apply clarsimp
     by (metis One_nat_def diff_Suc_eq_diff_pred nth_Cons_Suc zero_less_diff)
   note IH = this[THEN Cons.IH]
 
   from Cons obtain n' where n': "Suc n' = n" by (cases n) blast+
 
   show ?case
   proof (cases m)
     case "0" with Cons have "xs \<noteq> []" by auto
     with "0" Cons.prems(1)[of m] have "(xs ! 0, x) \<in> R" by simp
     moreover from IH[where m = 0] have "\<And>n. n < length xs \<Longrightarrow> n > 0 \<Longrightarrow> (xs ! n, xs ! 0) \<in> R\<^sup>+" by simp
     ultimately have "\<And>n. n < length xs \<Longrightarrow> (xs ! n, x) \<in> R\<^sup>+" by (metis trancl_into_trancl gr0I r_into_trancl')
     with Cons "0" show ?thesis by auto
   next
     case (Suc m') with Cons.prems n' have "n' < length xs" "m' < n'" by auto
     with IH have "(xs ! n', xs ! m') \<in> R\<^sup>+" by simp
     with Suc n' show ?thesis by auto
   qed
 qed simp
 
 lemma Image_empty_trancl_Image_empty:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>+ `` {v} = {}"
   unfolding Image_def
   by (auto elim: converse_tranclE)
 
 lemma Image_empty_rtrancl_Image_id:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>* `` {v} = {v}"
   unfolding Image_def
   by (auto elim: converse_rtranclE)
 
 lemma trans_rtrancl_eq_reflcl:
   "trans A \<Longrightarrow> A^* = A^="
   by (simp add: rtrancl_trancl_reflcl)
 
 lemma refl_on_reflcl_Image:
   "refl_on B A \<Longrightarrow> C \<subseteq> B \<Longrightarrow> A^= `` C = A `` C"
   by (auto simp add: Image_def dest: refl_onD)
 
 lemma Image_absorb_rtrancl:
   "\<lbrakk> trans A; refl_on B A; C \<subseteq> B \<rbrakk> \<Longrightarrow> A^* `` C = A `` C"
   by (simp add: trans_rtrancl_eq_reflcl refl_on_reflcl_Image)
 
 lemma trancl_Image_unfold_left: "E\<^sup>+``S = E\<^sup>*``E``S"
   by (auto simp: trancl_unfold_left)
 
 lemma trancl_Image_unfold_right: "E\<^sup>+``S = E``E\<^sup>*``S"
   by (auto simp: trancl_unfold_right)
 
 lemma trancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>+``{v} \<subseteq> E\<^sup>+``{u}"
   by auto
 
 lemma rtrancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>*``{v} \<subseteq> E\<^sup>*``{u}"
   by auto
 
 (* FIXME: nicer name *)
 lemma trancl_union_outside:
   assumes "(v,w) \<in> (E\<union>U)\<^sup>+"
   and "(v,w) \<notin> E\<^sup>+"
   shows "\<exists>x y. (v,x) \<in> (E\<union>U)\<^sup>* \<and> (x,y) \<in> U \<and> (y,w) \<in> (E\<union>U)\<^sup>*"
 using assms
 proof (induction)
   case base thus ?case by auto
 next
   case (step w x)
   show ?case
   proof (cases "(v,w)\<in>E\<^sup>+")
     case True
     from step have "(v,w)\<in>(E\<union>U)\<^sup>*" by simp
     moreover from True step have "(w,x) \<in> U" by (metis Un_iff trancl.simps)
     moreover have "(x,x) \<in> (E\<union>U)\<^sup>*" by simp
     ultimately show ?thesis by blast
   next
     case False with step.IH obtain a b where "(v,a) \<in> (E\<union>U)\<^sup>*" "(a,b) \<in> U" "(b,w) \<in> (E\<union>U)\<^sup>*" by blast
     moreover with step have "(b,x) \<in> (E\<union>U)\<^sup>*" by (metis rtrancl_into_rtrancl)
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma trancl_restrict_reachable:
   assumes "(u,v) \<in> E\<^sup>+"
   assumes "E``S \<subseteq> S"
   assumes "u\<in>S"
   shows "(u,v) \<in> (E\<inter>S\<times>S)\<^sup>+"
   using assms
   by (induction rule: converse_trancl_induct)
      (auto intro: trancl_into_trancl2)
 
 lemma rtrancl_image_unfold_right: "E``E\<^sup>*``V \<subseteq> E\<^sup>*``V"
   by (auto intro: rtrancl_into_rtrancl)
 
 
 lemma trancl_Image_in_Range:
   "R\<^sup>+ `` V \<subseteq> Range R"
 by (auto elim: trancl.induct)
 
 lemma rtrancl_Image_in_Field:
   "R\<^sup>* `` V \<subseteq> Field R \<union> V"
 proof -
   from trancl_Image_in_Range have "R\<^sup>+ `` V \<subseteq> Field R"
     unfolding Field_def by fast
   hence "R\<^sup>+ `` V \<union> V \<subseteq> Field R \<union> V" by blast
   with trancl_image_by_rtrancl show ?thesis by metis
 qed
 
 lemma rtrancl_sub_insert_rtrancl:
   "R\<^sup>* \<subseteq> (insert x R)\<^sup>*"
 by (auto elim: rtrancl.induct rtrancl_into_rtrancl)
 
 lemma trancl_sub_insert_trancl:
   "R\<^sup>+ \<subseteq> (insert x R)\<^sup>+"
 by (auto elim: trancl.induct trancl_into_trancl)
 
 lemma Restr_rtrancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>* \<Longrightarrow> (v,w) \<in> E\<^sup>*"
   by (metis inf_le1 rtrancl_mono subsetCE)
 
 lemma Restr_trancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>+ \<Longrightarrow> (v,w) \<in> E\<^sup>+"
   by (metis inf_le1 trancl_mono)
 
 
 
 
 
 
 
 
   subsubsection "Converse Relation"
 
   lemmas converse_add_simps = converse_Times trancl_converse[symmetric] converse_Un converse_Int
 
   lemma dom_ran_disj_comp[simp]: "Domain R \<inter> Range R = {} \<Longrightarrow> R O R = {}"
     by auto
 
   lemma below_Id_inv[simp]: "R\<inverse>\<subseteq>Id \<longleftrightarrow> R\<subseteq>Id" by (auto)
     
     
   subsubsection "Cyclicity"
 
   lemma cyclicE: "\<lbrakk>\<not>acyclic g; !!x. (x,x)\<in>g\<^sup>+ \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (unfold acyclic_def) blast
 
   lemma acyclic_insert_cyclic: "\<lbrakk>acyclic g; \<not>acyclic (insert (x,y) g)\<rbrakk> \<Longrightarrow> (y,x)\<in>g\<^sup>*"
     by (unfold acyclic_def) (auto simp add: trancl_insert)
 
 
   text \<open>
     This lemma makes a case distinction about a path in a graph where a couple of edges with the same
     endpoint have been inserted: If there is a path from a to b, then there's such a path in the original graph, or
     there's a path that uses an inserted edge only once.
 
     Originally, this lemma was used to reason about the graph of an updated acquisition history. Any path in
     this graph is either already contained in the original graph, or passes via an
     inserted edge. Because all the inserted edges point to the same target node, in the
     second case, the path can be short-circuited to use exactly one inserted edge.
 \<close>
   lemma trancl_multi_insert[cases set, case_names orig via]:
     "\<lbrakk> (a,b)\<in>(r\<union>X\<times>{m})\<^sup>+;
       (a,b)\<in>r\<^sup>+ \<Longrightarrow> P;
        !!x. \<lbrakk> x\<in>X; (a,x)\<in>r\<^sup>*; (m,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
   proof (induct arbitrary: P rule: trancl_induct)
     case (base b) thus ?case by auto
   next
     case (step b c) show ?case proof (rule step.hyps(3))
       assume A: "(a,b)\<in>r\<^sup>+"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A have "(a,c)\<in>r\<^sup>+" by auto
         with step.prems have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     next
       fix x
       assume A: "x \<in> X" "(a, x) \<in> r\<^sup>*" "(m, b) \<in> r\<^sup>*"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A(3) have "(m,c)\<in>r\<^sup>*" by auto
         with step.prems(2)[OF A(1,2)] have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     qed
   qed
 
   text \<open>
     Version of @{thm [source] trancl_multi_insert} for inserted edges with the same startpoint.
 \<close>
   lemma trancl_multi_insert2[cases set, case_names orig via]:
     "\<lbrakk>(a,b)\<in>(r\<union>{m}\<times>X)\<^sup>+; (a,b)\<in>r\<^sup>+ \<Longrightarrow> P; !!x. \<lbrakk> x\<in>X; (a,m)\<in>r\<^sup>*; (x,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof goal_cases
     case prems: 1 from prems(1) have "(b,a)\<in>((r\<union>{m}\<times>X)\<^sup>+)\<inverse>" by simp
     also have "((r\<union>{m}\<times>X)\<^sup>+)\<inverse> = (r\<inverse>\<union>X\<times>{m})\<^sup>+" by (simp add: converse_add_simps)
     finally have "(b, a) \<in> (r\<inverse> \<union> X \<times> {m})\<^sup>+" .
     thus ?case
       by (auto elim!: trancl_multi_insert
                intro: prems(2,3)
             simp add: trancl_converse rtrancl_converse
     )
   qed
 
 lemma cyclic_subset:
   "\<lbrakk> \<not> acyclic R; R \<subseteq> S \<rbrakk> \<Longrightarrow> \<not> acyclic S"
   unfolding acyclic_def
   by (blast intro: trancl_mono)
 
 
 
 
 
   subsubsection \<open>Wellfoundedness\<close>
   lemma wf_min: assumes A: "wf R" "R\<noteq>{}" "!!m. m\<in>Domain R - Range R \<Longrightarrow> P" shows P proof -
     have H: "!!x. wf R \<Longrightarrow> \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"
       by (erule_tac wf_induct_rule[where P="\<lambda>x. \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"]) auto
     from A(2) obtain x y where "(x,y)\<in>R" by auto
     with A(1,3) H show ?thesis by blast
   qed
 
   lemma finite_wf_eq_wf_converse: "finite R \<Longrightarrow> wf (R\<inverse>) \<longleftrightarrow> wf R"
     by (metis acyclic_converse finite_acyclic_wf finite_acyclic_wf_converse wf_acyclic)
 
   lemma wf_max: assumes A: "wf (R\<inverse>)" "R\<noteq>{}" and C: "!!m. m\<in>Range R - Domain R \<Longrightarrow> P" shows "P"
   proof -
     from A(2) have NE: "R\<inverse>\<noteq>{}" by auto
     from wf_min[OF A(1) NE] obtain m where "m\<in>Range R - Domain R" by auto
     thus P by (blast intro: C)
   qed
 
     \<comment> \<open>Useful lemma to show well-foundedness of some process approaching a finite upper bound\<close>
   lemma wf_bounded_supset: "finite S \<Longrightarrow> wf {(Q',Q). Q'\<supset>Q \<and> Q'\<subseteq> S}"
   proof -
     assume [simp]: "finite S"
     hence [simp]: "!!x. finite (S-x)" by auto
     have "{(Q',Q). Q\<subset>Q' \<and> Q'\<subseteq> S} \<subseteq> inv_image ({(s'::nat,s). s'<s}) (\<lambda>Q. card (S-Q))"
     proof (intro subsetI, case_tac x, simp)
       fix a b
       assume A: "b\<subset>a \<and> a\<subseteq>S"
       hence "S-a \<subset> S-b" by blast
       thus "card (S-a) < card (S-b)" by (auto simp add: psubset_card_mono)
     qed
     moreover have "wf ({(s'::nat,s). s'<s})" by (rule wf_less)
     ultimately show ?thesis by (blast intro: wf_inv_image wf_subset)
   qed
 
   lemma wf_no_path: "Domain R \<inter> Range R = {} \<Longrightarrow> wf R"
     apply (rule wf_no_loop)
     by simp
 
 text \<open>Extend a wf-relation by a break-condition\<close>
 definition "brk_rel R \<equiv>
     {((False,x),(False,y)) | x y. (x,y)\<in>R}
   \<union> {((True,x),(False,y)) | x y. True}"
 
 lemma brk_rel_wf[simp,intro!]:
   assumes WF[simp]: "wf R"
   shows "wf (brk_rel R)"
 proof -
   have "wf {((False,x),(False,y)) | x y. (x,y)\<in>R}"
   proof -
     have "{((False,x),(False,y)) | x y. (x,y)\<in>R} \<subseteq> inv_image R snd"
       by auto
     from wf_subset[OF wf_inv_image[OF WF] this] show ?thesis .
   qed
   moreover have "wf {((True,x),(False,y)) | x y. True}"
     by (rule wf_no_path) auto
   ultimately show ?thesis
     unfolding brk_rel_def
     apply (subst Un_commute)
     by (blast intro: wf_Un)
 qed
 
 
 subsubsection \<open>Restrict Relation\<close>
 definition rel_restrict :: "('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set"
 where
   "rel_restrict R A \<equiv> {(v,w). (v,w) \<in> R \<and> v \<notin> A \<and> w \<notin> A}"
 
 lemma rel_restrict_alt_def:
   "rel_restrict R A = R \<inter> (-A) \<times> (-A)"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_empty[simp]:
   "rel_restrict R {} = R"
 by (simp add: rel_restrict_def)
 
 lemma rel_restrict_notR:
   assumes "(x,y) \<in> rel_restrict A R"
   shows "x \<notin> R" and "y \<notin> R"
 using assms
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_sub:
   "rel_restrict R A \<subseteq> R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_Int_empty:
   "A \<inter> Field R = {} \<Longrightarrow> rel_restrict R A = R"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma Domain_rel_restrict:
   "Domain (rel_restrict R A) \<subseteq> Domain R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Range_rel_restrict:
   "Range (rel_restrict R A) \<subseteq> Range R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Field_rel_restrict:
   "Field (rel_restrict R A) \<subseteq> Field R - A"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma rel_restrict_compl:
   "rel_restrict R A \<inter> rel_restrict R (-A) = {}"
 unfolding rel_restrict_def
 by auto
 
 lemma finite_rel_restrict:
   "finite R \<Longrightarrow> finite (rel_restrict R A)"
 by (metis finite_subset rel_restrict_sub)
 
 lemma R_subset_Field: "R \<subseteq> Field R \<times> Field R"
   unfolding Field_def
   by auto
 
 lemma homo_rel_restrict_mono:
   "R \<subseteq> B \<times> B \<Longrightarrow> rel_restrict R A \<subseteq> (B - A) \<times> (B - A)"
 proof -
   assume A: "R \<subseteq> B \<times> B"
   hence "Field R \<subseteq> B" unfolding Field_def by auto
   with Field_rel_restrict have "Field (rel_restrict R A) \<subseteq> B - A"
     by (metis Diff_mono order_refl order_trans)
   with R_subset_Field show ?thesis by blast
 qed
 
 lemma rel_restrict_union:
   "rel_restrict R (A \<union> B) = rel_restrict (rel_restrict R A) B"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrictI:
   "x \<notin> R \<Longrightarrow> y \<notin> R \<Longrightarrow> (x,y) \<in> E \<Longrightarrow> (x,y) \<in> rel_restrict E R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_lift:
   "(x,y) \<in> rel_restrict E R \<Longrightarrow> (x,y) \<in> E"
 unfolding rel_restrict_def
 by simp
 
 lemma rel_restrict_trancl_mem:
   "(a,b) \<in> (rel_restrict A R)\<^sup>+ \<Longrightarrow> (a,b) \<in> rel_restrict (A\<^sup>+) R"
 by (induction rule: trancl_induct) (auto simp add: rel_restrict_def)
 
 lemma rel_restrict_trancl_sub:
   "(rel_restrict A R)\<^sup>+ \<subseteq> rel_restrict (A\<^sup>+) R"
 by (metis subrelI rel_restrict_trancl_mem)
 
 lemma rel_restrict_mono:
   "A \<subseteq> B \<Longrightarrow> rel_restrict A R \<subseteq> rel_restrict B R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_mono2:
   "R \<subseteq> S \<Longrightarrow> rel_restrict A S \<subseteq> rel_restrict A R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_Sigma_sub:
   "rel_restrict ((A\<times>A)\<^sup>+) R \<subseteq> ((A - R) \<times> (A - R))\<^sup>+"
 unfolding rel_restrict_def
 by auto (metis DiffI converse_tranclE mem_Sigma_iff r_into_trancl tranclE)
 
 
 lemma finite_reachable_restrictedI:
   assumes F: "finite Q"
   assumes I: "I\<subseteq>Q"
   assumes R: "Range E \<subseteq> Q"
   shows "finite (E\<^sup>*``I)"
 proof -
   from I R have "E\<^sup>*``I \<subseteq> Q"
     by (force elim: rtrancl.cases)
   also note F
   finally (finite_subset) show ?thesis .
 qed
 
 context begin
   private lemma rtrancl_restrictI_aux:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>* \<and> v\<notin>R"
     using assms
     by (induction) (auto simp: rel_restrict_def intro: rtrancl.intros)
 
   corollary rtrancl_restrictI:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>*"
     using rtrancl_restrictI_aux[OF assms] ..
 end
 
 lemma E_closed_restr_reach_cases:
   assumes P: "(u,v)\<in>E\<^sup>*"
   assumes CL: "E``R \<subseteq> R"
   obtains "v\<in>R" | "u\<notin>R" "(u,v)\<in>(rel_restrict E R)\<^sup>*"
   using P
 proof (cases rule: rtrancl_last_visit[where S=R])
   case no_visit
   show ?thesis proof (cases "u\<in>R")
     case True with P have "v\<in>R"
       using rtrancl_reachable_induct[OF _ CL, where I="{u}"]
       by auto
     thus ?thesis ..
   next
     case False with no_visit have "(u,v)\<in>(rel_restrict E R)\<^sup>*"
       by (rule rtrancl_restrictI)
     with False show ?thesis ..
   qed
 next
   case (last_visit_point x)
   from \<open>(x, v) \<in> (E - UNIV \<times> R)\<^sup>*\<close> have "(x,v)\<in>E\<^sup>*"
     by (rule rtrancl_mono_mp[rotated]) auto
   with \<open>x\<in>R\<close> have "v\<in>R"
     using rtrancl_reachable_induct[OF _ CL, where I="{x}"]
     by auto
   thus ?thesis ..
 qed
 
 lemma rel_restrict_trancl_notR:
   assumes "(v,w) \<in> (rel_restrict E R)\<^sup>+"
   shows "v \<notin> R" and "w \<notin> R"
   using assms
   by (metis rel_restrict_trancl_mem rel_restrict_notR)+
 
 lemma rel_restrict_tranclI:
   assumes "(x,y) \<in> E\<^sup>+"
   and "x \<notin> R" "y \<notin> R"
   and "E `` R \<subseteq> R"
   shows "(x,y) \<in> (rel_restrict E R)\<^sup>+"
   using assms
   proof (induct)
     case base thus ?case by (metis r_into_trancl rel_restrictI)
   next
     case (step y z) hence "y \<notin> R" by auto
     with step show ?case by (metis trancl_into_trancl rel_restrictI)
   qed
 
 
 subsubsection \<open>Single-Valued Relations\<close>
 lemma single_valued_inter1: "single_valued R \<Longrightarrow> single_valued (R\<inter>S)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_inter2: "single_valued R \<Longrightarrow> single_valued (S\<inter>R)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_below_Id: "R\<subseteq>Id \<Longrightarrow> single_valued R"
   by (auto intro: single_valuedI)
   
 
 subsubsection \<open>Bijective Relations\<close>
 definition "bijective R \<equiv>
   (\<forall>x y z. (x,y)\<in>R \<and> (x,z)\<in>R \<longrightarrow> y=z) \<and>
   (\<forall>x y z. (x,z)\<in>R \<and> (y,z)\<in>R \<longrightarrow> x=y)"
 
 lemma bijective_alt: "bijective R \<longleftrightarrow> single_valued R \<and> single_valued (R\<inverse>)"
   unfolding bijective_def single_valued_def by blast
 
 lemma bijective_Id[simp, intro!]: "bijective Id"
   by (auto simp: bijective_def)
 
 lemma bijective_Empty[simp, intro!]: "bijective {}"
   by (auto simp: bijective_def)
 
 subsubsection \<open>Miscellaneous\<close>
 
   lemma pair_vimage_is_Image[simp]: "(Pair u -` E) = E``{u}"
     by auto
 
 lemma fst_in_Field: "fst ` R \<subseteq> Field R"
   by (simp add: Field_def fst_eq_Domain)
 
 lemma snd_in_Field: "snd ` R \<subseteq> Field R"
   by (simp add: Field_def snd_eq_Range)
 
 lemma ran_map_of:
   "ran (map_of xs) \<subseteq> snd ` set (xs)"
 by (induct xs) (auto simp add: ran_def)
 
 lemma Image_subset_snd_image:
   "A `` B \<subseteq> snd ` A"
 unfolding Image_def image_def
 by force
 
 lemma finite_Image_subset:
   "finite (A `` B) \<Longrightarrow> C \<subseteq> A \<Longrightarrow> finite (C `` B)"
 by (metis Image_mono order_refl rev_finite_subset)
 
 lemma finite_Field_eq_finite[simp]: "finite (Field R) \<longleftrightarrow> finite R"
   by (metis finite_cartesian_product finite_subset R_subset_Field finite_Field)
 
 
 
 definition "fun_of_rel R x \<equiv> SOME y. (x,y)\<in>R"
 
 lemma for_in_RI(*[intro]*): "x\<in>Domain R \<Longrightarrow> (x,fun_of_rel R x)\<in>R"
   unfolding fun_of_rel_def
   by (auto intro: someI)
 
 lemma Field_not_elem:
   "v \<notin> Field R \<Longrightarrow> \<forall>(x,y) \<in> R. x \<noteq> v \<and> y \<noteq> v"
 unfolding Field_def by auto
 
 lemma Sigma_UNIV_cancel[simp]: "(A \<times> X - A \<times> UNIV) = {}" by auto
 
 lemma same_fst_trancl[simp]: "(same_fst P R)\<^sup>+ = same_fst P (\<lambda>x. (R x)\<^sup>+)"
 proof -
   {
     fix x y
     assume "(x,y)\<in>(same_fst P R)\<^sup>+"
     hence "(x,y)\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
       by induction (auto simp: same_fst_def)
   } moreover {
     fix f f' x y
     assume "((f,x),(f',y))\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
     hence [simp]: "f'=f" "P f" and 1: "(x,y)\<in>(R f)\<^sup>+" by (auto simp: same_fst_def)
     from 1 have "((f,x),(f',y))\<in>(same_fst P R)\<^sup>+"
       apply induction
       subgoal by (rule r_into_trancl) auto
       subgoal by (erule trancl_into_trancl) auto
       done
   } ultimately show ?thesis by auto
 qed  
     
 
 subsection \<open>\<open>option\<close> Datatype\<close>
 lemma le_some_optE: "\<lbrakk>Some m\<le>x; !!m'. \<lbrakk>x=Some m'; m\<le>m'\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by (cases x) auto
 
 
 lemma not_Some_eq2[simp]: "(\<forall>x y. v \<noteq> Some (x,y)) = (v = None)"
   by (cases v) auto
 
 
 subsection "Maps"
   primrec the_default where
     "the_default _ (Some x) = x"
   | "the_default x None = x"
 
   declare map_add_dom_app_simps[simp]  
   declare map_add_upd_left[simp]  
 
   lemma ran_add[simp]: "dom f \<inter> dom g = {} \<Longrightarrow> ran (f++g) = ran f \<union> ran g" by (fastforce simp add: ran_def map_add_def split: option.split_asm option.split)
 
   lemma nempty_dom: "\<lbrakk>e\<noteq>Map.empty; !!m. m\<in>dom e \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (subgoal_tac "dom e \<noteq> {}") (blast, auto)
 
 
 
   lemma le_map_dom_mono: "m\<le>m' \<Longrightarrow> dom m \<subseteq> dom m'"
     apply (safe)
     apply (drule_tac x=x in le_funD)
     apply simp
     apply (erule le_some_optE)
     apply simp
     done
 
   lemma map_add_first_le: fixes m::"'a\<rightharpoonup>('b::order)" shows "\<lbrakk> m\<le>m' \<rbrakk> \<Longrightarrow> m++n \<le> m'++n"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split elim: le_funE)
     done
 
   lemma map_add_distinct_le: shows "\<lbrakk> m\<le>m'; n\<le>n'; dom m' \<inter> dom n' = {} \<rbrakk> \<Longrightarrow> m++n \<le> m'++n'"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split)
     apply (fastforce elim: le_funE)
     apply (drule le_map_dom_mono)
     apply (drule le_map_dom_mono)
     apply (case_tac "m x")
     apply simp
     apply (force)
     apply (fastforce dest!: le_map_dom_mono)
     apply (erule le_funE)
     apply (erule_tac x=x in le_funE)
     apply simp
     done
 
   lemma map_add_left_comm: assumes A: "dom A \<inter> dom B = {}" shows "A ++ (B ++ C) = B ++ (A ++ C)"
   proof -
     have "A ++ (B ++ C) = (A++B)++C" by simp
     also have "\<dots> = (B++A)++C" by (simp add: map_add_comm[OF A])
     also have "\<dots> = B++(A++C)" by simp
     finally show ?thesis .
   qed
   lemmas map_add_ac = map_add_assoc map_add_comm map_add_left_comm
 
   lemma le_map_restrict[simp]: fixes m :: "'a \<rightharpoonup> ('b::order)" shows "m |` X \<le> m"
     by (rule le_funI) (simp add: restrict_map_def)
 
 lemma map_of_distinct_upd:
   "x \<notin> set (map fst xs) \<Longrightarrow> [x \<mapsto> y] ++ map_of xs = (map_of xs) (x \<mapsto> y)"
   by (induct xs) (auto simp add: fun_upd_twist)
 
 lemma map_of_distinct_upd2:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd3:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd4:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
   using assms by (induct xs) (auto simp: map_of_eq_None_iff)
 
 lemma map_of_distinct_lookup:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) x = Some y"
 proof -
   have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x \<mapsto> y)"
     using assms map_of_distinct_upd2 by simp
   thus ?thesis
     by simp
 qed
 
 lemma ran_distinct:
   assumes dist: "distinct (map fst al)"
   shows "ran (map_of al) = snd ` set al"
 using assms proof (induct al)
   case Nil then show ?case by simp
 next
   case (Cons kv al)
   then have "ran (map_of al) = snd ` set al" by simp
   moreover from Cons.prems have "map_of al (fst kv) = None"
     by (simp add: map_of_eq_None_iff)
   ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
 qed
 
 lemma ran_is_image:
   "ran M = (the \<circ> M) ` (dom M)"
 unfolding ran_def dom_def image_def
 by auto
 
 lemma map_card_eq_iff:
   assumes finite: "finite (dom M)"
   and card_eq: "card (dom M) = card (ran M)"
   and indom: "x \<in> dom M"
   shows "(M x = M y) \<longleftrightarrow> (x = y)"
 proof -
   from ran_is_image finite card_eq have *: "inj_on (the \<circ> M) (dom M)" using eq_card_imp_inj_on by metis
   thus ?thesis
   proof (cases "y \<in> dom M")
     case False with indom show ?thesis by auto
   next
     case True with indom have "the (M x) = the (M y) \<longleftrightarrow> (x = y)" using inj_on_eq_iff[OF *] by auto
     thus ?thesis by auto
   qed
 qed
 
 lemma map_dom_ran_finite:
   "finite (dom M) \<Longrightarrow> finite (ran M)"
 by (simp add: ran_is_image)
 
 lemma map_update_eta_repair[simp]:
   (* An update operation may get simplified, if it happens to be eta-expanded.
     This lemma tries to repair some common expressions *)
   "dom (\<lambda>x. if x=k then Some v else m x) = insert k (dom m)"
   "m k = None \<Longrightarrow> ran (\<lambda>x. if x=k then Some v else m x) = insert v (ran m)"
   apply auto []
   apply (force simp: ran_def)
   done
 
 lemma map_leI[intro?]: "\<lbrakk>\<And>x v. m1 x = Some v \<Longrightarrow> m2 x = Some v\<rbrakk> \<Longrightarrow> m1\<subseteq>\<^sub>mm2"
   unfolding map_le_def by force
 lemma map_leD: "m1\<subseteq>\<^sub>mm2 \<Longrightarrow> m1 k = Some v \<Longrightarrow> m2 k = Some v"
   unfolding map_le_def by force
     
 lemma map_restrict_insert_none_simp: "m x = None \<Longrightarrow> m|`(-insert x s) = m|`(-s)"
   by (auto intro!: ext simp:restrict_map_def)
 
 (* TODO: Move *)
 lemma eq_f_restr_conv: "s\<subseteq>dom (f A) \<and> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   apply auto
   subgoal by (metis map_leI restrict_map_eq(2))
   subgoal by (metis ComplD restrict_map_eq(2))
   subgoal by (metis Compl_iff restrict_in)
   subgoal by (force simp: map_le_def restrict_map_def)
   done
   
 corollary eq_f_restr_ss_eq: "\<lbrakk> s\<subseteq>dom (f A) \<rbrakk> \<Longrightarrow> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   using eq_f_restr_conv by blast
     
     
     
   subsubsection \<open>Simultaneous Map Update\<close>
   definition "map_mmupd m K v k \<equiv> if k\<in>K then Some v else m k"
   lemma map_mmupd_empty[simp]: "map_mmupd m {} v = m"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_in_upd[simp]: "k\<in>K \<Longrightarrow> map_mmupd m K v k = Some v"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_notin_upd[simp]: "k\<notin>K \<Longrightarrow> map_mmupd m K v k = m k"
     by (auto simp: map_mmupd_def)
 
   lemma map_mmupdE:
     assumes "map_mmupd m K v k = Some x"
     obtains "k\<notin>K" "m k = Some x"
           | "k\<in>K" "x=v"
     using assms by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma dom_mmupd[simp]: "dom (map_mmupd m K v) = dom m \<union> K"  
     by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma le_map_mmupd_not_dom[simp, intro!]: "m \<subseteq>\<^sub>m map_mmupd m (K-dom m) v" 
     by (auto simp: map_le_def)
 
   lemma map_mmupd_update_less: "K\<subseteq>K' \<Longrightarrow> map_mmupd m (K - dom m) v \<subseteq>\<^sub>m map_mmupd m (K'-dom m) v"
     by (auto simp: map_le_def map_mmupd_def)
 
     
 
 subsection\<open>Connection between Maps and Sets of Key-Value Pairs\<close>
 
 definition map_to_set where
   "map_to_set m = {(k, v) . m k = Some v}"
 
 definition set_to_map where
   "set_to_map S k = Eps_Opt (\<lambda>v. (k, v) \<in> S)"
 
 lemma set_to_map_simp :
 assumes inj_on_fst: "inj_on fst S"
 shows "(set_to_map S k = Some v) \<longleftrightarrow> (k, v) \<in> S"
 proof (cases "\<exists>v. (k, v) \<in> S")
   case True
   note kv_ex = this
   then obtain v' where kv'_in: "(k, v') \<in> S" by blast
 
   with inj_on_fst have kv''_in: "\<And>v''. (k, v'') \<in> S \<longleftrightarrow> v' = v''"
     unfolding inj_on_def Ball_def
     by auto
 
   show ?thesis
     unfolding set_to_map_def
     by (simp add: kv_ex kv''_in)
 next
   case False
   hence kv''_nin: "\<And>v''. (k, v'') \<notin> S" by simp
   thus ?thesis
     by (simp add: set_to_map_def)
 qed
 
 lemma inj_on_fst_map_to_set :
   "inj_on fst (map_to_set m)"
 unfolding map_to_set_def inj_on_def by simp
 
 lemma map_to_set_inverse :
    "set_to_map (map_to_set m) = m"
 proof
   fix k
   show "set_to_map (map_to_set m) k = m k"
   proof (cases "m k")
     case None note mk_eq = this
     hence "\<And>v. (k, v) \<notin> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k]
     show ?thesis unfolding mk_eq by auto
   next
     case (Some v) note mk_eq = this
     hence "(k, v) \<in> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k v]
     show ?thesis unfolding mk_eq by auto
   qed
 qed
 
 lemma set_to_map_inverse :
 assumes inj_on_fst_S: "inj_on fst S"
 shows "map_to_set (set_to_map S) = S"
 proof (rule set_eqI)
   fix kv
   from set_to_map_simp [OF inj_on_fst_S, of "fst kv" "snd kv"]
   show "(kv \<in> map_to_set (set_to_map S)) = (kv \<in> S)"
     unfolding map_to_set_def
     by auto
 qed
 
 lemma map_to_set_empty[simp]: "map_to_set Map.empty = {}"
   unfolding map_to_set_def by simp
 
 lemma set_to_map_empty[simp]: "set_to_map {} = Map.empty"
   unfolding set_to_map_def[abs_def] by simp
 
 lemma map_to_set_empty_iff: "map_to_set m = {} \<longleftrightarrow> m = Map.empty"
                             "{} = map_to_set m \<longleftrightarrow> m = Map.empty"
   unfolding map_to_set_def by auto
 
 lemma set_to_map_empty_iff: "set_to_map S = Map.empty \<longleftrightarrow> S = {}" (is ?T1)
                             "Map.empty = set_to_map S \<longleftrightarrow> S = {}" (is ?T2)
 proof -
   show T1: ?T1
     apply (simp only: set_eq_iff)
     apply (simp only: fun_eq_iff)
     apply (simp add: set_to_map_def)
     apply auto
   done
   from T1 show ?T2 by auto
 qed
 
 lemma map_to_set_upd[simp]: "map_to_set (m (k \<mapsto> v)) = insert (k, v) (map_to_set m - {(k, v') |v'. True})"
   unfolding map_to_set_def
   apply (simp add: set_eq_iff)
   apply metis
 done
 
 lemma set_to_map_insert:
 assumes k_nin: "fst kv \<notin> fst ` S"
 shows "set_to_map (insert kv S) = (set_to_map S) (fst kv \<mapsto> snd kv)"
 proof
   fix k'
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from k_nin have k_nin': "\<And>v'. (k, v') \<notin> S"
     by (auto simp add: image_iff Ball_def)
 
   show "set_to_map (insert kv S) k' = ((set_to_map S)(fst kv \<mapsto> snd kv)) k'"
     by (simp add: set_to_map_def k_nin')
 qed
 
 lemma map_to_set_dom :
   "dom m = fst ` (map_to_set m)"
 unfolding dom_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma map_to_set_ran :
   "ran m = snd ` (map_to_set m)"
 unfolding ran_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma set_to_map_dom :
   "dom (set_to_map S) = fst ` S"
 unfolding set_to_map_def[abs_def] dom_def
 by (auto simp add: image_iff Bex_def)
 
 lemma set_to_map_ran :
   "ran (set_to_map S) \<subseteq> snd ` S"
 unfolding set_to_map_def[abs_def] ran_def subset_iff
 by (auto simp add: image_iff Bex_def)
    (metis Eps_Opt_eq_Some)
 
 lemma finite_map_to_set:
 "finite (map_to_set m) = finite (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (intro iffI finite_imageI)
   apply assumption
   apply (rule finite_imageD[of fst])
   apply assumption
   apply (simp add: inj_on_def)
 done
 
 lemma card_map_to_set :
   "card (map_to_set m) = card (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (rule card_image[symmetric])
   apply (simp add: inj_on_def)
 done
 
 lemma map_of_map_to_set :
 "distinct (map fst l) \<Longrightarrow>
  map_of l = m \<longleftrightarrow> set l = map_to_set m"
 proof (induct l arbitrary: m)
   case Nil thus ?case by (simp add: map_to_set_empty_iff) blast
 next
   case (Cons kv l m)
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from Cons(2) have dist_l: "distinct (map fst l)" and kv'_nin: "\<And>v'. (k, v') \<notin> set l"
     by (auto simp add: image_iff)
   note ind_hyp = Cons(1)[OF dist_l]
 
   from kv'_nin have l_eq: "set (kv # l) = map_to_set m \<longleftrightarrow> (set l = map_to_set (m (k := None))) \<and> m k = Some v"
     apply (simp add: map_to_set_def restrict_map_def set_eq_iff)
     apply (auto)
     apply (metis)
     apply (metis option.inject)
   done
 
   from kv'_nin have m_eq: "map_of (kv # l) = m \<longleftrightarrow> map_of l = (m (k := None)) \<and> m k = Some v"
     apply (simp add: fun_eq_iff restrict_map_def map_of_eq_None_iff image_iff Ball_def)
     apply metis
   done
 
   show ?case
     unfolding m_eq l_eq
     using ind_hyp[of "m (k := None)"]
     by metis
 qed
 
 lemma map_to_set_map_of :
 "distinct (map fst l) \<Longrightarrow> map_to_set (map_of l) = set l"
 by (metis map_of_map_to_set)
 
 subsubsection \<open>Mapping empty set to None\<close>
 definition "dflt_None_set S \<equiv> if S={} then None else Some S"
 
 lemma the_dflt_None_empty[simp]: "dflt_None_set {} = None"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_nonempty[simp]: "S\<noteq>{} \<Longrightarrow> dflt_None_set S = Some S"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_set[simp]: "the_default {} (dflt_None_set x) = x"
   unfolding dflt_None_set_def by auto
 
 subsection \<open>Orderings\<close>
 
   
   
 lemma (in order) min_arg_le[simp]:
   "n \<le> min m n \<longleftrightarrow> min m n = n"
   "m \<le> min m n \<longleftrightarrow> min m n = m"
   by (auto simp: min_def)
 
 lemma (in linorder) min_arg_not_ge[simp]:
   "\<not> min m n < m \<longleftrightarrow> min m n = m"
   "\<not> min m n < n \<longleftrightarrow> min m n = n"
   by (auto simp: min_def)
 
 lemma (in linorder) min_eq_arg[simp]:
   "min m n = m \<longleftrightarrow> m\<le>n"
   "min m n = n \<longleftrightarrow> n\<le>m"
   by (auto simp: min_def)
 
 lemma min_simps[simp]:
   "a<(b::'a::order) \<Longrightarrow> min a b = a"
   "b<(a::'a::order) \<Longrightarrow> min a b = b"
   by (auto simp add: min_def dest: less_imp_le)
 
 lemma (in -) min_less_self_conv[simp]: 
   "min a b < a \<longleftrightarrow> b < (a::_::linorder)" 
   "min a b < b \<longleftrightarrow> a < (b::_::linorder)" 
   by (auto simp: min_def)
     
 lemma ord_eq_le_eq_trans: "\<lbrakk> a=b; b\<le>c; c=d \<rbrakk> \<Longrightarrow> a\<le>d" by auto
 
 lemma zero_comp_diff_simps[simp]: 
   "(0::'a::linordered_idom) \<le> a - b \<longleftrightarrow> b \<le> a" 
   "(0::'a::linordered_idom) < a - b \<longleftrightarrow> b < a" 
   by auto
     
 
 subsubsection \<open>Termination Measures\<close>    
 text \<open>Lexicographic measure, assuming upper bound for second component\<close>
 lemma mlex_fst_decrI:
   fixes a a' b b' N :: nat
   assumes "a<a'"
   assumes "b<N" "b'<N"
   shows "a*N + b < a'*N + b'"
 proof -  
   have "a*N + b + 1 \<le> a*N + N" using \<open>b<N\<close> by linarith 
   also have "\<dots> \<le> a'*N" using \<open>a<a'\<close>
     by (metis Suc_leI ab_semigroup_add_class.add.commute 
       ab_semigroup_mult_class.mult.commute mult_Suc_right mult_le_mono2) 
   also have "\<dots> \<le> a'*N + b'" by auto
   finally show ?thesis by auto
 qed      
   
 lemma mlex_leI:
   fixes a a' b b' N :: nat
   assumes "a\<le>a'"
   assumes "b\<le>b'"
   shows "a*N + b \<le> a'*N + b'"
   using assms
   by (auto intro!: add_mono)
     
 lemma mlex_snd_decrI:
   fixes a a' b b' N :: nat
   assumes "a=a'"
   assumes "b<b'"
   shows "a*N + b < a'*N + b'"
   using assms
   by (auto)
 
 lemma mlex_bound:  
   fixes a b :: nat
   assumes "a<A"
   assumes "b<N"
   shows "a*N + b < A*N"
   using assms
   using mlex_fst_decrI by fastforce
     
 subsection \<open>CCPOs\<close>
 
 context ccpo
 begin
 
 lemma ccpo_Sup_mono:
   assumes C: "Complete_Partial_Order.chain (\<le>) A"
     "Complete_Partial_Order.chain (\<le>) B"
   assumes B: "\<forall>x\<in>A. \<exists>y\<in>B. x\<le>y"
   shows "Sup A \<le> Sup B"
 proof (rule ccpo_Sup_least)
   fix x
   assume "x\<in>A"
   with B obtain y where I: "y\<in>B" and L: "x\<le>y" by blast
   note L
   also from I ccpo_Sup_upper have "y\<le>Sup B" by (blast intro: C)
   finally show "x\<le>Sup B" .
 qed (rule C)
 
 lemma fixp_mono:
   assumes M: "monotone (\<le>) (\<le>) f" "monotone (\<le>) (\<le>) g"
   assumes LE: "\<And>Z. f Z \<le> g Z"
   shows "ccpo_class.fixp f \<le> ccpo_class.fixp g"
   unfolding fixp_def[abs_def]
   apply (rule ccpo_Sup_mono)
   apply (rule chain_iterates M)+
 proof rule
   fix x
   assume "x\<in>ccpo_class.iterates f"
   thus "\<exists>y\<in>ccpo_class.iterates g. x\<le>y"
   proof (induct)
     case (step x)
     then obtain y where I: "y\<in>ccpo_class.iterates g" and L: "x\<le>y" by blast
     hence "g y \<in> ccpo_class.iterates g" and "f x \<le> g y"
       apply -
       apply (erule iterates.step)
       apply (rule order_trans)
       apply (erule monotoneD[OF M(1)])
       apply (rule LE)
       done
     thus "\<exists>y\<in>ccpo_class.iterates g. f x \<le> y" ..
   next
     case (Sup M)
     define N where "N = {SOME y. y\<in>ccpo_class.iterates g \<and> x\<le>y | x. x\<in>M}"
 
     have N1: "\<forall>y\<in>N. y\<in>ccpo_class.iterates g \<and> (\<exists>x\<in>M. x\<le>y)"
       unfolding N_def
       apply auto
       apply (metis (lifting) Sup.hyps(2) tfl_some)
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have N2: "\<forall>x\<in>M. \<exists>y\<in>N. x\<le>y"
       unfolding N_def
       apply auto
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have "N \<subseteq> ccpo_class.iterates g" using Sup
       using N1 by auto
     hence C_chain: "Complete_Partial_Order.chain (\<le>) N"
       using chain_iterates[OF M(2)]
       unfolding chain_def by auto
 
     have "Sup N \<in> ccpo_class.iterates g" and "Sup M \<le> Sup N"
       apply -
       apply (rule iterates.Sup[OF C_chain])
       using N1 apply blast
       apply (rule ccpo_Sup_mono)
       apply (rule Sup.hyps)
       apply (rule C_chain)
       apply (rule N2)
       done
 
     thus ?case by blast
   qed
 qed
 
 end
 
   
 subsection \<open>Code\<close>  
 text \<open>Constant for code-abort. If that gets executed, an abort-exception is raised.\<close>  
 definition [simp]: "CODE_ABORT f = f ()"
 declare [[code abort: CODE_ABORT]]
   
   
 end
diff --git a/thys/CRYSTALS-Kyber/Abs_Qr.thy b/thys/CRYSTALS-Kyber/Abs_Qr.thy
--- a/thys/CRYSTALS-Kyber/Abs_Qr.thy
+++ b/thys/CRYSTALS-Kyber/Abs_Qr.thy
@@ -1,583 +1,572 @@
 theory Abs_Qr
 
 imports Mod_Plus_Minus
         Kyber_spec
 
 begin
 text \<open>Auxiliary lemmas\<close>
 
 lemma finite_range_plus: 
   assumes "finite (range f)"
           "finite (range g)"
   shows "finite (range (\<lambda>x. f x + g x))"
 proof -
   have subs: "range (\<lambda>x. (f x, g x)) \<subseteq> range f \<times> range g" by auto
   have cart: "finite (range f \<times> range g)" using assms by auto
   have finite: "finite (range (\<lambda>x. (f x, g x)))" 
     using rev_finite_subset[OF cart subs] .
   have "range (\<lambda>x. f x + g x) = (\<lambda>(a,b). a+b) ` range (\<lambda>x. (f x, g x))"
     using range_composition[of "(\<lambda>(a,b). a+b)" "(\<lambda>x. (f x, g x))"] 
     by auto
   then show ?thesis 
     using finite finite_image_set[where f = "(\<lambda>(a,b). a+b)"] 
     by auto
 qed
 
 lemma all_impl_Max: 
   assumes "\<forall>x. f x \<ge> (a::int)"
           "finite (range f)"
   shows "(MAX x. f x) \<ge> a"
 by (simp add: Max_ge_iff assms(1) assms(2))
 
 lemma Max_mono':
   assumes "\<forall>x. f x \<le> g x"
           "finite (range f)"
           "finite (range g)"
   shows "(MAX x. f x) \<le> (MAX x. g x)"
 using assms 
 by (metis (no_types, lifting) Max_ge_iff Max_in UNIV_not_empty 
   image_is_empty rangeE rangeI)  
 
 lemma Max_mono_plus:
   assumes "finite (range (f::_\<Rightarrow>_::ordered_ab_semigroup_add))" 
           "finite (range g)"
   shows "(MAX x. f x + g x) \<le> (MAX x. f x) + (MAX x. g x)"
 proof -
   obtain xmax where xmax_def: "f xmax + g xmax = (MAX x. f x + g x)" 
     using finite_range_plus[OF assms] Max_in by fastforce
   have "(MAX x. f x + g x) = f xmax + g xmax" using xmax_def by auto
   also have "\<dots> \<le> (MAX x. f x) + g xmax" 
     using Max_ge[OF assms(1), of "f xmax"] 
     by (auto simp add: add_right_mono[of "f xmax"]) 
   also have "\<dots> \<le> (MAX x. f x) + (MAX x. g x)" 
     using Max_ge[OF assms(2), of "g xmax"]
     by (auto simp add: add_left_mono[of "g xmax"])
   finally show ?thesis by auto
 qed
 
 
 
 text \<open>Lemmas for porting to \<open>qr\<close>.\<close>
 
 lemma of_qr_mult:
   "of_qr (a * b) = of_qr a * of_qr b mod qr_poly"
 by (metis of_qr_to_qr to_qr_mult to_qr_of_qr)
 
 lemma of_qr_scale:
   "of_qr (to_module s * b) = 
   Polynomial.smult (of_int_mod_ring s) (of_qr b)"
 unfolding to_module_def
   by (auto simp add: of_qr_mult[of "to_qr [:of_int_mod_ring s:]" "b"] 
   of_qr_to_qr) (simp add: mod_mult_left_eq mod_smult_left of_qr.rep_eq)
 
 lemma to_module_mult:
   "poly.coeff (of_qr (to_module s * a)) x1 = 
    of_int_mod_ring (s) * poly.coeff (of_qr a) x1"
 using of_qr_scale[of s a] by simp
 
 text \<open>Lemmas on \<open>round\<close> and \<open>floor\<close>.\<close>
 lemma odd_round_up:
-assumes "odd x"
-shows "round (real_of_int x / 2) = (x+1) div 2"
+  assumes "odd x"
+  shows "round (real_of_int x / 2) = (x + 1) div 2"
 proof -
-  have "round (real_of_int x / 2) = round (real_of_int (x+1) /2)"
-    using assms unfolding round_def 
-    by (metis (no_types, opaque_lifting) add.commute 
-      add_divide_distrib even_add even_succ_div_2 
-      floor_divide_of_int_eq odd_one of_int_add 
-      of_int_hom.hom_one of_int_numeral)
-  also have "\<dots> = (x+1) div 2"
-    by (metis add_divide_distrib calculation 
-    floor_divide_of_int_eq of_int_add of_int_hom.hom_one 
-    of_int_numeral round_def)
-  finally show ?thesis by blast
+  from assms have \<open>odd (x + 2)\<close>
+    by simp
+  then have \<open>\<lfloor>real_of_int (x + 2) / 2\<rfloor> = (x + 2 - 1) div 2\<close>
+    by (rule odd_half_floor)
+  from this [symmetric] show ?thesis
+    by (simp add: round_def ac_simps) linarith
 qed
 
 lemma floor_unique:
 assumes "real_of_int a \<le> x" "x < a+1"
 shows "floor x = a"
   using assms(1) assms(2) by linarith
 
 lemma same_floor:
 assumes "real_of_int a \<le> x" "real_of_int a \<le> y" 
   "x < a+1" "y < a+1"
 shows "floor x = floor y"
 using assms floor_unique  by presburger
 
 lemma one_mod_four_round:
 assumes "x mod 4 = 1"
 shows "round (real_of_int x / 4) = (x-1) div 4"
 proof -
   have leq: "(x-1) div 4 \<le> real_of_int x / 4  + 1 / 2"
     using assms by linarith 
   have gr: "real_of_int x / 4  + 1 / 2 < (x-1) div 4 + 1" 
   proof -
     have "x+2 < 4 * ((x-1) div 4 + 1)" 
     proof -
       have *:  "(x-1) div 4 + 1 = (x+3) div 4" by auto
       have "4 dvd x + 3" using assms by presburger
       then have "4 * ((x+3) div 4) = x+3" 
         by (subst dvd_imp_mult_div_cancel_left, auto)
       then show ?thesis unfolding * by auto
     qed
     then show ?thesis by auto
   qed
   show "round (real_of_int x / 4) = (x-1) div 4"
     using floor_unique[OF leq gr] unfolding round_def by auto
 qed
 
-lemma odd_half_floor:
-assumes "odd x"
-shows "\<lfloor>real_of_int x / 2\<rfloor> = (x-1) div 2"
-using assms by (metis add.commute diff_add_cancel even_add 
- even_succ_div_2 floor_divide_of_int_eq odd_one of_int_numeral)
-
 
 section \<open>Re-centered "Norm" Function\<close>
 
 context module_spec
 begin 
 text \<open>We want to show that \<open>abs_infty_q\<close> is a function induced by the 
   Euclidean norm on the \<open>mod_ring\<close> using a re-centered representative via \<open>mod+-\<close>.
 
   \<open>abs_infty_poly\<close> is the induced norm by \<open>abs_infty_q\<close> on polynomials over the polynomial 
   ring over the \<open>mod_ring\<close>. 
 
   Unfortunately this is not a norm per se, as the homogeneity only holds in 
   inequality, not equality. Still, it fulfils its purpose, since we only 
   need the triangular inequality.\<close>
 
 definition abs_infty_q :: "('a mod_ring) \<Rightarrow> int" where
   "abs_infty_q p = abs ((to_int_mod_ring p) mod+- q)"
 
 definition abs_infty_poly :: "'a qr \<Rightarrow> int" where
   "abs_infty_poly p = Max (range (abs_infty_q \<circ> poly.coeff (of_qr p)))"
 
 text \<open>Helping lemmas and properties of \<open>Max\<close>, \<open>range\<close> and \<open>finite\<close>.\<close>
 
 lemma to_int_mod_ring_range: 
   "range (to_int_mod_ring :: 'a mod_ring \<Rightarrow> int) = {0 ..< q}"
 using CARD_a by (simp add: range_to_int_mod_ring)
 
 lemma finite_Max:
   "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))"
 proof -
   have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa)))" 
   using MOST_coeff_eq_0[of "of_qr x"] by auto
   have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa) mod+- q\<bar>)
     = (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) ` range (poly.coeff (of_qr x))"
   using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))" 
     "poly.coeff (of_qr x)"] by auto
   then show ?thesis 
     using finite_range finite_image_set[where 
       f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)"] 
     by (auto simp add: abs_infty_q_def)
 qed
 
 lemma finite_Max_scale:
   "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
     poly.coeff (of_qr x) xa)))"
 proof -
   have "of_int_mod_ring s * poly.coeff (of_qr x) xa = 
     poly.coeff (of_qr (to_module s * x)) xa" for xa
   by (metis coeff_smult of_qr_to_qr_smult to_qr_of_qr 
     to_qr_smult_to_module to_module_def)
   then show ?thesis
   using finite_Max by presburger
 qed
 
 lemma finite_Max_sum: 
   "finite (range (\<lambda>xa. abs_infty_q 
     (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)))"
 proof -
   have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa)))" 
   using MOST_coeff_eq_0[of "of_qr x"] by auto
   have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa) mod+- q\<bar>) = 
     (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) ` 
     range (\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"
   using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))" 
     "(\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"] 
   by auto
   then show ?thesis 
     using finite_range finite_image_set[where 
       f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)" ] 
     by (auto simp add: abs_infty_q_def)
 qed
 
 
 lemma finite_Max_sum':
   "finite (range
      (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa) + 
       abs_infty_q (poly.coeff (of_qr y) xa)))"
 proof -
   have finite_range_x: 
     "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))" 
     using finite_Max[of x] by auto
   have finite_range_y: 
     "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr y) xa)))" 
     using finite_Max[of y] by auto
   show ?thesis 
     using finite_range_plus[OF finite_range_x finite_range_y] by auto
 qed
 
 
 
 
 lemma Max_scale:
 "(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
     \<bar>s\<bar> * (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
 proof -
   have "(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
     (Max (range (\<lambda>xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))))"
     by auto
   moreover have "\<dots> = (Max ((\<lambda>a. \<bar>s\<bar> * a) `
     (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))))"
     by (metis range_composition)
   moreover have "\<dots> = \<bar>s\<bar> * (Max (range 
     (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa))))"
     by (subst mono_Max_commute[symmetric])
        (auto simp add: finite_Max Rings.mono_mult)
   moreover have "\<dots> =  \<bar>s\<bar> * 
     (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
     by auto
   ultimately show ?thesis by auto
 qed
 
 
 
 text \<open>Show that \<open>abs_infty_q\<close> is definite, positive and fulfils the triangle inequality.\<close>
 
 lemma abs_infty_q_definite:
   "abs_infty_q x = 0 \<longleftrightarrow> x = 0"
 proof (auto simp add: abs_infty_q_def 
   mod_plus_minus_zero'[OF q_gt_zero q_odd])
   assume "to_int_mod_ring x mod+- q = 0"
   then have "to_int_mod_ring x mod q = 0" 
     using mod_plus_minus_zero[of "to_int_mod_ring x" q] 
     by auto
   then have "to_int_mod_ring x = 0" 
     using to_int_mod_ring_range CARD_a
     by (metis mod_rangeE range_eqI)
   then show "x = 0" by force
 qed
 
 lemma abs_infty_q_pos:
   "abs_infty_q x \<ge> 0"
 by (auto simp add: abs_infty_q_def) 
 
 
 lemma abs_infty_q_minus:
   "abs_infty_q (- x) = abs_infty_q x"
 proof (cases "x=0")
 case True
   then show ?thesis by auto
 next
 case False
   have minus_x: "to_int_mod_ring (-x) = q - to_int_mod_ring x"
   proof -
     have "to_int_mod_ring (-x) = to_int_mod_ring (-x) mod q"
       by (metis CARD_a Rep_mod_ring_mod to_int_mod_ring.rep_eq)
     also have "\<dots> = (- to_int_mod_ring x) mod q" 
       by (metis (no_types, opaque_lifting) CARD_a diff_eq_eq 
         mod_add_right_eq plus_mod_ring.rep_eq to_int_mod_ring.rep_eq 
         uminus_add_conv_diff)
     also have "\<dots> = q - to_int_mod_ring x" 
     proof -
       have "- to_int_mod_ring x \<in> {-q<..<0}"
       using CARD_a range_to_int_mod_ring False 
         by (smt (verit, best) Rep_mod_ring_mod greaterThanLessThan_iff 
           q_gt_zero to_int_mod_ring.rep_eq to_int_mod_ring_hom.eq_iff 
           to_int_mod_ring_hom.hom_zero zmod_trivial_iff)
       then have "q-to_int_mod_ring x\<in>{0<..<q}" by auto
       then show ?thesis 
         using minus_mod_self1 mod_rangeE
         by (simp add: to_int_mod_ring.rep_eq zmod_zminus1_eq_if)
     qed
     finally show ?thesis by auto
   qed
   then have "\<bar>to_int_mod_ring (- x) mod+- q\<bar> = 
     \<bar>(q - (to_int_mod_ring x)) mod+- q\<bar>" 
     by auto
   also have "\<dots> = \<bar> (- to_int_mod_ring x) mod+- q\<bar>" 
     unfolding mod_plus_minus_def by (smt (z3) mod_add_self2)
   also have "\<dots> = \<bar> - (to_int_mod_ring x mod+- q)\<bar>" 
     using neg_mod_plus_minus[OF q_odd q_gt_zero, 
       of "to_int_mod_ring x"] by simp
   also have "\<dots> = \<bar>to_int_mod_ring x mod+- q\<bar>" by auto
   finally show ?thesis unfolding abs_infty_q_def by auto
 qed
 
 
 
 lemma to_int_mod_ring_mult:
   "to_int_mod_ring (a*b) =  to_int_mod_ring (a::'a mod_ring) * 
     to_int_mod_ring (b::'a mod_ring) mod q"
 by (metis (no_types, lifting) CARD_a of_int_hom.hom_mult 
   of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring 
   of_int_of_int_mod_ring to_int_mod_ring.rep_eq)
 
 
 
 text \<open>Scaling only with inequality not equality! This causes a problem in proof of the 
   Kyber scheme. Needed to add $q\equiv 1 \mod 4$ to change proof.\<close>
 lemma mod_plus_minus_leq_mod: 
   "\<bar>x mod+- q\<bar> \<le> \<bar>x\<bar>"
 by (smt (verit, best) atLeastAtMost_iff mod_plus_minus_range_odd
   mod_plus_minus_rangeE q_gt_zero q_odd)
 
 lemma abs_infty_q_scale_pos:
   assumes "s\<ge>0"
   shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 proof -
   have "\<bar>to_int_mod_ring (of_int_mod_ring s * x) mod+- q\<bar> = 
         \<bar>(to_int_mod_ring (of_int_mod_ring s ::'a mod_ring) * 
           to_int_mod_ring x mod q) mod+- q\<bar>"
     using to_int_mod_ring_mult[of "of_int_mod_ring s" x] by simp
   also have "\<dots> = \<bar>(s mod q * to_int_mod_ring x) mod+- q\<bar>"
   by (simp add: CARD_a mod_plus_minus_def of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
   also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>" 
   proof -
     have "\<bar>s mod q * to_int_mod_ring x mod+- q\<bar> = 
           \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q) mod+- q\<bar>"
       using mod_plus_minus_mult by auto
     also have "\<dots> \<le> \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q)\<bar>" 
       using mod_plus_minus_leq_mod by blast
     also have "\<dots> \<le> \<bar>s mod q mod+- q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>" 
       by (simp add: abs_mult)
     also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>"
       using mod_plus_minus_leq_mod[of "s mod q"] 
       by (simp add: mult_right_mono)
     finally show ?thesis by auto
   qed 
   also have "\<dots> \<le> \<bar>s\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>" using assms
     by (simp add: mult_mono' q_gt_zero zmod_le_nonneg_dividend)
   finally show ?thesis unfolding abs_infty_q_def by auto
 qed
 
 lemma abs_infty_q_scale_neg:
   assumes "s<0"
   shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 using abs_infty_q_minus abs_infty_q_scale_pos 
 by (smt (verit, best) mult_minus_left of_int_minus of_int_of_int_mod_ring)
 
 lemma abs_infty_q_scale:
   "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 apply (cases "s\<ge>0") 
 using abs_infty_q_scale_pos apply presburger 
 using abs_infty_q_scale_neg by force
 
 
 text \<open>Triangle inequality for \<open>abs_infty_q\<close>.\<close>
 
 lemma abs_infty_q_triangle_ineq:
   "abs_infty_q (x+y) \<le> abs_infty_q x + abs_infty_q y"
 proof -
   have "to_int_mod_ring (x + y) mod+- q = 
         (to_int_mod_ring x + to_int_mod_ring y) mod q mod+-q"
     by (simp add: to_int_mod_ring_def CARD_a plus_mod_ring.rep_eq)
   also have "\<dots> = (to_int_mod_ring x + to_int_mod_ring y) mod+-q"
     unfolding mod_plus_minus_def by auto
   also have "\<dots> = (to_int_mod_ring x mod+- q + 
     to_int_mod_ring y mod+- q) mod+- q"
     unfolding mod_plus_minus_def 
     by (smt (verit, ccfv_threshold) minus_mod_self2 mod_add_eq)
   finally have rewrite:"to_int_mod_ring (x + y) mod+- q = 
     (to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) mod+- q" .
   then have "\<bar>to_int_mod_ring (x + y) mod+- q\<bar>
     \<le> \<bar>to_int_mod_ring x mod+- q\<bar> + \<bar>to_int_mod_ring y mod+- q\<bar>"
     proof (cases 
     "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) \<in> 
        {-\<lfloor>real_of_int q/2\<rfloor>..<\<lfloor>real_of_int q/2\<rfloor>}")
     case True
       then have True': "to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q
         \<in> {- \<lfloor>real_of_int q / 2\<rfloor>..\<lfloor>real_of_int q / 2\<rfloor>}" by auto
       then have "(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q) mod+- q
        = to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q" 
         using mod_plus_minus_rangeE[OF True' q_odd q_gt_zero] by auto 
       then show ?thesis by (simp add: rewrite)
     next
     case False
       then have "\<bar>(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q)\<bar> \<ge> \<lfloor>real_of_int q /2\<rfloor>" 
         by auto
       then have "\<bar>(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q)\<bar> \<ge> \<bar>(to_int_mod_ring x mod+- q +
         to_int_mod_ring y mod+- q) mod+- q\<bar>"
       using mod_plus_minus_range_odd[OF q_gt_zero q_odd, 
         of "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q)"]
       by auto
       then show ?thesis by (simp add: rewrite)
     qed
   then show ?thesis 
     by (auto simp add: abs_infty_q_def mod_plus_minus_def)
 qed
 
 text \<open>Show that \<open>abs_infty_poly\<close> is definite, positive and fulfils the triangle inequality.\<close>
 
 lemma abs_infty_poly_definite:
   "abs_infty_poly x = 0 \<longleftrightarrow> x = 0"
 proof (auto simp add: abs_infty_poly_def abs_infty_q_definite)
   assume "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) = 0"
   then have abs_le_zero: "abs_infty_q (poly.coeff (of_qr x) xa) \<le> 0"
     for xa
     using Max_ge[OF finite_Max[of x], 
       of "abs_infty_q (poly.coeff (of_qr x) xa)"]
     by (auto simp add: Max_ge[OF finite_Max])
   have "abs_infty_q (poly.coeff (of_qr x) xa) = 0" for xa 
     using abs_infty_q_pos[of "poly.coeff (of_qr x) xa"] 
     abs_le_zero[of xa] by auto
   then have "poly.coeff (of_qr x) xa = 0" for xa
     by (auto simp add: abs_infty_q_definite)
   then show "x = 0" 
     using leading_coeff_0_iff of_qr_eq_0_iff by blast
 qed
 
 
 lemma abs_infty_poly_pos:
   "abs_infty_poly x \<ge> 0"
 proof (auto simp add: abs_infty_poly_def)
   have f_ge_zero: "\<forall>xa. abs_infty_q (poly.coeff (of_qr x) xa) \<ge> 0"
     by (auto simp add: abs_infty_q_pos)
   then show " 0 \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
     using all_impl_Max[OF f_ge_zero finite_Max] by auto
 qed
 
 
 text \<open>Again, homogeneity is only true for inequality not necessarily equality! 
   Need to add $q\equiv 1\mod 4$ such that proof of crypto scheme works out.\<close>
 lemma abs_infty_poly_scale:
   "abs_infty_poly ((to_module s) * x) \<le> (abs s) * (abs_infty_poly x)"
 proof -
   have fin1: "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
     poly.coeff (of_qr x) xa)))"
     using finite_Max_scale by auto
   have fin2: "finite (range (\<lambda>xa. \<bar>s\<bar> *
      abs_infty_q (poly.coeff (of_qr x) xa)))"
     by (metis finite_Max finite_imageI range_composition)
   have "abs_infty_poly (to_module s * x) = 
         (MAX xa. abs_infty_q
          ((of_int_mod_ring s) * poly.coeff (of_qr x) xa))"
   using abs_infty_poly_def to_module_mult
     by (metis (mono_tags, lifting) comp_apply image_cong)   
   also have "\<dots> \<le> (MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))"
     using abs_infty_q_scale fin1 fin2 by (subst Max_mono', auto)
   also have "\<dots> = \<bar>s\<bar> * abs_infty_poly x"
     unfolding abs_infty_poly_def comp_def using Max_scale by auto
   finally show ?thesis by blast
 qed
 
 
 text \<open>Triangle inequality for \<open>abs_infty_poly\<close>.\<close>
 lemma abs_infty_poly_triangle_ineq:
   "abs_infty_poly (x+y) \<le> abs_infty_poly x + abs_infty_poly y"
 proof -
   have "abs_infty_q (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa) \<le> 
     abs_infty_q (poly.coeff (of_qr x) xa) + 
     abs_infty_q (poly.coeff (of_qr y) xa)"
     for xa
     using abs_infty_q_triangle_ineq[of 
       "poly.coeff (of_qr x) xa" "poly.coeff (of_qr y) xa"]
     by auto
   then have abs_q_triang: "\<forall>xa. 
     abs_infty_q (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa) \<le>
     abs_infty_q (poly.coeff (of_qr x) xa) + 
     abs_infty_q (poly.coeff (of_qr y) xa)"
     by auto
   have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa + 
       poly.coeff (of_qr y) xa))
     \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa) + 
       abs_infty_q (poly.coeff (of_qr y) xa))"
     using Max_mono'[OF abs_q_triang finite_Max_sum finite_Max_sum'] 
     by auto
   also have "\<dots> \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
        (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))" 
     using Max_mono_plus[OF finite_Max[of x] finite_Max[of y]] 
     by auto
   finally have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa + 
       poly.coeff (of_qr y) xa))
     \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
        (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))"
     by auto
   then show ?thesis 
     by (auto simp add: abs_infty_poly_def)
 qed
 
 end
 
 text \<open>Estimation inequality using message bit.\<close>
 
 lemma(in kyber_spec) abs_infty_poly_ineq_pm_1:
 assumes "\<exists>x. poly.coeff (of_qr a) x \<in> {of_int_mod_ring (-1),1}"
 shows "abs_infty_poly (to_module (round((real_of_int q)/2)) * a) \<ge> 
               2 * round (real_of_int q / 4)"
 proof -
   let ?x = "to_module (round((real_of_int q)/2)) * a"
   obtain x1 where x1_def: 
     "poly.coeff (of_qr a) x1 \<in> {of_int_mod_ring(-1),1}" 
     using assms by auto
   have "abs_infty_poly (to_module (round((real_of_int q)/2)) * a)
     \<ge> abs_infty_q (poly.coeff (of_qr (to_module 
       (round (real_of_int q / 2)) * a)) x1)" 
     unfolding abs_infty_poly_def using x1_def 
     by (simp add: finite_Max)
   also have "abs_infty_q (poly.coeff (of_qr (to_module 
     (round (real_of_int q / 2)) * a)) x1)
   = abs_infty_q (of_int_mod_ring (round (real_of_int q / 2))
     * (poly.coeff (of_qr a) x1))" 
     using to_module_mult[of "round (real_of_int q / 2)" a] 
     by simp
   also have "\<dots> = abs_infty_q (of_int_mod_ring 
     (round (real_of_int q / 2)))" 
   proof -
     consider "poly.coeff (of_qr a) x1=1" | 
       "poly.coeff (of_qr a) x1 = of_int_mod_ring (-1)" 
       using x1_def by auto
     then show ?thesis 
     proof (cases)
       case 2
       then show ?thesis
       by (metis abs_infty_q_minus mult.right_neutral mult_minus_right
           of_int_hom.hom_one of_int_minus of_int_of_int_mod_ring)
     qed (auto)
   qed
   also have "\<dots> = \<bar>round (real_of_int q / 2) mod+- q\<bar>" 
     unfolding abs_infty_q_def 
     using to_int_mod_ring_of_int_mod_ring 
     by (simp add: CARD_a mod_add_left_eq mod_plus_minus_def 
       of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
   also have "\<dots> = \<bar>((q + 1) div 2) mod+- q\<bar>" 
     using odd_round_up[OF q_odd] by auto 
   also have "\<dots> = \<bar>((2 * q) div 2) mod q - (q - 1) div 2\<bar>" 
   proof -
     have "(q + 1) div 2 mod q = (q + 1) div 2" using q_gt_two by auto
     moreover have "(q + 1) div 2 - q = - ((q - 1) div 2)" by (simp add: q_odd)
     ultimately show ?thesis
     unfolding mod_plus_minus_def odd_half_floor[OF q_odd] 
     by (split if_splits) simp
   qed
   also have "\<dots> = \<bar>(q-1) div 2\<bar>" using q_odd 
     by (subst nonzero_mult_div_cancel_left[of 2 q], simp) 
        (simp add: abs_div abs_minus_commute)
   also have "\<dots> = 2 * ((q-1) div 4)" 
   proof -
     from q_gt_two have "(q-1) div 2 > 0" by simp
     then have "\<bar>(q-1) div 2\<bar> = (q-1) div 2" by auto
     also have "\<dots> = 2 * ((q-1) div 4)" 
       by (subst div_mult_swap) (use q_mod_4 in 
       \<open>metis dvd_minus_mod\<close>, force)
     finally show ?thesis by blast
   qed
   also have "\<dots> = 2 * round (real_of_int q / 4)" 
     unfolding odd_round_up[OF q_odd] one_mod_four_round[OF q_mod_4] 
     by (simp add: round_def)
   finally show ?thesis unfolding abs_infty_poly_def by simp
 qed
 
 end
\ No newline at end of file
diff --git a/thys/CRYSTALS-Kyber/Mod_Plus_Minus.thy b/thys/CRYSTALS-Kyber/Mod_Plus_Minus.thy
--- a/thys/CRYSTALS-Kyber/Mod_Plus_Minus.thy
+++ b/thys/CRYSTALS-Kyber/Mod_Plus_Minus.thy
@@ -1,181 +1,186 @@
 theory Mod_Plus_Minus
 
 imports Kyber_spec
 
 begin
+
+lemma odd_half_floor:
+  \<open>\<lfloor>real_of_int x / 2\<rfloor> = (x - 1) div 2\<close> if \<open>odd x\<close>
+  using that by (rule oddE) simp
+
 section \<open>Re-centered Modulo Operation\<close>
 text \<open>To define the compress and decompress functions, 
   we need some special form of modulo. It returns the 
   representation of the equivalence class in \<open>(-q div 2, q div 2]\<close>.
   Using these representatives, we ensure that the norm of the 
   representative is as small as possible.\<close>
 
 definition mod_plus_minus :: "int \<Rightarrow> int \<Rightarrow> int" 
   (infixl "mod+-" 70) where
 "m mod+- b = 
   (if m mod b > \<lfloor>b/2\<rfloor> then m mod b - b else m mod b)"
 
 text \<open>Range of the (re-centered) modulo operation\<close>
  
 lemma mod_range: "b>0 \<Longrightarrow> (a::int) mod (b::int) \<in> {0..b-1}"
 using range_mod by auto
 
 lemma mod_rangeE: 
   assumes "(a::int)\<in>{0..<b}"
   shows "a = a mod b"
 using assms by auto
 
 
 lemma half_mod_odd:
-assumes "b>0" "odd b" "\<lfloor>real_of_int b / 2\<rfloor> < y mod b" 
-shows "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b" "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>"
+  assumes "b > 0" "odd b" "\<lfloor>real_of_int b / 2\<rfloor> < y mod b" 
+  shows "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b"
+    "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>"
 proof -
-  have "\<lfloor>real_of_int b / 2\<rfloor> = (b-1) div 2" using \<open>odd b\<close>
-    by (metis add.commute diff_add_cancel even_add even_succ_div_2 floor_divide_of_int_eq 
-    odd_one of_int_numeral)
-  then show "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b" using assms by linarith
-  have "y mod b \<le> b + \<lfloor>real_of_int b / 2\<rfloor>" using mod_range[OF assms(1)] 
-  by (smt (verit, ccfv_SIG) \<open>\<lfloor>real_of_int b / 2\<rfloor> = (b - 1) div 2\<close> atLeastAtMost_iff 
-    pos_imp_zdiv_neg_iff)
-  then show "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>" by auto
+  from odd_half_floor [of b]
+  show "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b - b"
+    using assms by linarith
+  then have "y mod b \<le> b + \<lfloor>real_of_int b / 2\<rfloor>"
+    by (smt (verit) \<open>b > 0\<close> pos_mod_bound)
+  then show "y mod b - b \<le> \<lfloor>real_of_int b / 2\<rfloor>"
+    by auto
 qed
 
 lemma half_mod:
 assumes "b>0"
 shows "- \<lfloor>real_of_int b / 2\<rfloor> \<le> y mod b"
 using assms
 by (smt (verit, best) floor_less_zero half_gt_zero mod_int_pos_iff of_int_pos)
 
 lemma mod_plus_minus_range_odd: 
   assumes "b>0" "odd b"
   shows "y mod+- b \<in> {-\<lfloor>b/2\<rfloor>..\<lfloor>b/2\<rfloor>}"
 unfolding mod_plus_minus_def by (auto simp add: half_mod_odd[OF assms] half_mod[OF assms(1)])
 
 lemma odd_smaller_b:
   assumes "odd b" 
   shows "\<lfloor> real_of_int b / 2 \<rfloor> + \<lfloor> real_of_int b / 2 \<rfloor> < b"
 using assms 
 by (smt (z3) floor_divide_of_int_eq odd_two_times_div_two_succ 
   of_int_hom.hom_add of_int_hom.hom_one)
  
 
 lemma mod_plus_minus_rangeE_neg:
   assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
           "odd b" "b > 0"
            "\<lfloor>real_of_int b / 2\<rfloor> < y mod b"
   shows "y = y mod b - b"
 proof -
   have "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..<0}" using assms
   by (meson atLeastAtMost_iff atLeastLessThan_iff linorder_not_le order_trans zmod_le_nonneg_dividend)
   then have "y \<in> {-b..<0}" using assms(2-3)
   by (metis atLeastLessThan_iff floor_divide_of_int_eq int_div_less_self linorder_linear 
     linorder_not_le neg_le_iff_le numeral_code(1) numeral_le_iff of_int_numeral order_trans 
     semiring_norm(69))
   then have "y mod b = y + b" 
   by (smt (verit) atLeastLessThan_iff mod_add_self2 mod_pos_pos_trivial)
   then show ?thesis by auto
 qed
 
 lemma mod_plus_minus_rangeE_pos:
   assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
           "odd b" "b > 0"
           "\<lfloor>real_of_int b / 2\<rfloor> \<ge> y mod b"
   shows "y = y mod b"
 proof -
   have "y \<in> {0..\<lfloor>real_of_int b/2\<rfloor>}" 
   proof (rule ccontr)
     assume "y \<notin> {0..\<lfloor>real_of_int b / 2\<rfloor>} "
     then have "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..<0}" using assms(1) by auto
     then have "y \<in> {-b..<0}" using assms(2-3)
     by (metis atLeastLessThan_iff floor_divide_of_int_eq int_div_less_self linorder_linear 
       linorder_not_le neg_le_iff_le numeral_code(1) numeral_le_iff of_int_numeral order_trans 
       semiring_norm(69))
     then have "y mod b = y + b" 
       by (smt (verit) atLeastLessThan_iff mod_add_self2 mod_pos_pos_trivial)
     then have "y mod b \<ge> b - \<lfloor>real_of_int b/2\<rfloor>" using assms(1) by auto
     then have "y mod b > \<lfloor>real_of_int b/2\<rfloor>"
       using assms(2) odd_smaller_b by fastforce
     then show False using assms(4) by auto
   qed
   then have "y \<in> {0..<b}" using assms(2-3)
   by (metis atLeastAtMost_iff atLeastLessThan_empty atLeastLessThan_iff floor_divide_of_int_eq 
     int_div_less_self linorder_not_le numeral_One numeral_less_iff of_int_numeral semiring_norm(76))
   then show ?thesis by auto
 qed
 
 lemma mod_plus_minus_rangeE:
   assumes "y \<in> {-\<lfloor>real_of_int b/2\<rfloor>..\<lfloor>real_of_int b/2\<rfloor>}"
           "odd b" "b > 0"
   shows "y = y mod+- b"
 unfolding mod_plus_minus_def 
 using mod_plus_minus_rangeE_pos[OF assms] mod_plus_minus_rangeE_neg[OF assms]
 by auto
 
 text \<open>Image of $0$.\<close>
 
 lemma mod_plus_minus_zero:
   assumes "x mod+- b = 0"
   shows "x mod b = 0"
 using assms unfolding mod_plus_minus_def 
 by (metis eq_iff_diff_eq_0 mod_mod_trivial mod_self)
 
 lemma mod_plus_minus_zero':
   assumes "b>0" "odd b"
   shows "0 mod+- b = (0::int)" 
 using assms(1) mod_plus_minus_def by force
 
 text \<open>\<open>mod+-\<close> with negative values.\<close>
 
 lemma neg_mod_plus_minus:
   assumes "odd b"
           "b>0"
   shows "(- x) mod+- b = - (x mod+- b)"
 proof -
   obtain k :: int where k_def: "(-x) mod+- b = (-x)+ k* b" 
   using mod_plus_minus_def
   proof -
     assume a1: "\<And>k. - x mod+- b = - x + k * b \<Longrightarrow> thesis"
     have "\<exists>i. i mod b + - (x + i) = - x mod+- b" 
     by (smt (verit, del_insts) mod_add_self1 mod_plus_minus_def)
     then show ?thesis
       using a1 by (metis (no_types) diff_add_cancel diff_diff_add 
       diff_minus_eq_add minus_diff_eq minus_mult_div_eq_mod 
       mult.commute mult_minus_left)
   qed
   then have "(-x) mod+- b = -(x - k*b)" using k_def by auto
   also have "\<dots> = - ((x-k*b) mod+- b)"
   proof -
     have range_xkb:"x - k * b \<in> 
       {- \<lfloor>real_of_int b / 2\<rfloor>..\<lfloor>real_of_int b / 2\<rfloor>}"
       using k_def mod_plus_minus_range_odd[OF assms(2) assms(1)]
       by (smt (verit, ccfv_SIG) atLeastAtMost_iff)
     have "x - k*b = (x - k*b) mod+- b" 
       using mod_plus_minus_rangeE[OF range_xkb assms] by auto
     then show ?thesis by auto
   qed
   also have "-((x - k*b) mod+- b) = -(x mod+- b)" 
     unfolding mod_plus_minus_def 
     by (smt (verit, best) mod_mult_self1)
   finally show ?thesis by auto
 qed
 
 text \<open>Representative with \<open>mod+-\<close>\<close>
 
 lemma mod_plus_minus_rep_ex:
 "\<exists>k. x = k*b + x mod+- b"
 unfolding mod_plus_minus_def 
 by (split if_splits)(metis add.right_neutral add_diff_eq div_mod_decomp_int 
   eq_iff_diff_eq_0 mod_add_self2)
 
 
 lemma mod_plus_minus_rep: 
   obtains k where "x = k*b + x mod+- b"
 using mod_plus_minus_rep_ex by auto
 
 text \<open>Multiplication in \<open>mod+-\<close>\<close>
 
 lemma mod_plus_minus_mult: 
   "s*x mod+- q = (s mod+- q) * (x mod+- q) mod+- q"
 unfolding mod_plus_minus_def 
 by (smt (verit, ccfv_threshold) minus_mod_self2 mod_mult_left_eq mod_mult_right_eq)
 end
\ No newline at end of file
diff --git a/thys/Dict_Construction/dict_construction.ML b/thys/Dict_Construction/dict_construction.ML
--- a/thys/Dict_Construction/dict_construction.ML
+++ b/thys/Dict_Construction/dict_construction.ML
@@ -1,934 +1,934 @@
 signature DICT_CONSTRUCTION =
 sig
   datatype cert_proof = Cert | Skip
 
   type const
 
   type 'a sccs = (string * 'a) list list
 
   val annotate_code_eqs: local_theory -> string list -> (const sccs * local_theory)
   val new_names: local_theory -> const sccs -> (string * const) sccs
   val symtab_of_sccs: 'a sccs -> 'a Symtab.table
 
   val axclass: class -> local_theory -> Class_Graph.node * local_theory
   val instance: (string * const) Symtab.table -> string -> class -> local_theory -> term * local_theory
   val term: term Symreltab.table -> (string * const) Symtab.table -> term -> local_theory -> (term * local_theory)
   val consts: (string * const) Symtab.table -> cert_proof -> (string * const) list -> local_theory -> local_theory
 
   (* certification *)
 
   type const_info =
     {fun_info: Function.info option,
      inducts: thm list option,
      base_thms: thm list,
      base_certs: thm list,
      simps: thm list,
      code_thms: thm list, (* old defining theorems *)
      congs: thm list option}
 
   type fun_target = (string * class) list * (term * term)
 
   type dict_thms =
     {base_thms: thm list,
      def_thm: thm}
 
   type dict_target = (string * class) list * (term * string * class)
 
   val prove_fun_cert: fun_target list -> const_info -> cert_proof -> local_theory -> thm list
   val prove_dict_cert: dict_target -> dict_thms -> local_theory -> thm
 
   val the_info: Proof.context -> string -> const_info
 
   (* utilities *)
 
   val normalizer_conv: Proof.context -> conv
   val cong_of_const: Proof.context -> string -> thm option
   val get_code_eqs: Proof.context -> string -> thm list
   val group_code_eqs: Proof.context -> string list ->
     (string * (((string * sort) list * typ) * ((term list * term) * thm option) list)) list list
 end
 
 structure Dict_Construction: DICT_CONSTRUCTION =
 struct
 
 open Class_Graph
 open Dict_Construction_Util
 
 (* FIXME copied from skip_proof.ML *)
 
 val (_, make_thm_cterm) =
   Context.>>>
     (Context.map_theory_result (Thm.add_oracle (@{binding cert_oracle}, I)))
 
 fun make_thm ctxt prop = make_thm_cterm (Thm.cterm_of ctxt prop)
 
 fun cheat_tac ctxt i st =
   resolve_tac ctxt [make_thm ctxt (Var (("A", 0), propT))] i st
 
 (** utilities **)
 
 val normalizer_conv = Axclass.overload_conv
 
 fun cong_of_const ctxt name =
   let
     val head =
       Thm.concl_of
       #> Logic.dest_equals #> fst
       #> strip_comb #> fst
       #> dest_Const #> fst
     fun applicable thm =
       try head thm = SOME name
   in
     Function_Context_Tree.get_function_congs ctxt
     |> filter applicable
     |> try hd
   end
 
 fun group_code_eqs ctxt consts =
   let
     val thy = Proof_Context.theory_of ctxt
     val graph = #eqngr (Code_Preproc.obtain true { ctxt = ctxt, consts = consts, terms = [] })
 
     fun mk_eqs name = name
       |> Code_Preproc.cert graph
       |> Code.equations_of_cert thy ||> these
       ||> map (apsnd fst o apfst (apsnd snd o apfst (map snd)))
       |> pair name
   in
     map (map mk_eqs) (rev (Graph.strong_conn graph))
   end
 
 fun get_code_eqs ctxt const =
   AList.lookup op = (flat (group_code_eqs ctxt [const])) const
   |> the |> snd
   |> map snd
   |> cat_options
   |> map (Conv.fconv_rule (normalizer_conv ctxt))
 
 (** certification **)
 
 datatype cert_proof = Cert | Skip
 
 type const_info =
   {fun_info: Function.info option,
    inducts: thm list option,
    base_thms: thm list,
    base_certs: thm list,
    simps: thm list,
    code_thms: thm list,
    congs: thm list option}
 
 fun map_const_info f1 f2 f3 f4 f5 f6 f7 {fun_info, inducts, base_thms, base_certs, simps, code_thms, congs} =
   {fun_info = f1 fun_info,
    inducts = f2 inducts,
    base_thms = f3 base_thms,
    base_certs = f4 base_certs,
    simps = f5 simps,
    code_thms = f6 code_thms,
    congs = f7 congs}
 
 fun morph_const_info phi =
   map_const_info
     (Option.map (Function_Common.transform_function_data phi))
     (Option.map (map (Morphism.thm phi)))
     (map (Morphism.thm phi))
     (map (Morphism.thm phi))
     (map (Morphism.thm phi))
     I (* sic *)
     (Option.map (map (Morphism.thm phi)))
 
 type fun_target = (string * class) list * (term * term)
 
 type dict_thms =
   {base_thms: thm list,
    def_thm: thm}
 
 type dict_target = (string * class) list * (term * string * class)
 
 fun fun_cert_tac base_thms base_certs simps code_thms =
   SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, concl, ...} =>
     let
       val _ =
         if_debug ctxt (fn () =>
           tracing ("Proving " ^ Syntax.string_of_term ctxt (Thm.term_of concl)))
 
       fun is_ih prem =
         Thm.prop_of prem |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |> can HOLogic.dest_eq
 
       val (ihs, certs) = partition is_ih prems
       val super_certs = all_edges ctxt |> Symreltab.dest |> map (#subclass o snd)
       val param_dests = all_nodes ctxt |> Symtab.dest |> maps (#3 o #cert_thms o snd)
       val congs = Function_Context_Tree.get_function_congs ctxt @ map safe_mk_meta_eq @{thms cong}
 
       val simp_context = (clear_simpset ctxt) addsimps (certs @ super_certs @ base_certs @ base_thms @ param_dests)
         addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv)
 
       val ihs = map (Simplifier.asm_full_simplify simp_context) ihs
 
       val ih_tac =
         resolve_tac ctxt ihs THEN_ALL_NEW
           (TRY' (SOLVED' (Simplifier.asm_full_simp_tac simp_context)))
 
       val unfold_new =
         ANY' (map (CONVERSION o rewr_lhs_head_conv) simps)
 
       val normalize =
         CONVERSION (normalizer_conv ctxt)
 
       val unfold_old =
         ANY' (map (CONVERSION o rewr_rhs_head_conv) code_thms)
 
       val simp =
         CONVERSION (lhs_conv (Simplifier.asm_full_rewrite simp_context))
 
       fun walk_congs i = i |>
         ((resolve_tac ctxt @{thms refl} ORELSE'
           SOLVED' (Simplifier.asm_full_simp_tac simp_context) ORELSE'
           ih_tac ORELSE'
           Method.assm_tac ctxt ORELSE'
           (resolve_tac ctxt @{thms meta_eq_to_obj_eq} THEN'
             fo_resolve_tac congs ctxt)) THEN_ALL_NEW walk_congs)
 
       val tacs =
         [unfold_new, normalize, unfold_old, simp, walk_congs]
     in
       EVERY' tacs 1
     end)
 
 fun dict_cert_tac class def_thm base_thms =
   SOLVED' o Subgoal.FOCUS (fn {prems, context = ctxt, ...} =>
     let
       val (intro, sels) = case node ctxt class of
         SOME {cert_thms = (_, intro, _), data_thms = sels, ...} => (intro, sels)
       | NONE => error ("class " ^ class ^ " is not defined")
 
       val apply_intro =
         resolve_tac ctxt [intro]
 
       val unfold_dict =
         CONVERSION (Conv.rewr_conv def_thm |> Conv.arg_conv |> lhs_conv)
 
       val normalize =
         CONVERSION (normalizer_conv ctxt)
 
       val smash_sels =
         CONVERSION (lhs_conv (Conv.rewrs_conv sels))
 
       val solve =
         resolve_tac ctxt (@{thm HOL.refl} :: base_thms)
 
       val finally =
         resolve_tac ctxt prems
 
       val tacs =
         [apply_intro, unfold_dict, normalize, smash_sels, solve, finally]
     in
       EVERY (map (ALLGOALS' ctxt) tacs)
     end)
 
 fun prepare_dicts classes names lthy =
   let
     val sorts = Symtab.make_list classes
 
     fun mk_dicts (param_name, (tvar, class)) =
       case node lthy class of
         NONE =>
           error ("unknown class " ^ class)
       | SOME {cert, qname, ...} =>
           let
             val sort = the (Symtab.lookup sorts tvar)
             val param = Free (param_name, Type (qname, [TFree (tvar, sort)]))
           in
             (param, HOLogic.mk_Trueprop (cert dummyT $ param))
           end
 
     val dict_names = Name.invent_names names "a" classes
     val names = fold Name.declare (map fst dict_names) names
     val (dict_params, prems) = split_list (map mk_dicts dict_names)
   in (dict_params, prems, names) end
 
 fun prepare_fun_goal targets lthy =
   let
     fun mk_eq (classes, (lhs, rhs)) names =
       let
         val (lhs_name, _) = dest_Const lhs
         val (rhs_name, rhs_typ) = dest_Const rhs
 
         val (dict_params, prems, names) = prepare_dicts classes names lthy
 
         val param_names = fst (strip_type rhs_typ) |> map (K dummyT) |> Name.invent_names names "a"
         val names = fold Name.declare (map fst param_names) names
         val params = map Free param_names
 
         val lhs = list_comb (Const (lhs_name, dummyT), dict_params @ params)
         val rhs = list_comb (Const (rhs_name, dummyT), params)
 
         val eq = Const (@{const_name HOL.eq}, dummyT) $ lhs $ rhs
 
         val all_params = dict_params @ params
         val eq :: rest = Syntax.check_terms lthy (eq :: prems @ all_params)
         val (prems, all_params) = unappend (prems, all_params) rest
 
         val eq =
           if is_some (Axclass.inst_of_param (Proof_Context.theory_of lthy) rhs_name) then
             Thm.cterm_of lthy eq |> conv_result (Conv.arg_conv (normalizer_conv lthy))
           else
             eq
 
         val prop = prems ===> HOLogic.mk_Trueprop eq
       in ((all_params, prop), names) end
   in
     fold_map mk_eq targets Name.context
     |> fst
     |> split_list
   end
 
 fun prepare_dict_goal (classes, (term, _, class)) lthy =
   let
     val cert = case node lthy class of
       NONE =>
         error ("unknown class " ^ class)
     | SOME {cert, ...} =>
         cert dummyT
 
     val names = Name.context
     val (dict_params, prems, _) = prepare_dicts classes names lthy
     val (term_name, _) = dest_Const term
     val dict = list_comb (Const (term_name, dummyT), dict_params)
 
     val prop = prems ===> HOLogic.mk_Trueprop (cert $ dict)
     val prop :: dict_params = Syntax.check_terms lthy (prop :: dict_params)
   in
     (dict_params, prop)
   end
 
 fun prove_fun_cert targets {inducts, base_thms, base_certs, simps, code_thms, ...} proof lthy =
   let
     (* the props contain dictionary certs as prems
        we can't exclude them from the induction because the dicts are part of the function
        definition
        excluding them would mean that applying the induction rules becomes tricky or impossible
        proper fix would be if fun, akin to inductive, supported a "for" clause that marks parameters
        as "not changing" *)
     val (argss, props) = prepare_fun_goal targets lthy
     val frees = flat argss |> map (fst o dest_Free)
 
     (* we first prove the extensional variant (easier to prove), and then derive the
        contracted variant
        abs_def can't deal with premises, so we use our own version here *)
     val tac =
       case proof of
         Cert => fun_cert_tac base_thms base_certs simps code_thms
       | Skip => cheat_tac
 
     val long_thms =
        prove_common' lthy frees [] props (fn {context, ...} =>
           maybe_induct_tac inducts argss [] context THEN
             ALLGOALS' context (tac context))
   in
     map (contract lthy) long_thms
   end
 
 fun prove_dict_cert target {base_thms, def_thm} lthy =
   let
     val (args, prop) = prepare_dict_goal target lthy
     val frees = map (fst o dest_Free) args
     val (_, (_, _, class)) = target
   in
     prove' lthy frees [] prop (fn {context, ...} =>
       dict_cert_tac class def_thm base_thms context 1)
   end
 
 (** background data **)
 
 type definitions =
   {instantiations: (term * thm) Symreltab.table, (* key: (class, tyco) *)
    constants: (string * (thm option * const_info)) Symtab.table (* key: constant name *) }
 
 structure Definitions = Generic_Data
 (
   type T = definitions
   val empty = {instantiations = Symreltab.empty, constants = Symtab.empty}
   fun merge ({instantiations = i1, constants = c1}, {instantiations = i2, constants = c2}) =
     if Symreltab.is_empty i1 andalso Symtab.is_empty c1 andalso
        Symreltab.is_empty i2 andalso Symtab.is_empty c2 then
       empty
     else
       error "merging not supported"
 )
 
 fun map_definitions map_insts map_consts =
   Definitions.map (fn {instantiations, constants} =>
     {instantiations = map_insts instantiations,
      constants = map_consts constants})
 
 fun the_info ctxt name =
   Symtab.lookup (#constants (Definitions.get (Context.Proof ctxt))) name
   |> the
   |> snd
   |> snd
 
 fun add_instantiation (class, tyco) term cert =
   let
     fun upd phi =
       map_definitions
         (fn tab =>
           if Symreltab.defined tab (class, tyco) then
             error ("Duplicate instantiation " ^ quote tyco ^ " :: " ^ quote class)
           else
             tab
             |> Symreltab.update ((class, tyco), (Morphism.term phi term, Morphism.thm phi cert))) I
   in
     Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} upd
   end
 
 fun add_constant name name' (cert, info) lthy =
   let
     val qname = Local_Theory.full_name lthy (Binding.name name')
     fun upd phi =
       map_definitions I
         (fn tab =>
           if Symtab.defined tab name then
             error ("Duplicate constant " ^ quote name)
           else
             tab
             |> Symtab.update (name,
                 (qname, (Option.map (Morphism.thm phi) cert, morph_const_info phi info))))
   in
     Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} upd lthy
     |> Local_Theory.note ((Binding.empty, @{attributes [dict_construction_specs]}), #simps info)
     |> snd
   end
 
 (** classes **)
 
 fun axclass class =
   ensure_class class
   #>> node_of
 
 (** grouping and annotating constants **)
 
 datatype const =
   Fun of
     {dicts: ((string * class) * typ) list,
      certs: term list,
      param_typs: typ list,
      typ: typ, (* typified *)
      new_typ: typ,
      eqs: {params: term list, rhs: term, thm: thm} list,
      info: Function_Common.info option,
      cong: thm option} |
   Constructor |
   Classparam of
     {class: class,
      typ: typ, (* varified *)
      selector: term (* varified *)}
 
 type 'a sccs = (string * 'a) list list
 
 fun symtab_of_sccs x = Symtab.make (flat x)
 
 fun raw_dict_params tparams lthy =
   let
     fun mk_dict tparam class lthy =
       let
         val (node, lthy') = axclass class lthy
         val targ = TFree (tparam, @{sort type})
         val typ = dict_typ node targ
         val cert = #cert node targ
       in ((((tparam, class), typ), cert), lthy') end
     fun mk_dicts (tparam, sort) = fold_map
       (mk_dict tparam)
       (filter (Class.is_class (Proof_Context.theory_of lthy)) sort)
    in fold_map mk_dicts tparams lthy |>> flat end
 
 fun dict_params context dicts =
   let
     fun dict_param ((_, class), typ) =
       Name.variant (mangle class) #>> rpair typ #>> Free
   in
     fold_map dict_param dicts context
   end
 
 fun get_sel class param typ lthy =
   let
     val ({selectors, ...}, lthy') = axclass class lthy
   in
     case Symtab.lookup selectors param of
       NONE => error ("unknown class parameter " ^ param)
     | SOME sel => (sel typ, lthy')
   end
 
 fun annotate_const name ((tparams, typ), raw_eqs) lthy =
   if Code.is_constr (Proof_Context.theory_of lthy) name then
     ((name, Constructor), lthy)
   else if null raw_eqs then
     (* this detection is reliable, because code equations with overloaded heads are not allowed *)
     let
       val (_, class) = the_single tparams ||> the_single
       val (selector, thy') = get_sel class name (TVar (("'a", 0), @{sort type})) lthy
       val typ = range_type (fastype_of selector)
     in
       ((name, Classparam {class = class, typ = typ, selector = selector}), thy')
     end
   else
     let
       val info = try (Function.get_info lthy) (Const (name, typ))
       val cong = cong_of_const lthy name
       val ((raw_dicts, certs), lthy') = raw_dict_params tparams lthy |>> split_list
       val dict_typs = map snd raw_dicts
       val typ' = typify_typ typ
       fun mk_eq ((raw_params, rhs), SOME thm) =
             let
               val norm = normalizer_conv lthy'
               val transform = Thm.cterm_of lthy' #> conv_result norm #> typify
               val params = map transform raw_params
             in
               if has_duplicates (op =) (flat (map all_frees' params)) then
                 (warning "ignoring code equation with non-linear pattern"; NONE)
               else
                 SOME {params = params, rhs = rhs, thm = Conv.fconv_rule norm thm}
             end
         | mk_eq _ =
             error "no theorem"
       val const =
         Fun
           {dicts = raw_dicts, certs = certs, typ = typ', param_typs = binder_types typ',
            new_typ = dict_typs ---> typ', eqs = map_filter mk_eq raw_eqs, info = info, cong = cong}
     in ((name, const), lthy') end
 
 fun annotate_code_eqs lthy consts =
   fold_map (fold_map (uncurry annotate_const)) (group_code_eqs lthy consts) lthy
 
 (** instances and terms **)
 
 fun mk_path [] _ _ lthy = (NONE, lthy)
   | mk_path ((class, term) :: rest) typ goal lthy =
     let
       val (ev, lthy') = ensure_class class lthy
     in
       case find_path ev goal of
         SOME path => (SOME (fold_path path typ term), lthy')
       | NONE =>      mk_path rest typ goal lthy'
     end
 
 fun instance consts tyco class lthy =
   case Symreltab.lookup (#instantiations (Definitions.get (Context.Proof lthy))) (class, tyco) of
     SOME (inst, _) =>
       (inst, lthy)
   | NONE =>
       let
         val thy = Proof_Context.theory_of lthy
         val tparam_sorts = param_sorts tyco class thy
 
         fun print_info ctxt =
           let
             val tvars =
               Name.invent_list [] Name.aT (length tparam_sorts) ~~ tparam_sorts
               |> map TFree
           in
             [Pretty.str "Defining instance ", Syntax.pretty_typ ctxt (Type (tyco, tvars)),
               Pretty.str " :: ", Syntax.pretty_sort ctxt [class]]
             |> Pretty.block
             |> Pretty.writeln
           end
 
         val ({make, ...}, lthy) = axclass class lthy
 
         val name = mangle class ^ "__instance__" ^ mangle tyco
         val tparams = Name.invent_names Name.context Name.aT tparam_sorts
         val ((dict_params, _), lthy) = raw_dict_params tparams lthy
           |>> map fst
           |>> dict_params (Name.make_context [name])
         val dict_context = Symreltab.make (flat_right tparams ~~ dict_params)
 
         val {params, ...} = Axclass.get_info thy class
 
         val (super_fields, lthy) = fold_map
           (obtain_dict dict_context consts (Type (tyco, map TFree tparams)))
           (super_classes class thy)
           lthy
 
         val tparams' = map (TFree o rpair @{sort type} o fst) tparams
         val typ_inst = (TFree ("'a", [class]), Type (tyco, tparams'))
 
         fun mk_field (field, typ) =
           let
             val param = Axclass.param_of_inst thy (field, tyco)
             (* check: did we already define all required fields? *)
             (* if not: abort (else we would run into an infinite loop) *)
             val _ = case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) param of
               NONE =>
                 (* necessary for zero_nat *)
                 if Code.is_constr thy param then
                   ()
                 else
                   error ("cyclic dependency: " ^ param ^ " not yet defined in the definition of " ^ tyco ^ " :: " ^ class)
             | SOME _ => ()
           in
             term dict_context consts (Const (param, typ_subst_atomic [typ_inst] typ))
            end
 
         val (fields, lthy) = fold_map mk_field params lthy
 
         val rhs = list_comb (make (Type (tyco, tparams')), super_fields @ fields)
         val typ = map fastype_of dict_params ---> fastype_of rhs
         val head = Free (name, typ)
         val lhs = list_comb (head, dict_params)
         val term = Logic.mk_equals (lhs, rhs)
 
         val (def, (lthy', lthy)) = lthy
           |> tap print_info
           |> (snd o Local_Theory.begin_nested)
           |> define_params_nosyn term
           ||> `Local_Theory.end_nested
         val phi = Proof_Context.export_morphism lthy lthy'
         val def = Morphism.thm phi def
 
         val base_thms =
           Definitions.get (Context.Proof lthy') |> #constants |> Symtab.dest
           |> map (apsnd fst o snd)
           |> map_filter snd
 
         val target = (flat_right tparams, (Morphism.term phi head, tyco, class))
         val args = {base_thms = base_thms, def_thm = def}
         val thm = prove_dict_cert target args lthy'
 
         val const = Const (Local_Theory.full_name lthy' (Binding.name name), typ)
       in
         (const, add_instantiation (class, tyco) const thm lthy')
       end
 and obtain_dict dict_context consts =
   let
     val dict_context' = Symreltab.dest dict_context
     fun for_class (Type (tyco, args)) class lthy =
           let
             val inst_param_sorts = param_sorts tyco class (Proof_Context.theory_of lthy)
             val (raw_inst, lthy') = instance consts tyco class lthy
             val (const_name, _) = dest_Const raw_inst
             val (inst_args, lthy'') = fold_map for_sort (inst_param_sorts ~~ args) lthy'
             val head = Sign.mk_const (Proof_Context.theory_of lthy'') (const_name, args)
           in
             (list_comb (head, flat inst_args), lthy'')
           end
       | for_class (TFree (name, _)) class lthy =
           let
             val available = map_filter
               (fn ((tp, class), term) => if tp = name then SOME (class, term) else NONE)
               dict_context'
             val (path, lthy') = mk_path available (TFree (name, @{sort type})) class lthy
           in
             case path of
               SOME term => (term, lthy')
             | NONE => error "no path found"
           end
       | for_class (TVar _) _ _ = error "unexpected type variable"
     and for_sort (sort, typ) =
           fold_map (for_class typ) sort
   in for_class end
 and term dict_context consts term lthy =
   let
     fun traverse (t as Const (name, typ)) lthy =
         (case Symtab.lookup consts name of
           NONE => error ("unknown constant " ^ name)
         | SOME (_, Constructor) =>
             (typify t, lthy)
         | SOME (_, Classparam {class, typ = typ', selector}) =>
             let
               val subst = Sign.typ_match (Proof_Context.theory_of lthy) (typ', typ) Vartab.empty
               val (_, targ) = the (Vartab.lookup subst ("'a", 0))
               val (dict, lthy') = obtain_dict dict_context consts targ class lthy
             in
               (subst_TVars [(("'a", 0), targ)] selector $ dict, lthy')
             end
         | SOME (name', Fun {dicts = dicts, typ = typ', new_typ, ...}) =>
             let
               val subst = Type.raw_match (Logic.varifyT_global typ', typ) Vartab.empty
                 |> Vartab.dest |> map (apsnd snd)
               fun lookup tparam = the (AList.lookup (op =) subst (tparam, 0))
               val (dicts, lthy') =
                 fold_map (uncurry (obtain_dict dict_context consts o lookup)) (map fst dicts) lthy
               val typ = typ_subst_TVars subst (Logic.varifyT_global new_typ)
               val head =
                 case Symtab.lookup (#constants (Definitions.get (Context.Proof lthy))) name of
                   NONE => Free (name', typ)
                 | SOME (n, _) => Const (n, typ)
               val res = list_comb (head, dicts)
             in
               (res, lthy')
             end)
       | traverse (f $ x) lthy =
           let
             val (f', lthy')  = traverse f lthy
             val (x', lthy'') = traverse x lthy'
           in (f' $ x', lthy'') end
       | traverse (Abs (name, typ, term)) lthy =
           let
             val (term', lthy') = traverse term lthy
           in (Abs (name, typify_typ typ, term'), lthy') end
       | traverse (Free (name, typ)) lthy = (Free (name, typify_typ typ), lthy)
       | traverse (Var (name, typ)) lthy  = (Var (name, typify_typ typ), lthy)
       | traverse (Bound n) lthy = (Bound n, lthy)
   in
     traverse term lthy
   end
 
 (** group of constants **)
 
 fun new_names lthy consts =
   let
     val (all_names, all_consts) = split_list (flat consts)
     val all_frees = map (fn Fun {eqs, ...} => eqs | _ => []) all_consts |> flat
       |> map #params |> flat
       |> map all_frees' |> flat
     val context = fold Name.declare (all_names @ all_frees) (Variable.names_of lthy)
 
     fun new_name (name, const) context =
       let val (name', context') = Name.variant (mangle name) context in
         ((name, (name', const)), context')
       end
   in
     fst (fold_map (fold_map new_name) consts context)
   end
 
 fun consts consts proof group lthy =
   let
     val fun_config = Function_Common.FunctionConfig
       {sequential=true, default=NONE, domintros=false, partials=false}
     fun pat_completeness_auto ctxt =
       Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt
 
     val all_names = map fst group
 
     val pretty_consts = map (pretty_const lthy) all_names |> Pretty.commas
 
     fun print_info msg =
       Pretty.str (msg ^ " ") :: pretty_consts
       |> Pretty.block
       |> Pretty.writeln
 
     val _ = print_info "Redefining constant(s)"
 
     fun process_eqs (name, Fun {dicts, param_typs, new_typ, eqs, info, cong, ...}) lthy =
           let
             val new_name = case Symtab.lookup consts name of
               NONE => error ("no new name for " ^ name)
             | SOME (n, _) => n
 
             val all_frees = map #params eqs |> flat |> map all_frees' |> flat
             val context = Name.make_context (all_names @ all_frees)
             val (dict_params, context') = dict_params context dicts
 
             fun adapt_params param_typs params =
               let
                 val real_params = dict_params @ params
                 val ext_params = drop (length params) param_typs
                   |> map typify_typ
                   |> Name.invent_names context' "e0" |> map Free
               in (real_params, ext_params) end
 
             fun mk_eq {params, rhs, thm} lthy =
               let
                 val (real_params, ext_params) = adapt_params param_typs params
                 val lhs' = list_comb (Free (new_name, new_typ), real_params @ ext_params)
                 val (rhs', lthy') = term (Symreltab.make (map fst dicts ~~ dict_params)) consts rhs lthy
                 val rhs'' = list_comb (rhs', ext_params)
               in
                 ((HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs', rhs'')), thm), lthy')
               end
 
             val is_fun = length param_typs + length dicts > 0
           in
             fold_map mk_eq eqs lthy
             |>> rpair (new_typ, is_fun)
             |>> SOME
             |>> pair ((name, new_name, map fst dicts), {info = info, cong = cong})
           end
       | process_eqs (name, _) lthy =
           ((((name, name, []), {info = NONE, cong = NONE}), NONE), lthy)
 
     val (items, lthy') = fold_map process_eqs group lthy
 
     val ((metas, infos), ((eqs, code_thms), (new_typs, is_funs))) = items
       |> map_filter (fn (meta, eqs) => Option.map (pair meta) eqs)
       |> split_list
       ||> split_list ||> apfst (flat #> split_list #>> map typify)
       ||> apsnd split_list
       |>> split_list
 
     val _ = if_debug lthy (fn () =>
       if null code_thms then ()
       else
         map (Syntax.pretty_term lthy o Thm.prop_of) code_thms
         |> Pretty.big_list "Equations:"
         |> Pretty.string_of
         |> tracing)
 
     val is_fun =
       case distinct (op =) is_funs of
         [b] => b
       | [] => false
       | _ => error "unsupported feature: mixed non-function and function definitions"
     fun mk_binding (_, new_name, _) typ =
       (Binding.name new_name, SOME typ, NoSyn)
     val bindings = map2 mk_binding metas new_typs
 
     val {constants, instantiations} = Definitions.get (Context.Proof lthy')
     val base_thms = Symtab.dest constants |> map (apsnd fst o snd) |> map_filter snd
     val base_certs = Symreltab.dest instantiations |> map (snd o snd)
 
     val consts = Sign.consts_of (Proof_Context.theory_of lthy')
 
     fun prove_eq_fun (info as {simps = SOME simps, fs, inducts = SOME inducts, ...}) lthy =
       let
         fun mk_target (name, _, classes) new =
-          (classes, (new, Const (Consts.the_const consts name)))
+          (classes, (new, Const (name, Consts.the_const_type consts name)))
         val targets = map2 mk_target metas fs
         val args =
           {fun_info = SOME info, inducts = SOME inducts, simps = simps, base_thms = base_thms,
            base_certs = base_certs, code_thms = code_thms, congs = NONE}
       in
         (prove_fun_cert targets args proof lthy, args)
       end
 
     fun prove_eq_def defs lthy =
       let
         fun mk_target (name, _, classes) new =
-          (classes, (new, Const (Consts.the_const consts name)))
+          (classes, (new, Const (name, Consts.the_const_type consts name)))
         val targets = map2 mk_target metas (map (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) defs)
         val args =
           {fun_info = NONE, inducts = NONE, simps = defs,
            base_thms = base_thms, base_certs = base_certs, code_thms = code_thms, congs = NONE}
       in
         (prove_fun_cert targets args proof lthy, args)
       end
 
     fun add_constants ((((name, name', _), _), SOME _) :: xs) ((thm :: thms), info) =
           add_constant name name' (SOME thm, info) #> add_constants xs (thms, info)
       | add_constants ((((name, name', _), _), NONE) :: xs) (thms, info) =
           add_constant name name' (NONE, info) #> add_constants xs (thms, info)
       | add_constants [] _ =
           I
 
     fun prove_termination new_info ctxt =
       let
         val termination_ctxt =
           ctxt addsimps (@{thms equal} @ base_thms)
             addloop ("overload", CONVERSION o changed_conv o Axclass.overload_conv)
         val fallback_tac =
           Function_Common.termination_prover_tac true termination_ctxt
 
         val tac = case try hd (cat_options (map #info infos)) of
           SOME old_info => HEADGOAL (Transfer_Termination.termination_tac new_info old_info ctxt)
         | NONE => no_tac
 
       in Function.prove_termination NONE (tac ORELSE fallback_tac) ctxt end
 
     fun prove_cong data lthy =
       let
         fun rewr_cong thm cong =
           if Thm.nprems_of thm > 0 then
             (warning "No fundef_cong rule can be derived; this will likely not work later"; NONE)
           else
             (print_info "Porting fundef_cong rule for ";
              SOME (Local_Defs.fold lthy [thm] cong))
 
         val congs' =
           map2 (Option.mapPartial o rewr_cong) (fst data) (map #cong infos)
           |> cat_options
 
         fun add_congs phi =
           fold Function_Context_Tree.add_function_cong (map (Morphism.thm phi) congs')
 
         val data' =
           apsnd (map_const_info I I I I I I (K (SOME congs'))) data
       in
         (data', Local_Theory.declaration {pervasive = false, syntax = false, pos = \<^here>} add_congs lthy)
       end
 
     fun mk_fun lthy =
       let
         val specs = map (fn eq => (((Binding.empty, []), eq), [], [])) eqs
         val (info, lthy') =
           Function.add_function bindings specs fun_config pat_completeness_auto lthy
           |-> prove_termination
         val simps = the (#simps info)
         val (_, lthy'') =
           (* [simp del] is required because otherwise non-matching function definitions
              (e.g. divmod_nat) make the simplifier loop
              separate step because otherwise we'll get tons of warnings because the psimp rules
              are not added to the simpset *)
           Local_Theory.note ((Binding.empty, @{attributes [simp del]}), simps) lthy'
         fun prove_eq phi =
           prove_eq_fun (Function_Common.transform_function_data phi info)
       in
         (((simps, #inducts info), prove_eq), lthy'')
       end
 
     fun mk_def lthy =
       let
         val (defs, lthy') = fold_map define_params_nosyn eqs lthy
         fun prove_eq phi = prove_eq_def (map (Morphism.thm phi) defs)
       in
         (((defs, NONE), prove_eq), lthy')
       end
   in
     if null eqs then
       lthy'
     else
       let
         (* the redefinition itself doesn't have a sort constraint, but the equality prop may have
            one; hence the proof needs to happen after exiting the local theory target
            conceptually, everything happening locally would be great, but the type checker won't
            allow us to add sort constraints to TFrees after they have been declared *)
         val ((side, prove_eq), (lthy', lthy)) = lthy'
           |> (snd o Local_Theory.begin_nested)
           |> (if is_fun then mk_fun else mk_def)
           |-> (fn ((simps, inducts), prove_eq) =>
                 apfst (rpair prove_eq) o Side_Conditions.mk_side simps inducts)
           ||> `Local_Theory.end_nested
         val phi = Proof_Context.export_morphism lthy lthy'
       in
         lthy'
         |> `(prove_eq phi)
         |>> apfst (on_thms_complete (fn () => print_info "Proved equivalence for"))
         |-> prove_cong
         |-> add_constants items
       end
   end
 
 fun const_raw (binding, raw_consts) proof lthy =
   let
     val _ =
       if proof = Skip then
         warning "Skipping certificate proofs"
       else ()
 
     val (name, _) = Syntax.read_terms lthy raw_consts |> map dest_Const |> split_list
 
     val (eqs, lthy) = annotate_code_eqs lthy name
     val tab = symtab_of_sccs (new_names lthy eqs)
 
     val lthy = fold (consts tab proof) eqs lthy
 
     val {instantiations, constants} = Definitions.get (Context.Proof lthy)
     val thms =
       map (snd o snd) (Symreltab.dest instantiations) @
         map_filter (fst o snd o snd) (Symtab.dest constants)
   in
     snd (Local_Theory.note (binding, thms) lthy)
   end
 
 (** setup **)
 
 val parse_flags =
   Scan.optional (Args.parens (Parse.reserved "skip" >> K Skip)) Cert
 
 val _ =
   Outer_Syntax.local_theory
     @{command_keyword "declassify"}
     "redefines a constant after applying the dictionary construction"
     (parse_flags -- Parse_Spec.opt_thm_name ":" -- Scan.repeat1 Parse.const >>
         (fn ((flags, def_binding), consts) => const_raw (def_binding, consts) flags))
 
 end
\ No newline at end of file
diff --git a/thys/Distributed_Distinct_Elements/Distributed_Distinct_Elements_Accuracy_Without_Cutoff.thy b/thys/Distributed_Distinct_Elements/Distributed_Distinct_Elements_Accuracy_Without_Cutoff.thy
--- a/thys/Distributed_Distinct_Elements/Distributed_Distinct_Elements_Accuracy_Without_Cutoff.thy
+++ b/thys/Distributed_Distinct_Elements/Distributed_Distinct_Elements_Accuracy_Without_Cutoff.thy
@@ -1,1007 +1,1007 @@
 section \<open>Accuracy without cutoff\label{sec:accuracy_wo_cutoff}\<close>
 
 text \<open>This section verifies that each of the $l$ estimate have the required accuracy with high
 probability assuming that there was no cut-off, i.e., that $s=0$. Section~\ref{sec:accuracy} will
 then show that this remains true as long as the cut-off is below @{term "t f"} the subsampling
 threshold.\<close>
 
 theory Distributed_Distinct_Elements_Accuracy_Without_Cutoff
   imports
     Distributed_Distinct_Elements_Inner_Algorithm
     Distributed_Distinct_Elements_Balls_and_Bins
 begin
 
 no_notation Polynomials.var ("X\<index>")
 
 locale inner_algorithm_fix_A = inner_algorithm +
   fixes A
   assumes A_range: "A \<subseteq> {..<n}"
   assumes A_nonempty: "{} \<noteq> A"
 begin
 
 definition X :: nat where "X = card A"
 
 definition q_max where "q_max = nat (\<lceil>log 2 X\<rceil> - b_exp)"
 
 definition t :: "(nat \<Rightarrow> nat) \<Rightarrow> int"
   where "t f = int (Max (f ` A)) - b_exp + 9"
 
 definition s :: "(nat \<Rightarrow> nat) \<Rightarrow> nat"
   where "s f = nat (t f)"
 
 definition R :: "(nat \<Rightarrow> nat) \<Rightarrow> nat set"
   where "R f = {a. a \<in> A \<and> f a \<ge> s f}"
 
 definition r :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> nat"
   where "r x f = card {a. a \<in> A \<and> f a \<ge> x}"
 
 definition p where "p = (\<lambda>(f,g,h). card {j\<in> {..<b}. \<tau>\<^sub>1 (f,g,h) A 0 j \<ge> s f})"
 
 definition Y where "Y = (\<lambda>(f,g,h). 2 ^ s f * \<rho>_inv (p (f,g,h)))"
 
 lemma fin_A: "finite A"
   using A_range finite_nat_iff_bounded by auto
 
 lemma X_le_n: "X \<le> n"
 proof -
   have "card A \<le> card {..<n}"
     by (intro card_mono A_range) simp
   thus ?thesis
     unfolding X_def by simp
 qed
 
 lemma X_ge_1: "X \<ge> 1"
   unfolding X_def
   using fin_A A_nonempty by (simp add: leI)
 
 lemma of_bool_square: "(of_bool x)\<^sup>2 = ((of_bool x)::real)"
   by (cases x, auto)
 
 lemma r_eq: "r x f = (\<Sum> a \<in> A.( of_bool( x \<le> f a) :: real))"
   unfolding r_def of_bool_def sum.If_cases[OF fin_A]
   by (simp add: Collect_conj_eq)
 
 lemma
   shows
     r_exp: "(\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1) = real X * (of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1) / 2^x)" and
     r_var: "measure_pmf.variance \<Psi>\<^sub>1 (\<lambda>\<omega>. real (r x \<omega>)) \<le> (\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1)"
 proof -
   define V :: "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> real" where "V = (\<lambda>a f. of_bool (x \<le> f a))"
 
   have V_exp: "(\<integral>\<omega>. V a \<omega> \<partial>\<Psi>\<^sub>1) = of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1)/2^x"
     (is "?L = ?R") if "a \<in> A" for a
   proof -
     have a_le_n: "a < n"
       using that A_range by auto
 
     have "?L = (\<integral>\<omega>. indicator {f. x \<le> f a} \<omega> \<partial> \<Psi>\<^sub>1)"
       unfolding V_def by (intro integral_cong_AE) auto
     also have "... = measure (map_pmf (\<lambda>\<omega>. \<omega> a) (sample_pmf \<Psi>\<^sub>1)) {f. x \<le> f}"
       by simp
     also have "... = measure (\<G> n_exp) {f. x \<le> f}"
       unfolding \<Psi>\<^sub>1.single[OF a_le_n] by simp
     also have "... = of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1)/2^x"
       unfolding \<G>_prob n_exp_def by simp
     finally show ?thesis by simp
   qed
 
   have b:"(\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1) = (\<Sum> a \<in> A. (\<integral>\<omega>. V a \<omega> \<partial>\<Psi>\<^sub>1))"
     unfolding r_eq V_def  using \<Psi>\<^sub>1.sample_space
     by (intro Bochner_Integration.integral_sum) auto
   also have "... = (\<Sum> a \<in> A.  of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1)/2^x)"
     using V_exp by (intro sum.cong) auto
   also have "... = X * (of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1) / 2^x)"
     using X_def by simp
   finally show "(\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1) = real X * (of_bool (x \<le> max (nat \<lceil>log 2 n\<rceil>) 1)/ 2^x)"
     by simp
 
   have "(\<integral>\<omega>. (V a \<omega>)^2 \<partial> \<Psi>\<^sub>1) = (\<integral>\<omega>. V a \<omega> \<partial> \<Psi>\<^sub>1)" for a
     unfolding V_def of_bool_square by simp
 
   hence a:"measure_pmf.variance \<Psi>\<^sub>1 (V a) \<le> measure_pmf.expectation \<Psi>\<^sub>1 (V a)"  for a
     using \<Psi>\<^sub>1.sample_space by (subst measure_pmf.variance_eq) auto
 
   have "J \<subseteq> A \<Longrightarrow> card J = 2 \<Longrightarrow> prob_space.indep_vars \<Psi>\<^sub>1 (\<lambda>_. borel) V J" for J
     unfolding V_def using A_range finite_subset[OF _ fin_A]
     by (intro prob_space.indep_vars_compose2[where Y="\<lambda>i y. of_bool(x \<le> y)" and M'="\<lambda>_. discrete"]
         prob_space.k_wise_indep_vars_subset[OF _ \<Psi>\<^sub>1.indep]) (auto simp:prob_space_measure_pmf)
   hence "measure_pmf.variance \<Psi>\<^sub>1 (\<lambda>\<omega>. real (r x \<omega>)) = (\<Sum> a \<in> A. measure_pmf.variance \<Psi>\<^sub>1 (V a))"
     unfolding r_eq V_def using \<Psi>\<^sub>1.sample_space
-    by (intro measure_pmf.var_sum_pairwise_indep_2 fin_A) (simp_all)
+    by (intro measure_pmf.bienaymes_identity_pairwise_indep_2 fin_A) (simp_all)
   also have "... \<le> (\<Sum> a \<in> A. (\<integral>\<omega>. V a \<omega> \<partial> \<Psi>\<^sub>1))"
     by (intro sum_mono a)
   also have "... = (\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1)"
     unfolding b by simp
   finally show "measure_pmf.variance \<Psi>\<^sub>1 (\<lambda>\<omega>. real (r x \<omega>)) \<le> (\<integral>\<omega>. real (r x \<omega>) \<partial> \<Psi>\<^sub>1)" by simp
 qed
 
 definition E\<^sub>1 where "E\<^sub>1 = (\<lambda>(f,g,h). 2 powr (-t f) * X \<in> {b/2^16..b/2})"
 
 lemma t_low:
   "measure \<Psi>\<^sub>1 {f. of_int (t f) < log 2 (real X) + 1 - b_exp} \<le> 1/2^7" (is "?L \<le> ?R")
 proof (cases "log 2 (real X) \<ge> 8")
   case True
   define Z :: "(nat \<Rightarrow> nat) \<Rightarrow> real" where "Z = r (nat \<lceil>log 2 (real X) - 8\<rceil>)"
 
   have "log 2 (real X) \<le> log 2 (real n)"
     using X_le_n X_ge_1 by (intro log_mono) auto
   hence "nat \<lceil>log 2 (real X) - 8\<rceil> \<le> nat \<lceil>log 2 (real n)\<rceil>"
     by (intro nat_mono ceiling_mono) simp
   hence a:"(nat \<lceil>log 2 (real X) - 8\<rceil> \<le> max (nat \<lceil>log 2 (real n)\<rceil>) 1)"
     by simp
 
   have b:"real (nat (\<lceil>log 2 (real X)\<rceil> - 8)) \<le> log 2 (real X) - 7"
     using True by linarith
 
   have "2 ^ 7 = real X / (2 powr (log 2 X) * 2 powr (-7))"
     using X_ge_1 by simp
   also have "... = real X / (2 powr (log 2 X - 7))"
     by (subst powr_add[symmetric]) simp
   also have "... \<le> real X / (2 powr (real (nat \<lceil>log 2 (real X) - 8\<rceil>)))"
     using b by (intro divide_left_mono powr_mono) auto
   also have "... = real X / 2 ^ nat \<lceil>log 2 (real X) - 8\<rceil>"
     by (subst powr_realpow) auto
   finally have "2 ^ 7 \<le> real X / 2 ^ nat \<lceil>log 2 (real X) - 8\<rceil>"
     by simp
   hence exp_Z_gt_2_7: "(\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<ge> 2^7"
     using a unfolding Z_def r_exp by simp
 
   have var_Z_le_exp_Z: "measure_pmf.variance \<Psi>\<^sub>1 Z \<le> (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1)"
     unfolding Z_def by (intro r_var)
 
   have "?L \<le> measure \<Psi>\<^sub>1 {f. of_nat (Max (f ` A)) < log 2 (real X) - 8}"
     unfolding t_def by (intro pmf_mono) (auto simp add:int_of_nat_def)
   also have "... \<le> measure \<Psi>\<^sub>1 {f \<in> space \<Psi>\<^sub>1.  (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<le> \<bar>Z f - (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<bar>}"
   proof (rule pmf_mono)
     fix f assume "f \<in> set_pmf (sample_pmf \<Psi>\<^sub>1)"
     have fin_f_A: "finite (f ` A)" using fin_A finite_imageI by blast
     assume " f \<in> {f. real (Max (f ` A)) < log 2 (real X) - 8}"
     hence "real (Max (f ` A)) < log 2 (real X) - 8" by auto
     hence "real (f a) < log 2 (real X) - 8" if "a \<in> A" for a
       using Max_ge[OF fin_f_A] imageI[OF that]  order_less_le_trans by fastforce
     hence "of_nat (f a) < \<lceil>log 2 (real X) - 8\<rceil>" if "a \<in> A" for a
       using that by (subst less_ceiling_iff) auto
     hence "f a < nat \<lceil>log 2 (real X) - 8\<rceil>" if "a \<in> A" for a
       using that True by fastforce
     hence "r (nat \<lceil>log 2 (real X) - 8\<rceil>) f = 0"
       unfolding r_def card_eq_0_iff using not_less by auto
     hence "Z f = 0"
       unfolding Z_def by simp
     thus "f \<in> {f \<in> space \<Psi>\<^sub>1.  (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<le> \<bar>Z f - (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1)\<bar>}"
       by auto
   qed
   also have "... \<le> measure_pmf.variance \<Psi>\<^sub>1 Z / (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1)^2"
     using exp_Z_gt_2_7 \<Psi>\<^sub>1.sample_space by (intro measure_pmf.second_moment_method) simp_all
   also have "... \<le> (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) / (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1)^2"
     by (intro divide_right_mono var_Z_le_exp_Z) simp
   also have "... = 1 / (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1)"
     using exp_Z_gt_2_7 by (simp add:power2_eq_square)
   also have "... \<le> ?R"
     using exp_Z_gt_2_7 by (intro divide_left_mono) auto
   finally show ?thesis by simp
 next
   case "False"
   have "?L \<le> measure \<Psi>\<^sub>1 {f. of_nat (Max (f ` A)) < log 2 (real X) - 8}"
     unfolding t_def by (intro pmf_mono) (auto simp add:int_of_nat_def)
   also have "... \<le> measure \<Psi>\<^sub>1 {}"
     using False by (intro pmf_mono) simp
   also have "... = 0"
     by simp
   also have "... \<le> ?R" by simp
   finally show ?thesis by simp
 qed
 
 lemma t_high:
   "measure \<Psi>\<^sub>1 {f. of_int (t f) > log 2 (real X) + 16 - b_exp} \<le> 1/2^7" (is "?L \<le> ?R")
 proof -
   define Z :: "(nat \<Rightarrow> nat) \<Rightarrow> real" where "Z = r (nat \<lfloor>log 2 (real X) + 8\<rfloor>)"
 
   have Z_nonneg: "Z f \<ge> 0" for f
     unfolding Z_def r_def by simp
 
   have "(\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<le> real X / (2 ^ nat \<lfloor>log 2 (real X) + 8\<rfloor>)"
     unfolding Z_def r_exp by simp
   also have "... \<le> real X / (2 powr (real (nat \<lfloor>log 2 (real X) + 8\<rfloor>)))"
     by (subst powr_realpow) auto
   also have "... \<le> real X / (2 powr \<lfloor>log 2 (real X) + 8\<rfloor>)"
     by (intro divide_left_mono powr_mono) auto
   also have "... \<le> real X / (2 powr (log 2 (real X) + 7))"
     by (intro divide_left_mono powr_mono, linarith) auto
   also have "... = real X / 2 powr (log 2 (real X)) / 2 powr 7"
     by (subst powr_add) simp
   also have "... \<le> 1/2 powr 7"
     using X_ge_1 by (subst powr_log_cancel) auto
   finally have Z_exp: "(\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) \<le> 1/2^7"
     by simp
 
   have "?L \<le> measure \<Psi>\<^sub>1 {f. of_nat (Max (f ` A)) > log 2 (real X) + 7}"
     unfolding t_def  by (intro pmf_mono) (auto simp add:int_of_nat_def)
   also have "... \<le> measure \<Psi>\<^sub>1 {f. Z f \<ge> 1}"
   proof (rule pmf_mono)
     fix f assume "f \<in> set_pmf (sample_pmf \<Psi>\<^sub>1)"
     assume " f \<in> {f. real (Max (f ` A)) > log 2 (real X) + 7}"
     hence "real (Max (f ` A)) > log 2 (real X) + 7" by simp
     hence "int (Max (f ` A)) \<ge> \<lfloor>log 2 (real X) + 8\<rfloor>"
       by linarith
     hence "Max (f ` A) \<ge> nat \<lfloor>log 2 (real X) + 8\<rfloor>"
       by simp
     moreover have "f ` A \<noteq> {}" "finite (f ` A)"
       using fin_A finite_imageI A_nonempty by auto
     ultimately obtain fa where "fa \<in> f ` A" " fa \<ge>  nat \<lfloor>log 2 (real X) + 8\<rfloor>"
       using Max_in by auto
     then obtain ae where ae_def: "ae \<in> A" "nat \<lfloor>log 2 (real X) + 8\<rfloor> \<le> f ae"
       by auto
     hence "r (nat \<lfloor>log 2 (real X) + 8\<rfloor>) f > 0"
       unfolding r_def card_gt_0_iff using fin_A by auto
     hence "Z f \<ge> 1"
       unfolding Z_def by simp
     thus "f \<in> {f. 1 \<le> Z f}" by simp
   qed
   also have "... \<le> (\<integral>\<omega>. Z \<omega> \<partial>\<Psi>\<^sub>1) / 1"
     using Z_nonneg using \<Psi>\<^sub>1.sample_space by (intro pmf_markov) auto
   also have "... \<le> ?R"
     using Z_exp by simp
   finally show ?thesis by simp
 qed
 
 lemma e_1: "measure \<Psi> {\<psi>. \<not>E\<^sub>1 \<psi>} \<le> 1/2^6"
 proof -
   have "measure \<Psi>\<^sub>1 {f. 2 powr (of_int (-t f)) * real X \<notin> {real b/2^16..real b/2}} \<le>
     measure \<Psi>\<^sub>1 {f. 2 powr (of_int (-t f)) * real X < real b/2^16} +
     measure \<Psi>\<^sub>1 {f. 2 powr (of_int (-t f)) * real X > real b/2}"
     by (intro pmf_add) auto
   also have "... \<le> measure \<Psi>\<^sub>1 {f. of_int (t f) > log 2 X + 16 - b_exp} +
                    measure \<Psi>\<^sub>1 {f. of_int (t f) < log 2 X + 1 - b_exp}"
   proof (rule add_mono)
     show "measure \<Psi>\<^sub>1 {f. 2 powr (of_int (-t f)) * real X < real b/2^16} \<le>
     measure \<Psi>\<^sub>1 {f. of_int (t f) > log 2 X + 16 - b_exp}"
     proof (rule pmf_mono)
       fix f assume "f \<in> {f. 2 powr real_of_int (-t f) * real X < real b / 2 ^ 16}"
       hence "2 powr real_of_int (-t f) * real X < real b / 2 ^ 16"
         by simp
       hence "log 2 (2 powr of_int (-t f) * real X) < log 2 (real b / 2^16)"
         using b_min X_ge_1 by (intro iffD2[OF log_less_cancel_iff]) auto
       hence "of_int (-t f) + log  2 (real X) < log 2 (real b / 2^16)"
         using X_ge_1 by (subst (asm) log_mult) auto
       also have  "... = real b_exp - log 2 (2 powr 16)"
         unfolding b_def by (subst log_divide) auto
       also have "... = real b_exp - 16"
         by (subst log_powr_cancel) auto
       finally have "of_int (-t f) + log 2 (real X) < real b_exp - 16" by simp
       thus "f \<in> {f. of_int (t f) > log 2 (real X) + 16 - b_exp}"
         by simp
     qed
   next
     show "measure \<Psi>\<^sub>1 {f. 2 powr of_int (-t f) * real X > real b/2} \<le>
       measure \<Psi>\<^sub>1 {f. of_int (t f) < log 2 X + 1 - b_exp}"
     proof (rule pmf_mono)
       fix f assume "f \<in> {f. 2 powr real_of_int (-t f) * real X > real b / 2}"
       hence "2 powr real_of_int (-t f) * real X > real b / 2"
         by simp
       hence "log 2 (2 powr of_int (-t f) * real X) > log 2 (real b / 2)"
         using b_min X_ge_1 by (intro iffD2[OF log_less_cancel_iff]) auto
       hence "of_int (-t f) + log  2 (real X) > log 2 (real b / 2)"
         using X_ge_1 by (subst (asm) log_mult) auto
       hence  "of_int (-t f) + log  2 (real X) > real b_exp - 1"
         unfolding b_def by (subst (asm) log_divide) auto
       hence "of_int (t f) < log 2 (real X) + 1 - b_exp"
         by simp
       thus "f \<in> {f. of_int (t f) < log 2 (real X) + 1 - b_exp}"
         by simp
     qed
   qed
   also have "... \<le> 1/2^7 + 1/2^7"
     by (intro add_mono t_low t_high)
   also have "... = 1/2^6" by simp
   finally have "measure \<Psi>\<^sub>1 {f. 2 powr of_int (-t f) * real X \<notin> {real b/2^16..real b/2}} \<le> 1/2^6"
     by simp
 
   thus ?thesis
     unfolding sample_pmf_\<Psi> E\<^sub>1_def case_prod_beta
     by (subst pair_pmf_prob_left)
 qed
 
 definition E\<^sub>2 where "E\<^sub>2 = (\<lambda>(f,g,h). \<bar>card (R f) - X / 2^(s f)\<bar> \<le> \<epsilon>/3 * X / 2^(s f))"
 
 lemma e_2: "measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> \<not>E\<^sub>2 \<psi>} \<le> 1/2^6" (is "?L \<le> ?R")
 proof -
   define t\<^sub>m :: int where "t\<^sub>m = \<lfloor>log 2 (real X)\<rfloor> + 16 - b_exp"
 
   have t_m_bound: "t\<^sub>m \<le> \<lfloor>log 2 (real X)\<rfloor> - 10"
     unfolding t\<^sub>m_def using b_exp_ge_26 by simp
 
   have "real b / 2^16 = (real X * (1/ X)) * (real b / 2^16)"
     using X_ge_1 by simp
   also have "... = (real X * 2 powr (-log 2 X)) * (real b / 2^16)"
     using X_ge_1 by (subst powr_minus_divide) simp
   also have "... \<le> (real X * 2 powr (- \<lfloor>log 2 (real X)\<rfloor>)) * (2 powr b_exp / 2^16)"
     unfolding b_def using powr_realpow
     by (intro mult_mono powr_mono) auto
   also have "... = real X * (2 powr (- \<lfloor>log 2 (real X)\<rfloor>) * 2 powr(real b_exp-16))"
     by (subst powr_diff) simp
   also have "... = real X * 2 powr (- \<lfloor>log 2 (real X)\<rfloor> + (int b_exp - 16))"
     by (subst powr_add[symmetric]) simp
   also have "... = real X * 2 powr (-t\<^sub>m)"
     unfolding t\<^sub>m_def by (simp add:algebra_simps)
   finally have c:"real b / 2^16 \<le> real X * 2 powr (-t\<^sub>m)" by simp
 
   define T :: "nat set" where "T = {x. (real X / 2^x \<ge> real b / 2^16)}"
 
   have "x \<in> T \<longleftrightarrow> int x \<le> t\<^sub>m" for x
   proof -
     have "x \<in> T \<longleftrightarrow> 2^ x \<le> real X * 2^16 / b"
       using b_min by (simp add: field_simps T_def)
     also have "... \<longleftrightarrow> log 2 (2^x) \<le> log 2 (real X * 2^16 / b)"
       using X_ge_1 b_min by (intro log_le_cancel_iff[symmetric] divide_pos_pos) auto
     also have "... \<longleftrightarrow> x \<le> log 2 (real X * 2^16) - log 2 b"
       using X_ge_1 b_min by (subst log_divide) auto
     also have "... \<longleftrightarrow> x \<le> log 2 (real X) + log 2 (2 powr 16) - b_exp"
       unfolding b_def using X_ge_1 by (subst log_mult) auto
     also have "... \<longleftrightarrow> x \<le> \<lfloor>log 2 (real X) + log 2 (2 powr 16) - b_exp\<rfloor>"
       by linarith
     also have "... \<longleftrightarrow> x \<le> \<lfloor>log 2 (real X) + 16 - real_of_int (int b_exp)\<rfloor>"
       by (subst log_powr_cancel) auto
     also have "... \<longleftrightarrow> x \<le> t\<^sub>m"
       unfolding t\<^sub>m_def by linarith
     finally show ?thesis by simp
   qed
   hence T_eq: "T = {x. int x \<le> t\<^sub>m}" by auto
 
   have "T = {x. int x < t\<^sub>m+1}"
     unfolding T_eq by simp
   also have "... = {x. x < nat (t\<^sub>m + 1)}"
     unfolding zless_nat_eq_int_zless by simp
   finally have T_eq_2: "T = {x. x < nat (t\<^sub>m + 1)}"
     by simp
 
   have inj_1: "inj_on ((-) (nat t\<^sub>m)) T"
     unfolding T_eq by (intro inj_onI) simp
   have fin_T: "finite T"
     unfolding T_eq_2 by simp
 
   have r_exp: "(\<integral>\<omega>. real (r t \<omega>) \<partial>\<Psi>\<^sub>1) = real X / 2^t" if "t \<in> T" for t
   proof -
     have "t \<le> t\<^sub>m"
       using that unfolding T_eq by simp
     also have "... \<le> \<lfloor>log 2 (real X)\<rfloor> - 10"
       using t_m_bound by simp
     also have "... \<le> \<lfloor>log 2 (real X)\<rfloor>"
       by simp
     also have "... \<le> \<lfloor>log 2 (real n)\<rfloor>"
       using X_le_n X_ge_1 by (intro floor_mono log_mono) auto
     also have "... \<le> \<lceil>log 2 (real n)\<rceil>"
       by simp
     finally have "t \<le> \<lceil>log 2 (real n)\<rceil>" by simp
     hence "t \<le> max (nat \<lceil>log 2 (real n)\<rceil>) 1"by simp
     thus ?thesis
       unfolding r_exp by simp
   qed
 
   have r_var: "measure_pmf.variance \<Psi>\<^sub>1 (\<lambda>\<omega>. real (r t \<omega>)) \<le> real X / 2^t" if "t \<in> T" for t
     using r_exp[OF that] r_var by metis
 
   have "9 = C\<^sub>4 / \<epsilon>\<^sup>2 * \<epsilon>^2/2^23"
     using \<epsilon>_gt_0 by (simp add:C\<^sub>4_def)
   also have "... = 2 powr (log 2 (C\<^sub>4 /  \<epsilon>\<^sup>2)) *  \<epsilon>^2/2^23"
     using \<epsilon>_gt_0 C\<^sub>4_def by (subst powr_log_cancel) auto
   also have "... \<le> 2 powr b_exp * \<epsilon>^2/2^23"
     unfolding b_exp_def
     by (intro divide_right_mono mult_right_mono powr_mono, linarith) auto
   also have "... = b * \<epsilon>^2/2^23"
     using powr_realpow unfolding b_def by simp
   also have "... = (b/2^16) * (\<epsilon>^2/2^7)"
     by simp
   also have "... \<le> (X * 2 powr (-t\<^sub>m)) * (\<epsilon>^2/2^7)"
     by (intro mult_mono c) auto
   also have "... = X * (2 powr (-t\<^sub>m) * 2 powr (-7)) * \<epsilon>^2"
     using powr_realpow by simp
   also have "... = 2 powr (-t\<^sub>m-7) * (\<epsilon>^2 * X)"
     by (subst powr_add[symmetric]) (simp )
   finally have "9 \<le> 2 powr (-t\<^sub>m-7) * (\<epsilon>^2 * X)" by simp
   hence b: "9/ (\<epsilon>^2 * X) \<le> 2 powr (-t\<^sub>m -7)"
     using \<epsilon>_gt_0 X_ge_1
     by (subst pos_divide_le_eq) auto
 
   have a: "measure \<Psi>\<^sub>1 {f.\<bar>real (r t f)-real X/2^t\<bar>> \<epsilon>/3 *real X/2^t} \<le> 2 powr (real t-t\<^sub>m-7)"
     (is"?L1 \<le> ?R1") if "t \<in> T" for t
   proof -
     have "?L1 \<le> \<P>(f in \<Psi>\<^sub>1. \<bar>real (r t f) - real X / 2^t\<bar> \<ge>  \<epsilon>/3 * real X / 2^t)"
       by (intro pmf_mono) auto
     also have "... = \<P>(f in \<Psi>\<^sub>1. \<bar>real (r t f)-(\<integral>\<omega>. real (r t \<omega>) \<partial> \<Psi>\<^sub>1)\<bar> \<ge> \<epsilon>/3 * real X/2^t)"
       by (simp add: r_exp[OF that])
     also have "... \<le> measure_pmf.variance \<Psi>\<^sub>1 (\<lambda>\<omega>. real (r t \<omega>)) / (\<epsilon>/3 * real X / 2^t)^2"
       using X_ge_1 \<epsilon>_gt_0 \<Psi>\<^sub>1.sample_space
       by (intro measure_pmf.Chebyshev_inequality divide_pos_pos mult_pos_pos) auto
     also have "... \<le> (X / 2^t) / (\<epsilon>/3 * X / 2^t)^2"
       by (intro divide_right_mono r_var[OF that]) simp
     also have "... = 2^t*(9/ ( \<epsilon>^2 * X))"
       by (simp add:power2_eq_square algebra_simps)
     also have "... \<le> 2^t*(2 powr (-t\<^sub>m-7))"
       by (intro mult_left_mono b) simp
     also have "... = 2 powr t * 2 powr (-t\<^sub>m-7)"
       by (subst powr_realpow[symmetric]) auto
     also have "... = ?R1"
       by (subst powr_add[symmetric]) (simp add:algebra_simps)
     finally show "?L1 \<le> ?R1" by simp
   qed
 
   have "\<exists>y<nat (t\<^sub>m + 1). x = nat t\<^sub>m - y" if "x < nat (t\<^sub>m+1)" for x
     using that by (intro exI[where x="nat t\<^sub>m - x"]) simp
   hence T_reindex: "(-) (nat t\<^sub>m) ` {x. x < nat (t\<^sub>m + 1)} = {..<nat (t\<^sub>m + 1)}"
     by (auto simp add: set_eq_iff image_iff)
 
   have "?L \<le> measure \<Psi> {\<psi>. (\<exists>t \<in> T. \<bar>real (r t (fst \<psi>))-real X/2^t\<bar> > \<epsilon>/3 * real X / 2^t)}"
   proof (rule pmf_mono)
     fix \<psi>
     assume "\<psi> \<in> set_pmf (sample_pmf \<Psi>)"
     obtain f g h where \<psi>_def: "\<psi> = (f,g,h)" by (metis prod_cases3)
     assume "\<psi> \<in> {\<psi>. E\<^sub>1 \<psi> \<and> \<not> E\<^sub>2 \<psi>}"
     hence a:"2 powr ( -real_of_int (t f)) * real X \<in> {real b/2^16..real b/2}" and
       b:"\<bar>card (R f) - real X / 2^(s f)\<bar> >  \<epsilon>/3 * X / 2^(s f)"
       unfolding E\<^sub>1_def E\<^sub>2_def by (auto simp add:\<psi>_def)
     have "\<bar>card (R f) - X / 2^(s f)\<bar> = 0" if "s f= 0"
       using that by (simp add:R_def X_def)
     moreover have "( \<epsilon>/3) * (X / 2^s f) \<ge> 0"
       using \<epsilon>_gt_0 X_ge_1 by (intro mult_nonneg_nonneg) auto
     ultimately have "False" if "s f = 0"
       using b that by simp
     hence "s f > 0" by auto
     hence "t f = s f" unfolding s_def by simp
     hence "2 powr (-real (s f)) * X \<ge> b / 2^16"
       using a by simp
     hence "X / 2 powr (real (s f)) \<ge> b / 2^16"
       by (simp add: divide_powr_uminus mult.commute)
     hence "real X / 2 ^ (s f) \<ge> b / 2^16"
       by (subst (asm) powr_realpow, auto)
     hence "s f \<in> T" unfolding T_def by simp
     moreover have "\<bar>r (s f) f - X / 2^s f\<bar> >  \<epsilon>/3 * X / 2^s f"
       using R_def r_def b by simp
     ultimately have "\<exists>t \<in> T. \<bar>r t (fst \<psi>) - X / 2^t\<bar> >  \<epsilon>/3 * X / 2^t"
       using \<psi>_def by (intro bexI[where x="s f"]) simp
     thus "\<psi> \<in> {\<psi>. (\<exists>t \<in> T. \<bar>r t (fst \<psi>) - X / 2^t\<bar> >  \<epsilon>/3 * X / 2^t)}" by simp
   qed
   also have "... = measure \<Psi>\<^sub>1 {f. (\<exists>t \<in> T. \<bar>real (r t f)-real X / 2^t\<bar> > \<epsilon>/3 * real X/2^t)}"
     unfolding sample_pmf_\<Psi> by (intro pair_pmf_prob_left)
   also have "... = measure \<Psi>\<^sub>1 (\<Union>t \<in> T. {f. \<bar>real (r t f)-real X / 2^t\<bar> > \<epsilon>/3 * real X/2^t})"
     by (intro measure_pmf_cong) auto
   also have "... \<le> (\<Sum>t \<in> T. measure \<Psi>\<^sub>1 {f.\<bar>real (r t f)-real X / 2^t\<bar> > \<epsilon>/3 * real X/2^t})"
     by (intro measure_UNION_le fin_T) (simp)
   also have "... \<le> (\<Sum>t \<in> T.  2 powr (real t - of_int t\<^sub>m - 7))"
     by (intro sum_mono a)
   also have "... = (\<Sum>t \<in> T.  2 powr (-int (nat t\<^sub>m-t) - 7))"
     unfolding T_eq
     by (intro sum.cong refl arg_cong2[where f="(powr)"]) simp
   also have "... = (\<Sum>x \<in> (\<lambda>x. nat t\<^sub>m - x) ` T. 2 powr (-real x - 7))"
     by (subst sum.reindex[OF inj_1]) simp
   also have "... = (\<Sum>x \<in> (\<lambda>x. nat t\<^sub>m - x) ` T. 2 powr (-7) * 2 powr (-real x))"
     by (subst powr_add[symmetric]) (simp add:algebra_simps)
   also have "... = 1/2^7 * (\<Sum>x \<in> (\<lambda>x. nat t\<^sub>m - x) ` T. 2 powr (-real x))"
     by (subst sum_distrib_left) simp
   also have "... = 1/2^7 * (\<Sum>x <nat (t\<^sub>m+1). 2 powr (-real x))"
     unfolding T_eq_2 T_reindex
     by (intro arg_cong2[where f="(*)"] sum.cong) auto
   also have "... = 1/2^7 * (\<Sum>x <nat (t\<^sub>m+1). (2 powr (-1)) powr (real x))"
     by (subst powr_powr) simp
   also have "... = 1/2^7 * (\<Sum>x <nat (t\<^sub>m+1). (1/2)^x)"
     using powr_realpow by simp
   also have "... \<le> 1/2^7 * 2"
     by(subst geometric_sum) auto
   also have "... = 1/2^6" by simp
   finally show ?thesis by simp
 qed
 
 definition E\<^sub>3 where "E\<^sub>3 = (\<lambda>(f,g,h). inj_on g (R f))"
 
 lemma R_bound:
   fixes f g h
   assumes "E\<^sub>1 (f,g,h)"
   assumes "E\<^sub>2 (f,g,h)"
   shows "card (R f) \<le> 2/3 * b"
 proof -
   have "real (card (R f)) \<le> ( \<epsilon> / 3) * (real X / 2 ^ s f) + real X / 2 ^ s f"
     using assms(2) unfolding E\<^sub>2_def by simp
   also have "... \<le> (1/3) * (real X / 2 ^ s f) + real X / 2 ^ s f"
     using \<epsilon>_lt_1 by (intro add_mono mult_right_mono) auto
   also have "... = (4/3) * (real X / 2 powr s f)"
     using powr_realpow by simp
   also have "... \<le> (4/3) * (real X / 2 powr t f)"
     unfolding s_def
     by (intro mult_left_mono divide_left_mono powr_mono) auto
   also have "... = (4/3) * (2 powr (-(of_int (t f))) * real X)"
     by (subst powr_minus_divide) simp
   also have "... = (4/3) * (2 powr (- t f) * real X)"
     by simp
   also have "... \<le> (4/3) * (b/2)"
     using assms(1) unfolding E\<^sub>1_def
     by (intro mult_left_mono) auto
   also have "... \<le> (2/3) * b" by simp
   finally show ?thesis by simp
 qed
 
 lemma e_3: "measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> E\<^sub>2 \<psi> \<and> \<not>E\<^sub>3 \<psi>} \<le> 1/2^6" (is "?L \<le> ?R")
 proof -
   let ?\<alpha> = "(\<lambda>(z,x,y) f. z < C\<^sub>7*b^2 \<and> x \<in> R f \<and> y \<in> R f \<and> x < y)"
   let ?\<beta> = "(\<lambda>(z,x,y) g. g x = z \<and> g y = z)"
 
   have \<beta>_prob: "measure \<Psi>\<^sub>2 {g. ?\<beta> \<omega> g} \<le> (1/real (C\<^sub>7*b^2)^2)"
     if "?\<alpha> \<omega> f" for \<omega> f
   proof -
     obtain x y z where \<omega>_def: "\<omega> = (z,x,y)" by (metis prod_cases3)
     have a:"prob_space.k_wise_indep_vars \<Psi>\<^sub>2 2 (\<lambda>i. discrete) (\<lambda>x \<omega>. \<omega> x = z) {..<n}"
       by (intro prob_space.k_wise_indep_vars_compose[OF _ \<Psi>\<^sub>2.indep])
        (simp_all add:prob_space_measure_pmf)
 
     have "u \<in> R f \<Longrightarrow> u < n" for u
       unfolding R_def using A_range by auto
     hence b: "x < n" "y < n" "card {x, y} = 2"
       using that \<omega>_def by auto
     have c: "z < C\<^sub>7*b\<^sup>2" using \<omega>_def that by simp
 
     have "measure \<Psi>\<^sub>2 {g. ?\<beta> \<omega> g} = measure \<Psi>\<^sub>2 {g. (\<forall>\<xi> \<in> {x,y}. g \<xi> = z)}"
       by (simp add:\<omega>_def)
     also have "... = (\<Prod>\<xi> \<in> {x,y}. measure \<Psi>\<^sub>2 {g. g \<xi> = z})"
       using b by (intro measure_pmf.split_indep_events[OF refl, where I="{x,y}"]
           prob_space.k_wise_indep_vars_subset[OF _ a]) (simp_all add:prob_space_measure_pmf)
     also have "... = (\<Prod>\<xi> \<in> {x,y}. measure (map_pmf (\<lambda>\<omega>. \<omega> \<xi>) (sample_pmf \<Psi>\<^sub>2)) {g. g = z}) "
       by (simp add:vimage_def)
     also have "... = (\<Prod>\<xi> \<in> {x,y}. measure [C\<^sub>7 * b\<^sup>2]\<^sub>S {g. g=z})"
       using b \<Psi>\<^sub>2.single by (intro prod.cong) fastforce+
     also have "... = (\<Prod>\<xi> \<in> {x,y}. measure (pmf_of_set {..<C\<^sub>7 * b\<^sup>2}) {z})"
       by (subst nat_sample_pmf) simp
     also have "... = (measure (pmf_of_set {..<C\<^sub>7 * b\<^sup>2}) {z})^2"
       using b by simp
     also have "... \<le> (1 /(C\<^sub>7*b\<^sup>2))^2"
       using c by (subst measure_pmf_of_set) auto
     also have "... = (1 /(C\<^sub>7*b\<^sup>2)^2)"
       by (simp add:algebra_simps power2_eq_square)
     finally show ?thesis by simp
   qed
 
   have \<alpha>_card: "card {\<omega>. ?\<alpha> \<omega> f} \<le> (C\<^sub>7*b^2) * (card (R f) * (card (R f)-1)/2)"
     (is "?TL \<le> ?TR") and fin_\<alpha>: "finite {\<omega>. ?\<alpha> \<omega> f}" (is "?T2") for f
   proof -
     have t1: "{\<omega>. ?\<alpha> \<omega> f} \<subseteq> {..<C\<^sub>7*b^2} \<times> {(x,y) \<in> R f \<times> R f. x < y}"
       by (intro subsetI) auto
     moreover have "card ({..<C\<^sub>7*b^2} \<times> {(x,y) \<in> R f \<times> R f. x < y}) = ?TR"
       using  card_ordered_pairs'[where M="R f"]
       by (simp add: card_cartesian_product)
     moreover have "finite (R f)"
       unfolding R_def using fin_A finite_subset by simp
     hence "finite {(x, y). (x, y) \<in> R f \<times> R f \<and> x < y}"
       by (intro finite_subset[where B="R f \<times> R f", OF _ finite_cartesian_product]) auto
     hence t2: "finite ({..<C\<^sub>7*b^2} \<times> {(x,y) \<in> R f \<times> R f. x < y})"
       by (intro finite_cartesian_product) auto
     ultimately show "?TL \<le> ?TR"
       using card_mono of_nat_le_iff by (metis (no_types, lifting))
     show ?T2
       using finite_subset[OF t1 t2] by simp
   qed
 
   have "?L \<le> measure \<Psi> {(f,g,h). card (R f) \<le> b \<and> (\<exists> x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) g)}"
   proof (rule pmf_mono)
     fix \<psi> assume b:"\<psi> \<in> set_pmf (sample_pmf \<Psi>)"
     obtain f g h where \<psi>_def:"\<psi> = (f,g,h)" by (metis prod_cases3)
     have "(f,g,h) \<in> sample_set \<Psi>"
       using sample_space_alt[OF sample_space_\<Psi>] b \<psi>_def by simp
     hence c:"g x < C\<^sub>7*b^2" for x
       using g_range by simp
 
     assume a:"\<psi> \<in> {\<psi>. E\<^sub>1 \<psi> \<and> E\<^sub>2 \<psi> \<and> \<not> E\<^sub>3 \<psi>}"
     hence "card (R f) \<le> 2/3 * b"
       using R_bound \<psi>_def by force
     moreover have "\<exists>a b. a \<in> R f \<and> b \<in> R f \<and> a \<noteq> b \<and> g a = g b"
       using a unfolding \<psi>_def E\<^sub>3_def inj_on_def by auto
     hence "\<exists>x y. x \<in> R f \<and> y \<in> R f \<and> x < y \<and> g x = g y"
       by (metis not_less_iff_gr_or_eq)
     hence "\<exists>x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) g"
       using c by blast
     ultimately show "\<psi> \<in> {(f, g, h). card (R f) \<le> b \<and> (\<exists> x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) g)}"
       unfolding \<psi>_def by auto
   qed
   also have "... = (\<integral>f. measure (pair_pmf \<Psi>\<^sub>2 \<Psi>\<^sub>3)
      {g. card (R f) \<le> b \<and> (\<exists>x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) (fst g))} \<partial>\<Psi>\<^sub>1)"
     unfolding sample_pmf_\<Psi> split_pair_pmf by (simp add: case_prod_beta)
   also have
     "... = (\<integral>f. measure \<Psi>\<^sub>2 {g. card (R f) \<le> b \<and> (\<exists>x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) g)} \<partial>\<Psi>\<^sub>1)"
     by (subst pair_pmf_prob_left) simp
   also have "... \<le> (\<integral>f. 1/real (2*C\<^sub>7) \<partial>\<Psi>\<^sub>1)"
   proof (rule pmf_exp_mono[OF integrable_sample_pmf[OF \<Psi>\<^sub>1.sample_space]
           integrable_sample_pmf[OF \<Psi>\<^sub>1.sample_space]])
     fix f assume "f \<in> set_pmf (sample_pmf \<Psi>\<^sub>1)"
     show "measure \<Psi>\<^sub>2 {g. card (R f) \<le> b \<and> (\<exists>x y z. ?\<alpha> (x,y,z) f \<and> ?\<beta> (x,y,z) g)} \<le> 1 / real (2 * C\<^sub>7)"
       (is "?L1 \<le> ?R1")
     proof (cases "card (R f) \<le> b")
       case True
       have "?L1 \<le> measure \<Psi>\<^sub>2 (\<Union> \<omega> \<in> {\<omega>. ?\<alpha> \<omega> f}. {g. ?\<beta> \<omega> g})"
         by (intro pmf_mono) auto
       also have "... \<le> (\<Sum>\<omega> \<in> {\<omega>. ?\<alpha> \<omega> f}. measure \<Psi>\<^sub>2 {g. ?\<beta> \<omega> g})"
         by (intro measure_UNION_le fin_\<alpha>) auto
       also have "... \<le> (\<Sum>\<omega> \<in> {\<omega>. ?\<alpha> \<omega> f}. (1/real (C\<^sub>7*b^2)^2))"
         by (intro sum_mono \<beta>_prob) auto
       also have "... = card {\<omega>. ?\<alpha> \<omega> f} /(C\<^sub>7*b^2)^2"
         by simp
       also have "... \<le> (C\<^sub>7*b^2) * (card (R f) * (card (R f)-1)/2) / (C\<^sub>7*b^2)^2"
         by (intro \<alpha>_card divide_right_mono) simp
       also have "... \<le> (C\<^sub>7*b^2) * (b * b / 2)  / (C\<^sub>7*b^2)^2"
         unfolding C\<^sub>7_def using True
         by (intro divide_right_mono Nat.of_nat_mono mult_mono) auto
       also have "... = 1/(2*C\<^sub>7)"
         using b_min by (simp add:algebra_simps power2_eq_square)
       finally show ?thesis by simp
     next
       case False
       then show ?thesis by simp
     qed
   qed
   also have "... \<le> 1/2^6"
     unfolding C\<^sub>7_def by simp
   finally show ?thesis by simp
 qed
 
 definition E\<^sub>4 where "E\<^sub>4 = (\<lambda>(f,g,h). \<bar>p (f,g,h) - \<rho> (card (R f))\<bar> \<le>  \<epsilon>/12 * card (R f))"
 
 lemma e_4_h: "9 / sqrt b \<le> \<epsilon> / 12"
 proof -
   have "108 \<le> sqrt (C\<^sub>4)"
     unfolding C\<^sub>4_def by (approximation 5)
   also have "... \<le> sqrt( \<epsilon>^2 * real b)"
     using b_lower_bound \<epsilon>_gt_0
     by (intro real_sqrt_le_mono) (simp add: pos_divide_le_eq algebra_simps)
   also have "... =  \<epsilon> * sqrt b"
     using \<epsilon>_gt_0 by (simp add:real_sqrt_mult)
   finally have "108 \<le>  \<epsilon> * sqrt b"  by simp
   thus ?thesis
     using b_min by (simp add:pos_divide_le_eq)
 qed
 
 lemma e_4: "measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> E\<^sub>2 \<psi> \<and> E\<^sub>3 \<psi> \<and> \<not>E\<^sub>4 \<psi>} \<le> 1/2^6" (is "?L \<le> ?R")
 proof -
   have a: "measure \<Psi>\<^sub>3 {h. E\<^sub>1 (f,g,h) \<and> E\<^sub>2 (f,g,h) \<and> E\<^sub>3 (f,g,h) \<and> \<not>E\<^sub>4 (f,g,h)} \<le> 1/2^6"
     (is "?L1 \<le> ?R1") if "f \<in> set_pmf (sample_pmf \<Psi>\<^sub>1)" "g \<in> set_pmf(sample_pmf \<Psi>\<^sub>2)"
     for f g
   proof (cases "card (R f) \<le> b \<and> inj_on g (R f)")
     case True
 
     have g_inj: "inj_on g (R f)"
       using True by simp
 
     have fin_R: "finite (g ` R f)"
       unfolding R_def using fin_A
       by (intro finite_imageI) simp
 
     interpret B:balls_and_bins_abs "g ` R f" "{..<b}"
       using fin_R b_ne by unfold_locales auto
 
     have "range g \<subseteq> {..<C\<^sub>7 * b\<^sup>2}"
       using g_range_1 that(2) unfolding sample_space_alt[OF \<Psi>\<^sub>2.sample_space] by auto
     hence g_ran: "g ` R f \<subseteq> {..<C\<^sub>7 * b\<^sup>2}"
       by auto
 
     have "sample_pmf [b]\<^sub>S = pmf_of_set {..<b}"
       unfolding sample_pmf_def nat_sample_space_def by simp
     hence " map_pmf (\<lambda>\<omega>. \<omega> x) (sample_pmf (\<H> k (C\<^sub>7 * b\<^sup>2) [b]\<^sub>S)) = pmf_of_set {..<b}"
       if "x \<in> g ` R f" for x
       using g_ran \<Psi>\<^sub>3.single that by auto
     moreover have "prob_space.k_wise_indep_vars \<Psi>\<^sub>3 k (\<lambda>_. discrete) (\<lambda>x \<omega>. \<omega> x) (g ` R f)"
       by (intro prob_space.k_wise_indep_subset[OF _ _ \<Psi>\<^sub>3.indep] g_ran prob_space_measure_pmf)
     ultimately have lim_balls_and_bins: "B.lim_balls_and_bins k (sample_pmf (\<H> k (C\<^sub>7 * b\<^sup>2) [b]\<^sub>S))"
       unfolding B.lim_balls_and_bins_def by auto
 
     have card_g_R: "card (g ` R f) = card (R f)"
       using True card_image by auto
     hence b_mu: "\<rho> (card (R f)) = B.\<mu>"
       unfolding B.\<mu>_def \<rho>_def using b_min by (simp add:powr_realpow)
 
     have card_g_le_b: "card (g ` R f) \<le> card {..<b}"
       unfolding card_g_R using True by simp
 
     have "?L1 \<le> measure \<Psi>\<^sub>3 {h. \<bar>B.Y h - B.\<mu>\<bar> > 9 * real (card (g ` R f)) / sqrt (card {..<b})}"
     proof (rule pmf_mono)
       fix h assume "h \<in> {h. E\<^sub>1 (f,g,h) \<and> E\<^sub>2 (f,g,h) \<and> E\<^sub>3 (f,g,h) \<and> \<not>E\<^sub>4 (f,g,h)}"
       hence b: "\<bar>p (f,g,h) -\<rho> (card (R f))\<bar> >  \<epsilon>/12 * card (R f)"
         unfolding E\<^sub>4_def by simp
       assume "h \<in> set_pmf (sample_pmf \<Psi>\<^sub>3)"
       hence h_range: "h x < b" for x
         unfolding sample_space_alt[OF \<Psi>\<^sub>3.sample_space,symmetric] using h_range_1 by simp
 
       have "{j \<in> {..<b}. int (s f) \<le> \<tau>\<^sub>1 (f, g, h) A 0 j} =
         {j \<in> {..<b}. int (s f) \<le> max (Max ({int (f a) |a. a \<in> A \<and> h (g a) = j} \<union> {-1})) (- 1)}"
         unfolding \<tau>\<^sub>1_def by simp
       also have "... = {j \<in> {..<b}. int (s f) \<le> Max ({int (f a) |a. a \<in> A \<and> h (g a) = j} \<union> {-1})}"
         using fin_A by (subst max_absorb1) (auto intro: Max_ge)
       also have "... = {j \<in> {..<b}. (\<exists>a \<in> R f. h (g a) = j)}"
         unfolding R_def using fin_A by (subst Max_ge_iff) auto
       also have "... = {j. \<exists>a \<in> R f. h (g a) = j}"
         using h_range by auto
       also have "... = (h \<circ> g) ` (R f)"
         by (auto simp add:set_eq_iff image_iff)
       also have "... = h ` (g ` (R f))"
         by (simp add:image_image)
       finally have c:"{j \<in> {..<b}. int (s f) \<le> \<tau>\<^sub>1 (f, g, h) A 0 j} = h ` (g ` R f)"
         by simp
       have "9 * real (card (g ` R f)) / sqrt (card {..<b}) = 9/ sqrt b * real (card (R f))"
         using card_image[OF g_inj] by simp
       also have "... \<le>  \<epsilon>/12 * card (R f)"
         by (intro mult_right_mono e_4_h) simp
       also have "... < \<bar>B.Y h - B.\<mu>\<bar>"
         using b c unfolding B.Y_def p_def b_mu by simp
       finally show "h \<in> {h. \<bar>B.Y h - B.\<mu>\<bar> >  9 * real (card (g ` R f)) / sqrt (card {..<b})}"
         by simp
     qed
     also have "... \<le> 1/2^6"
       using k_min
       by (intro B.devitation_bound[OF card_g_le_b lim_balls_and_bins]) auto
     finally show ?thesis by simp
   next
     case False
     have "?L1 \<le> measure \<Psi>\<^sub>3 {}"
     proof (rule pmf_mono)
       fix h assume b:"h \<in> {h. E\<^sub>1 (f, g, h) \<and> E\<^sub>2 (f, g, h) \<and> E\<^sub>3 (f, g, h) \<and> \<not> E\<^sub>4 (f, g, h)}"
       hence "card (R f) \<le> (2/3)*b"
         by (auto intro!: R_bound[simplified])
       hence "card (R f) \<le> b"
         by simp
       moreover have "inj_on g (R f)"
         using b by (simp add:E\<^sub>3_def)
       ultimately have "False" using False by simp
       thus "h \<in> {}" by simp
     qed
     also have "... = 0" by simp
     finally show ?thesis by simp
   qed
 
   have "?L = (\<integral>f. (\<integral>g.
     measure \<Psi>\<^sub>3 {h. E\<^sub>1 (f,g,h) \<and> E\<^sub>2 (f,g,h) \<and> E\<^sub>3 (f,g,h) \<and> \<not>E\<^sub>4 (f,g,h)} \<partial>\<Psi>\<^sub>2) \<partial>\<Psi>\<^sub>1)"
     unfolding sample_pmf_\<Psi> split_pair_pmf by simp
   also have "... \<le> (\<integral>f. (\<integral>g.  1/2^6  \<partial>\<Psi>\<^sub>2) \<partial>\<Psi>\<^sub>1)"
     using a \<Psi>\<^sub>1.sample_space \<Psi>\<^sub>2.sample_space
     by (intro integral_mono_AE AE_pmfI) simp_all
   also have "... = 1/2^6"
     by simp
   finally show ?thesis by simp
 qed
 
 lemma \<rho>_inverse: "\<rho>_inv (\<rho> x) = x"
 proof -
   have a:"1-1/b \<noteq> 0"
     using b_min by simp
 
   have "\<rho> x = b * (1-(1-1/b) powr x)"
     unfolding \<rho>_def by simp
   hence "\<rho> x / real b = 1-(1-1/b) powr x" by simp
   hence "ln (1 - \<rho> x / real b) = ln ((1-1/b) powr x)" by simp
   also have "... = x * ln (1 - 1/ b)"
     using a by (intro ln_powr)
   finally have "ln (1 - \<rho> x / real b) = x * ln (1- 1/ b)"
     by simp
   moreover have "ln (1-1/b) < 0"
     using b_min by (subst ln_less_zero_iff) auto
   ultimately show ?thesis
     using \<rho>_inv_def by simp
 qed
 
 lemma rho_mono:
   assumes "x \<le> y"
   shows "\<rho> x \<le> \<rho> y"
 proof-
   have "(1 - 1 / real b) powr y \<le> (1 - 1 / real b) powr x"
     using b_min
     by (intro powr_mono_rev assms) auto
   thus ?thesis
     unfolding \<rho>_def by (intro mult_left_mono) auto
 qed
 
 lemma rho_two_thirds: "\<rho> (2/3 * b) \<le> 3/5 *b"
 proof -
   have "1/3 \<le> exp ( - 13 / 12::real )"
     by (approximation 8)
   also have "... \<le> exp ( - 1 - 2 / real b )"
     using b_min by (intro iffD2[OF exp_le_cancel_iff]) (simp add:algebra_simps)
   also have "... \<le> exp ( b * (-(1/real b)-2*(1/real b)^2))"
     using b_min by (simp add:algebra_simps power2_eq_square)
   also have  "... \<le> exp ( b * ln (1-1/real b))"
     using b_min
     by (intro iffD2[OF exp_le_cancel_iff] mult_left_mono ln_one_minus_pos_lower_bound) auto
   also have "... = exp ( ln ( (1-1/real b) powr b))"
     using b_min by (subst ln_powr) auto
   also have "... = (1-1/real b) powr b"
     using b_min by (subst exp_ln) auto
   finally have a:"1/3 \<le> (1-1/real b) powr b" by simp
 
   have "2/5 \<le> (1/3) powr (2/3::real)"
     by (approximation 5)
   also have "... \<le> ((1-1/real b) powr b) powr (2/3)"
     by (intro powr_mono2 a) auto
   also have "... = (1-1/real b) powr (2/3 * real b)"
     by (subst powr_powr) (simp add:algebra_simps)
   finally have "2/5 \<le> (1 - 1 / real b) powr (2 / 3 * real b)" by simp
   hence "1 - (1 - 1 / real b) powr (2 / 3 * real b) \<le> 3/5"
     by simp
   hence "\<rho> (2/3 * b) \<le> b * (3/5)"
     unfolding \<rho>_def by (intro mult_left_mono) auto
   thus ?thesis
     by simp
 qed
 
 definition \<rho>_inv' :: "real \<Rightarrow> real"
   where "\<rho>_inv' x = -1 / (real b * (1-x / real b) * ln (1 - 1 / real b))"
 
 lemma \<rho>_inv'_bound:
   assumes "x \<ge> 0"
   assumes "x \<le> 59/90*b"
   shows "\<bar>\<rho>_inv' x\<bar> \<le> 4"
 proof -
   have c:"ln (1 - 1 / real b) < 0"
     using b_min
     by (subst ln_less_zero_iff) auto
   hence d:"real b * (1 - x / real b) * ln (1 - 1 / real b) < 0"
     using b_min assms by (intro Rings.mult_pos_neg) auto
 
   have "(1::real) \<le> 31/30" by simp
   also have "... \<le> (31/30) * (b * -(- 1 / real b))"
     using b_min by simp
   also have "... \<le> (31/30) * (b * -ln (1 + (- 1 / real b)))"
     using b_min
     by (intro mult_left_mono le_imp_neg_le  ln_add_one_self_le_self2) auto
   also have "... \<le> 3 * (31/90) * (- b * ln (1 - 1 / real b))"
     by simp
   also have "... \<le> 3 * (1 - x / real b) * (- b * ln (1 - 1 / real b))"
     using assms b_min pos_divide_le_eq[where c="b"] c
     by (intro mult_right_mono mult_left_mono mult_nonpos_nonpos) auto
   also have "... \<le> 3 * (real b * (1 - x / real b) * (-ln (1 - 1 / real b)))"
     by (simp add:algebra_simps)
   finally have "3 * (real b * (1 - x / real b) * (-ln (1 - 1 / real b))) \<ge> 1" by simp
   hence "3 * (real b * (1 - x / real b) * ln (1 - 1 / real b)) \<le> -1" by simp
   hence "\<rho>_inv' x \<le> 3"
     unfolding \<rho>_inv'_def using d
     by (subst neg_divide_le_eq) auto
   moreover have "\<rho>_inv' x > 0"
     unfolding \<rho>_inv'_def using d by (intro divide_neg_neg) auto
   ultimately show ?thesis by simp
 qed
 
 lemma \<rho>_inv':
   fixes x :: real
   assumes "x < b"
   shows "DERIV \<rho>_inv x :> \<rho>_inv' x"
 proof -
   have "DERIV (ln \<circ> (\<lambda>x. (1 - x / real b))) x :> 1 / (1-x / real b) * (0 -1/b)"
     using assms b_min
     by (intro DERIV_chain DERIV_ln_divide DERIV_cdivide derivative_intros) auto
   hence "DERIV \<rho>_inv x :> (1 / (1-x / real b) * (-1/b)) / ln (1-1/real b)"
     unfolding comp_def \<rho>_inv_def by (intro DERIV_cdivide) auto
   thus ?thesis
     by (simp add:\<rho>_inv'_def algebra_simps)
 qed
 
 lemma accuracy_without_cutoff:
   "measure \<Psi> {(f,g,h). \<bar>Y (f,g,h) - real X\<bar> > \<epsilon> * X \<or> s f < q_max} \<le> 1/2^4"
   (is "?L \<le> ?R")
 proof -
   have "?L \<le> measure \<Psi> {\<psi>. \<not>E\<^sub>1 \<psi> \<or>  \<not>E\<^sub>2 \<psi> \<or>  \<not>E\<^sub>3 \<psi> \<or>  \<not>E\<^sub>4 \<psi>}"
   proof (rule pmf_rev_mono)
     fix \<psi> assume "\<psi> \<in> set_pmf (sample_pmf \<Psi>)"
     obtain f g h where \<psi>_def: "\<psi> = (f,g,h)" by (metis prod_cases3)
 
     assume "\<psi> \<notin> {\<psi>. \<not> E\<^sub>1 \<psi> \<or> \<not> E\<^sub>2 \<psi> \<or> \<not> E\<^sub>3 \<psi> \<or> \<not> E\<^sub>4 \<psi>}"
     hence assms: "E\<^sub>1 (f,g,h)" "E\<^sub>2 (f,g,h)" "E\<^sub>3 (f,g,h)" "E\<^sub>4 (f,g,h)"
       unfolding \<psi>_def by auto
 
     define I :: "real set" where "I = {0..59/90*b}"
 
     have "p (f,g,h) \<le> \<rho> (card (R f)) + \<epsilon>/12 * card (R f)"
       using assms(4) E\<^sub>4_def unfolding abs_le_iff by simp
     also have "... \<le> \<rho>(2/3*b) + 1/12* (2/3*b)"
       using \<epsilon>_lt_1 R_bound[OF assms(1,2)]
       by (intro add_mono rho_mono mult_mono) auto
     also have "... \<le> 3/5 * b + 1/18*b"
       by (intro add_mono rho_two_thirds) auto
     also have "... \<le> 59/90 * b"
        by simp
     finally have "p (f,g,h) \<le> 59/90 * b" by simp
     hence p_in_I: "p (f,g,h) \<in> I"
       unfolding I_def by simp
 
     have "\<rho> (card (R f)) \<le> \<rho>(2/3 * b)"
       using  R_bound[OF assms(1,2)]
       by (intro rho_mono) auto
     also have "... \<le> 3/5 * b"
       using rho_two_thirds by simp
     also have "... \<le> b * 59/90" by simp
     finally have "\<rho> (card (R f)) \<le> b * 59/90" by simp
     moreover have "(1 - 1 / real b) powr (real (card (R f))) \<le> 1 powr (real (card (R f)))"
       using b_min by (intro powr_mono2) auto
     hence "\<rho> (card (R f)) \<ge> 0"
       unfolding \<rho>_def by (intro mult_nonneg_nonneg) auto
     ultimately have "\<rho> (card (R f)) \<in> I"
       unfolding I_def by simp
 
     moreover have "interval I"
       unfolding I_def interval_def by simp
     moreover have "59 / 90 * b < b"
       using b_min by simp
     hence "DERIV \<rho>_inv x :> \<rho>_inv' x" if "x \<in> I" for x
       using that I_def by (intro \<rho>_inv') simp
     ultimately obtain \<xi> :: real where \<xi>_def: "\<xi> \<in> I"
       "\<rho>_inv (p(f,g,h)) - \<rho>_inv (\<rho> (card (R f))) = (p (f,g,h) - \<rho>(card (R f))) * \<rho>_inv' \<xi>"
       using p_in_I MVT_interval by blast
 
     have "\<bar>\<rho>_inv(p (f,g,h)) - card (R f)\<bar> = \<bar>\<rho>_inv(p (f,g,h)) - \<rho>_inv(\<rho>(card (R f)))\<bar>"
       by (subst \<rho>_inverse) simp
     also have "... = \<bar>(p (f,g,h) - \<rho> (card (R f)))\<bar> * \<bar>\<rho>_inv' \<xi> \<bar>"
       using \<xi>_def(2) abs_mult by simp
     also have "... \<le> \<bar>p (f,g,h) - \<rho> (card (R f))\<bar> * 4"
       using \<xi>_def(1) I_def
       by (intro mult_left_mono \<rho>_inv'_bound) auto
     also have "... \<le> ( \<epsilon>/12 * card (R f)) * 4"
       using assms(4) E\<^sub>4_def by (intro mult_right_mono) auto
     also have "... = \<epsilon>/3 * card (R f)" by simp
     finally have b: "\<bar>\<rho>_inv(p (f,g,h)) - card (R f)\<bar> \<le> \<epsilon>/3 * card (R f)"  by simp
 
     have "\<bar>\<rho>_inv(p (f,g,h)) - X / 2 ^ (s f)\<bar> \<le>
       \<bar>\<rho>_inv(p (f,g,h)) - card (R f)\<bar> + \<bar>card (R f) - X / 2 ^ (s f)\<bar>"
       by simp
     also have "... \<le> \<epsilon>/3 * card (R f) + \<bar>card (R f) - X / 2 ^ (s f)\<bar>"
       by (intro add_mono b) auto
     also have "... =  \<epsilon>/3 * \<bar>X / 2 ^ (s f) + (card (R f) - X / 2 ^ (s f))\<bar> +
       \<bar>card (R f) - X / 2 ^ (s f)\<bar>" by simp
     also have "... \<le>  \<epsilon>/3 * (\<bar>X / 2 ^ (s f)\<bar> + \<bar>card (R f) - X / 2 ^ (s f)\<bar>) +
       \<bar>card (R f) - X / 2 ^ (s f)\<bar>"
       using \<epsilon>_gt_0 by (intro mult_left_mono add_mono abs_triangle_ineq) auto
     also have "... \<le>  \<epsilon>/3 * \<bar>X / 2 ^ (s f)\<bar> + (1+  \<epsilon>/3) * \<bar>card (R f) - X / 2 ^ (s f)\<bar>"
       using \<epsilon>_gt_0 \<epsilon>_lt_1 by (simp add:algebra_simps)
     also have "... \<le>  \<epsilon>/3 * \<bar>X / 2 ^ s f\<bar> + (4/3) * ( \<epsilon> / 3 * real X / 2 ^ s f)"
       using assms(2) \<epsilon>_gt_0 \<epsilon>_lt_1
       unfolding E\<^sub>2_def by (intro add_mono mult_mono) auto
     also have "... = (7/9) * \<epsilon> * real X / 2^s f"
       using X_ge_1 by (subst abs_of_nonneg) auto
     also have "... \<le> 1 * \<epsilon> * real X / 2^s f"
       using \<epsilon>_gt_0 by (intro mult_mono divide_right_mono) auto
     also have "... =  \<epsilon> * real X / 2^s f" by simp
     finally have a:"\<bar>\<rho>_inv(p (f,g,h)) - X / 2 ^ (s f)\<bar> \<le> \<epsilon> * X / 2 ^ (s f)"
       by simp
 
     have "\<bar>Y (f, g, h) - real X\<bar> = \<bar>2 ^ (s f)\<bar> * \<bar>\<rho>_inv(p (f,g,h)) - real X / 2 ^ (s f)\<bar>"
       unfolding Y_def by (subst abs_mult[symmetric]) (simp add:algebra_simps powr_add[symmetric])
     also have "... \<le> 2 ^ (s f) * (\<epsilon> * X / 2 ^ (s f))"
       by (intro mult_mono a) auto
     also have "... = \<epsilon> * X"
       by (simp add:algebra_simps powr_add[symmetric])
     finally have "\<bar>Y (f, g, h) - real X\<bar> \<le> \<epsilon> * X" by simp
     moreover have "2 powr (\<lceil>log 2 (real X)\<rceil> - t f) \<le> 2 powr b_exp" (is "?L1 \<le> ?R1")
     proof -
       have "?L1 \<le> 2 powr (1 + log 2 (real X)- t f)"
         by (intro powr_mono, linarith) auto
       also have "... = 2 powr 1 * 2 powr (log 2 (real X)) * 2 powr (- t f)"
         unfolding powr_add[symmetric] by simp
       also have "... = 2 * (2 powr (-t f) * X)"
         using X_ge_1 by simp
       also have "... \<le> 2 * (b/2)"
         using assms(1) unfolding E\<^sub>1_def by (intro mult_left_mono) auto
       also have "... = b" by simp
       also have "... = ?R1"
         unfolding b_def by (simp add: powr_realpow)
       finally show ?thesis by simp
     qed
     hence "\<lceil>log 2 (real X)\<rceil> - t f \<le> real b_exp"
       unfolding not_less[symmetric] using powr_less_mono[where x="2"] by simp
     hence "s f \<ge> q_max" unfolding s_def q_max_def by (intro nat_mono) auto
     ultimately show "\<psi> \<notin> {(f, g, h). \<epsilon> * X < \<bar>Y (f, g, h) - real X\<bar> \<or> s f < q_max}"
       unfolding \<psi>_def by auto
   qed
   also have "... \<le>
     measure \<Psi> {\<psi>. \<not>E\<^sub>1 \<psi> \<or> \<not>E\<^sub>2 \<psi> \<or> \<not>E\<^sub>3 \<psi>} + measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> E\<^sub>2 \<psi> \<and> E\<^sub>3 \<psi> \<and> \<not>E\<^sub>4 \<psi>}"
     by (intro pmf_add) auto
   also have "... \<le> (measure \<Psi> {\<psi>. \<not>E\<^sub>1 \<psi> \<or> \<not>E\<^sub>2 \<psi>} + measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> E\<^sub>2 \<psi> \<and> \<not>E\<^sub>3 \<psi>}) + 1/2^6"
     by (intro add_mono e_4 pmf_add) auto
   also have "... \<le> ((measure \<Psi> {\<psi>. \<not>E\<^sub>1 \<psi>} + measure \<Psi> {\<psi>. E\<^sub>1 \<psi> \<and> \<not>E\<^sub>2 \<psi>}) + 1/2^6) + 1/2^6"
     by (intro add_mono e_3 pmf_add) auto
   also have "... \<le> ((1/2^6 + 1/2^6) + 1/2^6) + 1/2^6"
     by (intro add_mono e_2 e_1) auto
   also have "... = ?R" by simp
   finally show ?thesis by simp
 qed
 
 end
 
 end
diff --git a/thys/FO_Theory_Rewriting/ROOT b/thys/FO_Theory_Rewriting/ROOT
--- a/thys/FO_Theory_Rewriting/ROOT
+++ b/thys/FO_Theory_Rewriting/ROOT
@@ -1,37 +1,37 @@
 chapter AFP
 
 session FO_Theory_Rewriting = "HOL-Library" +
-  options [timeout = 1200]
+  options [timeout = 2400]
   sessions
     "Regular_Tree_Relations"
     "FOL-Fitting"
   directories
     "Util"
     "Primitives"
     "Rewriting"
     "Closure"
   theories
     "Util/Multihole_Context"
     "Util/Ground_MCtxt"
     "Util/Bot_Terms"
     "Util/Saturation"
     "Util/Utils"
     "Rewriting/Rewriting"
     "Primitives/LV_to_GTT"
     "Primitives/NF"
     "Primitives/NF_Impl"
     "Closure/TA_Clousure_Const"
     "Closure/Context_Extensions"
     "Closure/Lift_Root_Step"
     "Closure/GTT_RRn"
     "Closure/Context_RR2"
     "FOL_Extra"
     "FOR_Certificate"
     "FOR_Semantics"
     "FOR_Check"
     "Type_Instances_Impl"
     "FOR_Check_Impl"
   document_files
     "root.bib"
     "root.tex"
 
diff --git a/thys/FSM_Tests/FSM.thy b/thys/FSM_Tests/FSM.thy
--- a/thys/FSM_Tests/FSM.thy
+++ b/thys/FSM_Tests/FSM.thy
@@ -1,6428 +1,6428 @@
 section \<open>Finite State Machines\<close>
 
 text \<open>This theory defines well-formed finite state machines and introduces various closely related 
       notions, as well as a selection of basic properties and definitions.\<close>
 
 theory FSM
   imports FSM_Impl "HOL-Library.Quotient_Type" "HOL-Library.Product_Lexorder"
 begin
 
 
 subsection \<open>Well-formed Finite State Machines\<close>
 
 text \<open>A value of type @{text "fsm_impl"} constitutes a well-formed FSM if its contained sets are 
       finite and the initial state and the components of each transition are contained in their 
       respective sets.\<close>
 
 abbreviation(input) "well_formed_fsm (M :: ('state, 'input, 'output) fsm_impl) 
      \<equiv> (initial M \<in> states M
       \<and> finite (states M)
       \<and> finite (inputs M)
       \<and> finite (outputs M)
       \<and> finite (transitions M)
       \<and> (\<forall> t \<in> transitions M . t_source t \<in> states M \<and> 
                                 t_input t \<in> inputs M \<and> 
                                 t_target t \<in> states M \<and> 
                                 t_output t \<in> outputs M)) " 
 
 typedef ('state, 'input, 'output) fsm = 
   "{ M :: ('state, 'input, 'output) fsm_impl . well_formed_fsm M}"
   morphisms fsm_impl_of_fsm Abs_fsm 
 proof -
   obtain q :: 'state where "True" by blast
   have "well_formed_fsm (FSMI q {q} {} {} {})" by auto
   then show ?thesis by blast
 qed
 
 
 setup_lifting type_definition_fsm
 
 lift_definition initial :: "('state, 'input, 'output) fsm \<Rightarrow> 'state" is FSM_Impl.initial done
 lift_definition states :: "('state, 'input, 'output) fsm \<Rightarrow> 'state set" is FSM_Impl.states done
 lift_definition inputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'input set" is FSM_Impl.inputs done
 lift_definition outputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'output set" is FSM_Impl.outputs done
 lift_definition transitions :: 
   "('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input \<times> 'output \<times> 'state) set" 
   is FSM_Impl.transitions done
 
 lift_definition fsm_from_list :: "'a \<Rightarrow> ('a,'b,'c) transition list \<Rightarrow> ('a, 'b, 'c) fsm" 
   is FSM_Impl.fsm_impl_from_list 
 proof -
   fix q  :: 'a 
   fix ts :: "('a,'b,'c) transition list"
   show "well_formed_fsm (fsm_impl_from_list q ts)" 
     by (induction ts; auto)
 qed
 
 
 
 lemma fsm_initial[intro]: "initial M \<in> states M" 
   by (transfer; blast)
 lemma fsm_states_finite: "finite (states M)" 
   by (transfer; blast)
 lemma fsm_inputs_finite: "finite (inputs M)" 
   by (transfer; blast)
 lemma fsm_outputs_finite: "finite (outputs M)" 
   by (transfer; blast)
 lemma fsm_transitions_finite: "finite (transitions M)" 
   by (transfer; blast)
 lemma fsm_transition_source[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_source t \<in> states M" 
   by (transfer; blast)
 lemma fsm_transition_target[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_target t \<in> states M" 
   by (transfer; blast)
 lemma fsm_transition_input[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_input t \<in> inputs M" 
   by (transfer; blast)
 lemma fsm_transition_output[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_output t \<in> outputs M" 
   by (transfer; blast)
 
 
 instantiation fsm :: (type,type,type) equal
 begin                                  
 definition equal_fsm :: "('a, 'b, 'c) fsm \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> bool" where
   "equal_fsm x y = (initial x = initial y \<and> states x = states y \<and> inputs x = inputs y \<and> outputs x = outputs y \<and> transitions x = transitions y)"
 
 instance
   apply (intro_classes)
   unfolding equal_fsm_def 
   apply transfer
   using fsm_impl.expand by auto
 end 
 
 
 
 subsubsection \<open>Example FSMs\<close>
 
 
 definition m_ex_H :: "(integer,integer,integer) fsm" where
   "m_ex_H = fsm_from_list 1 [ (1,0,0,2),
                               (1,0,1,4),
                               (1,1,1,4),
                               (2,0,0,2),
                               (2,1,1,4),
                               (3,0,1,4),
                               (3,1,0,1),
                               (3,1,1,3),
                               (4,0,0,3),
                               (4,1,0,1)]"
 
 
 definition m_ex_9 :: "(integer,integer,integer) fsm" where
   "m_ex_9 = fsm_from_list 0 [ (0,0,2,2),
                               (0,0,3,2),
                               (0,1,0,3),
                               (0,1,1,3),
                               (1,0,3,2),
                               (1,1,1,3),
                               (2,0,2,2),
                               (2,1,3,3),
                               (3,0,2,2),
                               (3,1,0,2),
                               (3,1,1,1)]"
 
 definition m_ex_DR :: "(integer,integer,integer) fsm" where
   "m_ex_DR = fsm_from_list 0  [(0,0,0,100),
                                (100,0,0,101), 
                                (100,0,1,101),
                                (101,0,0,102),
                                (101,0,1,102),
                                (102,0,0,103),
                                (102,0,1,103),
                                (103,0,0,104),
                                (103,0,1,104),
                                (104,0,0,100),
                                (104,0,1,100),
                                (104,1,0,400),
                                (0,0,2,200),
                                (200,0,2,201),
                                (201,0,2,202),
                                (202,0,2,203),
                                (203,0,2,200),
                                (203,1,0,400),
                                (0,1,0,300),
                                (100,1,0,300),
                                (101,1,0,300),
                                (102,1,0,300),
                                (103,1,0,300),
                                (200,1,0,300),
                                (201,1,0,300),
                                (202,1,0,300),
                                (300,0,0,300),
                                (300,1,0,300),
                                (400,0,0,300),
                                (400,1,0,300)]"
 
 
 subsection \<open>Transition Function h and related functions\<close>
 
 lift_definition h :: "('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set" 
   is FSM_Impl.h .
 
 lemma h_simps[simp]: "FSM.h M (q,x) = { (y,q') . (q,x,y,q') \<in> transitions M }"
   by (transfer; auto)
 
 lift_definition h_obs :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input \<Rightarrow> 'output \<Rightarrow> 'state option" 
   is FSM_Impl.h_obs .
 
 lemma h_obs_simps[simp]: "FSM.h_obs M q x y = (let 
       tgts = snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))
     in if card tgts = 1
       then Some (the_elem tgts)
       else None)"
   by (transfer; auto)
 
 fun defined_inputs' :: "(('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'b set" where
   "defined_inputs' hM iM q = {x \<in> iM . hM (q,x) \<noteq> {}}"
 
 fun defined_inputs :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b set" where
   "defined_inputs M q = defined_inputs' (h M) (inputs M) q"
 
 lemma defined_inputs_set : "defined_inputs M q = {x \<in> inputs M . h M (q,x) \<noteq> {} }"
   by auto
 
 fun transitions_from' :: "(('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) transition set" where
   "transitions_from' hM iM q = \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . (q,x,y,q')) (hM (q,x))) iM)"
 
 fun transitions_from :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) transition set" where
   "transitions_from M q = transitions_from' (h M) (inputs M) q"
 
 
 lemma transitions_from_set : 
   assumes "q \<in> states M" 
   shows "transitions_from M q = {t \<in> transitions M . t_source t = q}"
 proof -
   have "\<And> t . t \<in> transitions_from M q \<Longrightarrow> t \<in> transitions M \<and> t_source t = q" by auto
   moreover have "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t = q \<Longrightarrow> t \<in> transitions_from M q" 
   proof -
     fix t assume "t \<in> transitions M" and "t_source t = q"
     then have "(t_output t, t_target t) \<in> h M (q,t_input t)" and "t_input t \<in> inputs M" by auto
     then have "t_input t \<in> defined_inputs' (h M) (inputs M) q" 
       unfolding defined_inputs'.simps \<open>t_source t = q\<close> by blast
 
     have "(q, t_input t, t_output t, t_target t) \<in> transitions M"
       using \<open>t_source t = q\<close> \<open>t \<in> transitions M\<close> by auto
     then have "(q, t_input t, t_output t, t_target t) \<in> (\<lambda>(y, q'). (q, t_input t, y, q')) ` h M (q, t_input t)"
       using \<open>(t_output t, t_target t) \<in> h M (q,t_input t)\<close>
       unfolding h.simps
       by (metis (no_types, lifting) image_iff prod.case_eq_if surjective_pairing)
     then have "t \<in> (\<lambda>(y, q'). (q, t_input t, y, q')) ` h M (q, t_input t)"
       using \<open>t_source t = q\<close> by (metis prod.collapse) 
     then show "t \<in> transitions_from M q" 
        
       unfolding transitions_from.simps transitions_from'.simps 
       using \<open>t_input t \<in> defined_inputs' (h M) (inputs M) q\<close>
       using \<open>t_input t \<in> FSM.inputs M\<close> by blast
   qed
   ultimately show ?thesis by blast
 qed
 
 
 fun h_from :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> ('input \<times> 'output \<times> 'state) set" where
   "h_from M q = { (x,y,q') . (q,x,y,q') \<in> transitions M }"
 
 
 lemma h_from[code] : "h_from M q = (let m = set_as_map (transitions M) 
                                      in (case m q of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
   unfolding set_as_map_def by force
 
 
 fun h_out :: "('a,'b,'c) fsm \<Rightarrow> ('a \<times> 'b) \<Rightarrow> 'c set" where
   "h_out M (q,x) = {y . \<exists> q' . (q,x,y,q') \<in> transitions M}"
 
 lemma h_out_code[code]: 
   "h_out M = (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of 
                             Some yqs \<Rightarrow> yqs | 
                             None \<Rightarrow> {}))"
 proof -
   
 
   let ?f = "(\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
   
   have "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` (transitions M)}) qx"
     unfolding set_as_map_def by auto
   
   moreover have "\<And> qx . (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` (transitions M)}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> (transitions M)}) qx" 
     by force
     
   ultimately have "?f = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> (transitions M)})" 
     by blast
   then have "?f = (\<lambda> (q,x) . {y | y . \<exists> q' . (q, x, y, q') \<in> (transitions M)})" by force
   
   then show ?thesis by force 
 qed
 
 lemma h_out_alt_def : 
   "h_out M (q,x) = {t_output t | t . t \<in> transitions M \<and> t_source t = q \<and> t_input t = x}"
   unfolding h_out.simps
   by auto
 
 
 subsection \<open>Size\<close>
 
 instantiation fsm  :: (type,type,type) size 
 begin
 
 definition size where [simp, code]: "size (m::('a, 'b, 'c) fsm) = card (states m)"
 
 instance ..
 end
 
 lemma fsm_size_Suc :
   "size M > 0"
   unfolding FSM.size_def
   using fsm_states_finite[of M] fsm_initial[of M]
   using card_gt_0_iff by blast 
 
 
 subsection \<open>Paths\<close>
 
 inductive path :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> bool" 
   where
   nil[intro!] : "q \<in> states M \<Longrightarrow> path M q []" |
   cons[intro!] : "t \<in> transitions M \<Longrightarrow> path M (t_target t) ts \<Longrightarrow> path M (t_source t) (t#ts)"
 
 inductive_cases path_nil_elim[elim!]: "path M q []"
 inductive_cases path_cons_elim[elim!]: "path M q (t#ts)"
 
 fun visited_states :: "'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> 'state list" where
   "visited_states q p = (q # map t_target p)"
 
 fun target :: "'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> 'state" where
   "target q p = last (visited_states q p)"
 
 lemma target_nil [simp] : "target q [] = q" by auto
 lemma target_snoc [simp] : "target q (p@[t]) = t_target t" by auto
 
 
 lemma path_begin_state :
   assumes "path M q p"
   shows   "q \<in> states M" 
   using assms by (cases; auto) 
 
 lemma path_append[intro!] :
   assumes "path M q p1"
       and "path M (target q p1) p2"
   shows "path M q (p1@p2)"
   using assms by (induct p1 arbitrary: p2; auto) 
 
 lemma path_target_is_state :
   assumes "path M q p"
   shows   "target q p \<in> states M"
 using assms by (induct p; auto)
 
 lemma path_suffix :
   assumes "path M q (p1@p2)"
   shows "path M (target q p1) p2"
 using assms by (induction p1 arbitrary: q; auto)
 
 lemma path_prefix :
   assumes "path M q (p1@p2)"
   shows "path M q p1"
 using assms by (induction p1 arbitrary: q; auto; (metis path_begin_state))
 
 lemma path_append_elim[elim!] :
   assumes "path M q (p1@p2)"
   obtains "path M q p1"
       and "path M (target q p1) p2"
   by (meson assms path_prefix path_suffix)
 
 lemma path_append_target:
   "target q (p1@p2) = target (target q p1) p2" 
   by (induction p1) (simp+)
 
 lemma path_append_target_hd :
   assumes "length p > 0"
   shows "target q p = target (t_target (hd p)) (tl p)"
 using assms by (induction p) (simp+)
 
 lemma path_transitions :
   assumes "path M q p"
   shows "set p \<subseteq> transitions M"
   using assms by (induct p arbitrary: q; fastforce)
 
 lemma path_append_transition[intro!] :
   assumes "path M q p"
   and     "t \<in> transitions M"
   and     "t_source t = target q p" 
 shows "path M q (p@[t])"
   by (metis assms(1) assms(2) assms(3) cons fsm_transition_target nil path_append)
 
 lemma path_append_transition_elim[elim!] :
   assumes "path M q (p@[t])"
 shows "path M q p"
 and   "t \<in> transitions M"
 and   "t_source t = target q p" 
   using assms by auto
 
 lemma path_prepend_t : "path M q' p \<Longrightarrow> (q,x,y,q') \<in> transitions M \<Longrightarrow> path M q ((q,x,y,q')#p)" 
   by (metis (mono_tags, lifting) fst_conv path.intros(2) prod.sel(2)) 
 
 lemma path_target_append : "target q1 p1 = q2 \<Longrightarrow> target q2 p2 = q3 \<Longrightarrow> target q1 (p1@p2) = q3" 
   by auto
 
 lemma single_transition_path : "t \<in> transitions M \<Longrightarrow> path M (t_source t) [t]" by auto
 
 lemma path_source_target_index :
   assumes "Suc i < length p"
   and     "path M q p"
 shows "t_target (p ! i) = t_source (p ! (Suc i))"
   using assms proof (induction p rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc t ps)
   then have "path M q ps" and "t_source t = target q ps" and "t \<in> transitions M" by auto
   
   show ?case proof (cases "Suc i < length ps")
     case True
     then have "t_target (ps ! i) = t_source (ps ! Suc i)" 
       using snoc.IH \<open>path M q ps\<close> by auto
     then show ?thesis
       by (simp add: Suc_lessD True nth_append) 
   next
     case False
     then have "Suc i = length ps"
       using snoc.prems(1) by auto
     then have "(ps @ [t]) ! Suc i = t"
       by auto
 
     show ?thesis proof (cases "ps = []")
       case True
       then show ?thesis using \<open>Suc i = length ps\<close> by auto
     next
       case False
       then have "target q ps = t_target (last ps)"
         unfolding target.simps visited_states.simps
         by (simp add: last_map) 
       then have "target q ps = t_target (ps ! i)"
         using \<open>Suc i = length ps\<close>
         by (metis False diff_Suc_1 last_conv_nth) 
       then show ?thesis 
         using \<open>t_source t = target q ps\<close>
         by (metis \<open>(ps @ [t]) ! Suc i = t\<close> \<open>Suc i = length ps\<close> lessI nth_append) 
     qed
   qed   
 qed
 
 lemma paths_finite : "finite { p . path M q p \<and> length p \<le> k }"
 proof -
   have "{ p . path M q p \<and> length p \<le> k } \<subseteq> {xs . set xs \<subseteq> transitions M \<and> length xs \<le> k}"
     by (metis (no_types, lifting) Collect_mono path_transitions)     
   then show "finite { p . path M q p \<and> length p \<le> k }"
     using finite_lists_length_le[OF fsm_transitions_finite[of M], of k]
     by (metis (mono_tags) finite_subset) 
 qed
 
 lemma visited_states_prefix :
   assumes "q' \<in> set (visited_states q p)"
   shows   "\<exists> p1 p2 . p = p1@p2 \<and> target q p1 = q'"
 using assms proof (induction p arbitrary: q)
   case Nil
   then show ?case by auto
 next
   case (Cons a p)
   then show ?case 
   proof (cases "q' \<in> set (visited_states (t_target a) p)")
     case True
     then obtain p1 p2 where "p = p1 @ p2 \<and> target (t_target a) p1 = q'"
       using Cons.IH by blast
     then have "(a#p) = (a#p1)@p2 \<and> target q (a#p1) = q'"
       by auto
     then show ?thesis by blast
   next
     case False
     then have "q' = q" 
       using Cons.prems by auto     
     then show ?thesis
       by auto 
   qed
 qed 
 
 lemma visited_states_are_states :
   assumes "path M q1 p"
   shows "set (visited_states q1 p) \<subseteq> states M" 
   by (metis assms path_prefix path_target_is_state subsetI visited_states_prefix) 
   
 lemma transition_subset_path : 
   assumes "transitions A \<subseteq> transitions B"
   and "path A q p"
   and "q \<in> states B"
 shows "path B q p"
 using assms(2) proof (induction p rule: rev_induct)
   case Nil
   show ?case using assms(3) by auto
 next
   case (snoc t p)
   then show ?case using assms(1) path_suffix
     by fastforce   
 qed
 
 subsubsection \<open>Paths of fixed length\<close>
 
 fun paths_of_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> (('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" 
   where
   "paths_of_length' prev q hM iM 0 = {prev}" |
   "paths_of_length' prev q hM iM (Suc k) = 
     (let hF = transitions_from' hM iM q
       in \<Union> (image (\<lambda> t . paths_of_length' (prev@[t]) (t_target t) hM iM k) hF))"
 
 fun paths_of_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
   "paths_of_length M q k = paths_of_length' [] q (h M) (inputs M) k"
 
 
 
 subsubsection \<open>Paths up to fixed length\<close>
 
 fun paths_up_to_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> (('a \<times>'b) \<Rightarrow> (('c\<times>'a) set)) \<Rightarrow> 'b set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" 
   where
   "paths_up_to_length' prev q hM iM 0 = {prev}" |
   "paths_up_to_length' prev q hM iM (Suc k) = 
     (let hF = transitions_from' hM iM q
       in insert prev (\<Union> (image (\<lambda> t . paths_up_to_length' (prev@[t]) (t_target t) hM iM k) hF)))"
 
 fun paths_up_to_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
   "paths_up_to_length M q k = paths_up_to_length' [] q (h M) (inputs M) k"
 
 
 lemma paths_up_to_length'_set :
   assumes "q \<in> states M"
   and     "path M q prev"
 shows "paths_up_to_length' prev (target q prev) (h M) (inputs M) k 
         = {(prev@p) | p . path M (target q prev) p \<and> length p \<le> k}"
 using assms(2) proof (induction k arbitrary: prev)
   case 0
   show ?case unfolding paths_up_to_length'.simps using path_target_is_state[OF "0.prems"(1)] by auto
 next
   case (Suc k)
   
   have "\<And> p . p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k) 
           \<Longrightarrow> p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}"
   proof -
     fix p assume "p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
     then show "p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}" 
     proof (cases "p = prev")
       case True
       show ?thesis using path_target_is_state[OF Suc.prems(1)] unfolding True by (simp add: nil) 
     next
       case False
       then have "p \<in> (\<Union> (image (\<lambda>t. paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k) 
                                 (transitions_from' (h M) (inputs M) (target q prev))))"
         using \<open>p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)\<close>
         unfolding paths_up_to_length'.simps Let_def by blast
       then obtain t where "t \<in> \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . ((target q prev),x,y,q')) 
                                                     (h M ((target q prev),x))) (inputs M))"
                     and   "p \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k"
         unfolding transitions_from'.simps by blast
 
       have "t \<in> transitions M" and "t_source t = (target q prev)"
         using \<open>t \<in> \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . ((target q prev),x,y,q')) 
                                         (h M ((target q prev),x))) (inputs M))\<close> by auto
       then have "path M q (prev@[t])"
         using Suc.prems(1) using path_append_transition by simp
 
       have "(target q (prev @ [t])) = t_target t" by auto
       
 
       show ?thesis 
         using \<open>p \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k\<close>
         using Suc.IH[OF \<open>path M q (prev@[t])\<close>] 
         unfolding \<open>(target q (prev @ [t])) = t_target t\<close>
         using \<open>path M q (prev @ [t])\<close> by auto 
     qed
   qed
 
   moreover have "\<And> p . p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k} 
                   \<Longrightarrow> p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
   proof -
     fix p assume "p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}"
     then obtain p' where "p = prev@p'"
                    and   "path M (target q prev) p'" 
                    and   "length p' \<le> Suc k"
       by blast
 
     have "prev@p' \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
     proof (cases p')
       case Nil
       then show ?thesis by auto
     next
       case (Cons t p'')
 
       then have "t \<in> transitions M" and "t_source t = (target q prev)"
         using \<open>path M (target q prev) p'\<close> by auto
       then have "path M q (prev@[t])"
         using Suc.prems(1) using path_append_transition by simp
       
       have "(target q (prev @ [t])) = t_target t" by auto
 
       have "length p'' \<le> k" using \<open>length p' \<le> Suc k\<close> Cons by auto
       moreover have "path M (target q (prev@[t])) p''"
         using \<open>path M (target q prev) p'\<close> unfolding Cons
         by auto
       ultimately have "p \<in> paths_up_to_length' (prev @ [t]) (t_target t) (h M) (FSM.inputs M) k"
         using Suc.IH[OF \<open>path M q (prev@[t])\<close>] 
         unfolding \<open>(target q (prev @ [t])) = t_target t\<close> \<open>p = prev@p'\<close> Cons by simp
       then have "prev@t#p'' \<in> paths_up_to_length' (prev @ [t]) (t_target t) (h M) (FSM.inputs M) k"
         unfolding \<open>p = prev@p'\<close> Cons by auto
 
       have "t \<in> (\<lambda>(y, q'). (t_source t, t_input t, y, q')) ` 
                               {(y, q'). (t_source t, t_input t, y, q') \<in> FSM.transitions M}"
         using \<open>t \<in> transitions M\<close>
         by (metis (no_types, lifting) case_prodI mem_Collect_eq pair_imageI surjective_pairing)  
       then have "t \<in> transitions_from' (h M) (inputs M) (target q prev)"
         unfolding transitions_from'.simps 
         using fsm_transition_input[OF \<open>t \<in> transitions M\<close>] 
         unfolding \<open>t_source t = (target q prev)\<close>[symmetric] h_simps 
         by blast
 
       then show ?thesis 
         using \<open>prev @ t # p'' \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (FSM.inputs M) k\<close> 
         unfolding \<open>p = prev@p'\<close> Cons paths_up_to_length'.simps Let_def by blast
     qed
     then show "p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
       unfolding \<open>p = prev@p'\<close> by assumption
   qed
 
   ultimately show ?case by blast
 qed
 
 
 lemma paths_up_to_length_set :
   assumes "q \<in> states M"
 shows "paths_up_to_length M q k = {p . path M q p \<and> length p \<le> k}" 
   unfolding paths_up_to_length.simps 
   using paths_up_to_length'_set[OF assms nil[OF assms], of k]  by auto
 
 
 
 
 subsubsection \<open>Calculating Acyclic Paths\<close>
 
 fun acyclic_paths_up_to_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> ('a  \<Rightarrow> (('b\<times>'c\<times>'a) set)) \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" 
   where
   "acyclic_paths_up_to_length' prev q hF visitedStates 0 = {prev}" |
   "acyclic_paths_up_to_length' prev q hF visitedStates (Suc k) = 
     (let tF = Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF q)
       in (insert prev (\<Union> (image (\<lambda> (x,y,q') . acyclic_paths_up_to_length' (prev@[(q,x,y,q')]) q' hF (insert q' visitedStates) k) tF))))"
 
 
 fun p_source :: "'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> 'a"
   where "p_source q p = hd (visited_states q p)"
 
 lemma acyclic_paths_up_to_length'_prev : 
   "p' \<in> acyclic_paths_up_to_length' (prev@prev') q hF visitedStates k \<Longrightarrow> \<exists> p'' . p' = prev@p''" 
   by (induction k arbitrary: p' q visitedStates prev'; auto)
 
 lemma acyclic_paths_up_to_length'_set :
   assumes "path M (p_source q prev) prev"
   and     "\<And> q' . hF q' = {(x,y,q'') | x y q'' . (q',x,y,q'') \<in> transitions M}"
   and     "distinct (visited_states (p_source q prev) prev)"
   and     "visitedStates = set (visited_states (p_source q prev) prev)"
 shows "acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates k 
         = { prev@p | p . path M (p_source q prev) (prev@p) 
                           \<and> length p \<le> k 
                           \<and> distinct (visited_states (p_source q prev) (prev@p)) }"
 using assms proof (induction k arbitrary: q hF prev visitedStates)
   case 0
   then show ?case by auto
 next
   case (Suc k)
 
   let ?tgt = "(target (p_source q prev) prev)"
 
   have "\<And> p . (prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k) 
             \<Longrightarrow> path M (p_source q prev) (prev@p) 
                 \<and> length p \<le> Suc k 
                 \<and> distinct (visited_states (p_source q prev) (prev@p))"
   proof -
     fix p assume "(prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
     then consider (a) "(prev@p) = prev" |
                   (b) "(prev@p) \<in> (\<Union> (image (\<lambda> (x,y,q') . acyclic_paths_up_to_length' (prev@[(?tgt,x,y,q')]) q' hF (insert q' visitedStates) k) 
                                              (Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (target (p_source q prev) prev)))))"
       by auto
     then show "path M (p_source q prev) (prev@p) \<and> length p \<le> Suc k \<and> distinct (visited_states (p_source q prev) (prev@p))"
     proof (cases)
       case a
       then show ?thesis using Suc.prems(1,3) by auto
     next
       case b
       then obtain x y q' where *: "(x,y,q') \<in> Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF ?tgt)"
                          and   **:"(prev@p) \<in> acyclic_paths_up_to_length' (prev@[(?tgt,x,y,q')]) q' hF (insert q' visitedStates) k"
         by auto
 
       let ?t = "(?tgt,x,y,q')"
 
       from * have "?t \<in> transitions M" and "q' \<notin> visitedStates"
         using Suc.prems(2)[of ?tgt] by simp+ 
       moreover have "t_source ?t = target (p_source q prev) prev"
         by simp
       moreover have "p_source (p_source q prev) (prev@[?t]) = p_source q prev"
         by auto
       ultimately have p1: "path M (p_source (p_source q prev) (prev@[?t])) (prev@[?t])" 
         using Suc.prems(1)
         by (simp add: path_append_transition) 
       
       
       have "q' \<notin> set (visited_states (p_source q prev) prev)"
         using \<open>q' \<notin> visitedStates\<close> Suc.prems(4) by auto
       then have p2: "distinct (visited_states (p_source (p_source q prev) (prev@[?t])) (prev@[?t]))"
         using Suc.prems(3) by auto
 
       have p3: "(insert q' visitedStates) 
                   = set (visited_states (p_source (p_source q prev) (prev@[?t])) (prev@[?t]))"
         using Suc.prems(4) by auto
 
       have ***: "(target (p_source (p_source q prev) (prev @ [(target (p_source q prev) prev, x, y, q')])) 
                          (prev @ [(target (p_source q prev) prev, x, y, q')])) 
                   = q'"
         by auto
 
       show ?thesis
         using Suc.IH[OF p1 Suc.prems(2) p2 p3] ** 
         unfolding *** 
         unfolding \<open>p_source (p_source q prev) (prev@[?t]) = p_source q prev\<close>
       proof -
         assume "acyclic_paths_up_to_length' (prev @ [(target (p_source q prev) prev, x, y, q')]) q' hF (insert q' visitedStates) k 
                   = {(prev @ [(target (p_source q prev) prev, x, y, q')]) @ p |p. 
                         path M (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ p) 
                         \<and> length p \<le> k 
                         \<and> distinct (visited_states (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ p))}"
         then have "\<exists>ps. prev @ p = (prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps 
                         \<and> path M (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps) 
                         \<and> length ps \<le> k 
                         \<and> distinct (visited_states (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps))"
           using \<open>prev @ p \<in> acyclic_paths_up_to_length' (prev @ [(target (p_source q prev) prev, x, y, q')]) q' hF (insert q' visitedStates) k\<close> 
           by blast
         then show ?thesis
           by (metis (no_types) Suc_le_mono append.assoc append.right_neutral append_Cons length_Cons same_append_eq)
       qed 
     qed
   qed
   moreover have "\<And> p' . p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k) 
                         \<Longrightarrow> \<exists> p'' . p' = prev@p''"
     using acyclic_paths_up_to_length'_prev[of _ prev "[]" "target (p_source q prev) prev" hF visitedStates "Suc k"] 
     by force
   ultimately have fwd: "\<And> p' . p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k) 
                           \<Longrightarrow> p' \<in> { prev@p | p . path M (p_source q prev) (prev@p) 
                                                     \<and> length p \<le> Suc k 
                                                     \<and> distinct (visited_states (p_source q prev) (prev@p)) }"
     by blast
 
   have "\<And> p . path M (p_source q prev) (prev@p) 
                 \<Longrightarrow> length p \<le> Suc k 
                 \<Longrightarrow> distinct (visited_states (p_source q prev) (prev@p)) 
                 \<Longrightarrow> (prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
   proof -
     fix p assume "path M (p_source q prev) (prev@p)"
           and    "length p \<le> Suc k"
           and    "distinct (visited_states (p_source q prev) (prev@p))"
 
     show "(prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
     proof (cases p)
       case Nil
       then show ?thesis by auto
     next
       case (Cons t p')
 
       then have "t_source t = target (p_source q (prev)) (prev)" and "t \<in> transitions M"
         using \<open>path M (p_source q prev) (prev@p)\<close> by auto
       
       have "path M (p_source q (prev@[t])) ((prev@[t])@p')"
       and  "path M (p_source q (prev@[t])) ((prev@[t]))"
         using Cons \<open>path M (p_source q prev) (prev@p)\<close> by auto
       have "length p' \<le> k"
         using Cons \<open>length p \<le> Suc k\<close> by auto
       have "distinct (visited_states (p_source q (prev@[t])) ((prev@[t])@p'))"
       and  "distinct (visited_states (p_source q (prev@[t])) ((prev@[t])))" 
         using Cons \<open>distinct (visited_states (p_source q prev) (prev@p))\<close> by auto
       then have "t_target t \<notin> visitedStates"
         using Suc.prems(4) by auto
 
       let ?vN = "insert (t_target t) visitedStates"
       have "?vN = set (visited_states (p_source q (prev @ [t])) (prev @ [t]))"
         using Suc.prems(4) by auto
 
       have "prev@p = prev@([t]@p')"
         using Cons by auto
 
       have "(prev@[t])@p' \<in> acyclic_paths_up_to_length' (prev @ [t]) (target (p_source q (prev @ [t])) (prev @ [t])) hF (insert (t_target t) visitedStates) k" 
         using Suc.IH[of q "prev@[t]", OF \<open>path M (p_source q (prev@[t])) ((prev@[t]))\<close> Suc.prems(2)
                                          \<open>distinct (visited_states (p_source q (prev@[t])) ((prev@[t])))\<close> 
                                          \<open>?vN = set (visited_states (p_source q (prev @ [t])) (prev @ [t]))\<close> ]
         using \<open>path M (p_source q (prev@[t])) ((prev@[t])@p')\<close>
               \<open>length p' \<le> k\<close>
               \<open>distinct (visited_states (p_source q (prev@[t])) ((prev@[t])@p'))\<close> 
         by force
 
       then have "(prev@[t])@p' \<in> acyclic_paths_up_to_length' (prev@[t]) (t_target t) hF ?vN k"
         by auto
       moreover have "(t_input t,t_output t, t_target t) \<in> Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (t_source t))"
         using Suc.prems(2)[of "t_source t"] \<open>t \<in> transitions M\<close> \<open>t_target t \<notin> visitedStates\<close>
       proof -
         have "\<exists>b c a. snd t = (b, c, a) \<and> (t_source t, b, c, a) \<in> FSM.transitions M"
           by (metis (no_types) \<open>t \<in> FSM.transitions M\<close> prod.collapse)
         then show ?thesis
           using \<open>hF (t_source t) = {(x, y, q'') |x y q''. (t_source t, x, y, q'') \<in> FSM.transitions M}\<close> 
                 \<open>t_target t \<notin> visitedStates\<close> 
           by fastforce
       qed 
       ultimately have "\<exists> (x,y,q') \<in> (Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (target (p_source q prev) prev))) .
                         (prev@[t])@p' \<in> (acyclic_paths_up_to_length' (prev@[((target (p_source q prev) prev),x,y,q')]) q' hF (insert q' visitedStates) k)"
         unfolding \<open>t_source t = target (p_source q (prev)) (prev)\<close>
         by (metis (no_types, lifting) \<open>t_source t = target (p_source q prev) prev\<close> case_prodI prod.collapse) 
        
       then show ?thesis unfolding \<open>prev@p = prev@[t]@p'\<close> 
         unfolding acyclic_paths_up_to_length'.simps Let_def by force
     qed
   qed
   then have rev: "\<And> p' . p' \<in> {prev@p | p . path M (p_source q prev) (prev@p) 
                                               \<and> length p \<le> Suc k 
                                               \<and> distinct (visited_states (p_source q prev) (prev@p))} 
                         \<Longrightarrow> p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
     by blast
   
   show ?case
     using fwd rev by blast
 qed 
 
 
 fun acyclic_paths_up_to_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
   "acyclic_paths_up_to_length M q k = {p. path M q p \<and> length p \<le> k \<and> distinct (visited_states q p)}"
 
 lemma acyclic_paths_up_to_length_code[code] :
   "acyclic_paths_up_to_length M q k = (if q \<in> states M 
       then acyclic_paths_up_to_length' [] q (m2f (set_as_map (transitions M))) {q} k
       else {})"
 proof (cases "q \<in> states M")
   case False
   then have "acyclic_paths_up_to_length M q k = {}" 
     using path_begin_state by fastforce
   then show ?thesis using False by auto
 next
   case True
   then have *: "path M (p_source q []) []" by auto
   have **: "(\<And>q'. (m2f (set_as_map (transitions M))) q' = {(x, y, q'') |x y q''. (q', x, y, q'') \<in> FSM.transitions M})"
     unfolding set_as_map_def by auto 
   have ***: "distinct (visited_states (p_source q []) [])"
     by auto
   have ****: "{q} = set (visited_states (p_source q []) [])"
     by auto
   
   show ?thesis
     using acyclic_paths_up_to_length'_set[OF * ** *** ****, of k ] 
     using True by auto
 qed
 
 
 lemma path_map_target : "target (f4 q) (map (\<lambda> t . (f1 (t_source t), f2 (t_input t), f3 (t_output t), f4 (t_target t))) p) = f4 (target q p)" 
   by (induction p; auto)
 
 
 lemma path_length_sum :
   assumes "path M q p" 
   shows "length p = (\<Sum> q \<in> states M . length (filter (\<lambda>t. t_target t = q) p))"
   using assms
 proof (induction p rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
   then have "length xs = (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))"
     by auto
   
   have *: "t_target x \<in> states M"
     using \<open>path M q (xs @ [x])\<close> by auto
   then have **: "length (filter (\<lambda>t. t_target t = t_target x) (xs @ [x])) 
                   = Suc (length (filter (\<lambda>t. t_target t = t_target x) xs))"
     by auto
 
   have "\<And> q . q \<in> states M \<Longrightarrow> q \<noteq> t_target x 
           \<Longrightarrow> length (filter (\<lambda>t. t_target t = q) (xs @ [x])) = length (filter (\<lambda>t. t_target t = q) xs)"
     by simp
   then have ***: "(\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) (xs @ [x]))) 
                   = (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) xs))"
     using fsm_states_finite[of M]
     by (metis (no_types, lifting) DiffE insertCI sum.cong)
 
   have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (xs @ [x]))) 
           = (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) (xs @ [x]))) 
               + (length (filter (\<lambda>t. t_target t = t_target x) (xs @ [x])))"
     using * fsm_states_finite[of M]
   proof -
     have "(\<Sum>a\<in>insert (t_target x) (states M). length (filter (\<lambda>p. t_target p = a) (xs @ [x]))) 
             = (\<Sum>a\<in>states M. length (filter (\<lambda>p. t_target p = a) (xs @ [x])))"
       by (simp add: \<open>t_target x \<in> states M\<close> insert_absorb)
     then show ?thesis
       by (simp add: \<open>finite (states M)\<close> sum.insert_remove)
   qed  
   moreover have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs)) 
                   = (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) xs)) 
                       + (length (filter (\<lambda>t. t_target t = t_target x) xs))"
     using * fsm_states_finite[of M]
   proof -
     have "(\<Sum>a\<in>insert (t_target x) (states M). length (filter (\<lambda>p. t_target p = a) xs)) 
             = (\<Sum>a\<in>states M. length (filter (\<lambda>p. t_target p = a) xs))"
       by (simp add: \<open>t_target x \<in> states M\<close> insert_absorb)
     then show ?thesis
       by (simp add: \<open>finite (states M)\<close> sum.insert_remove)
   qed  
 
   ultimately have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (xs @ [x]))) 
                     = Suc (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))"
     using ** *** by auto
     
   then show ?case
     by (simp add: \<open>length xs = (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))\<close>) 
 qed
 
 
 lemma path_loop_cut :
   assumes "path M q p"
   and     "t_target (p ! i) = t_target (p ! j)"
   and     "i < j"
   and     "j < length p"
 shows "path M q ((take (Suc i) p) @ (drop (Suc j) p))"
 and   "target q ((take (Suc i) p) @ (drop (Suc j) p)) = target q p"
 and   "length ((take (Suc i) p) @ (drop (Suc j) p)) < length p"
 and   "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p))"
 and   "target (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p)) = (target q (take (Suc i) p))"
 proof -
     
   have "p = (take (Suc j) p) @ (drop (Suc j) p)"
     by auto
   also have "\<dots> = ((take (Suc i) (take (Suc j) p)) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p)"
     by (metis append_take_drop_id)
   also have "\<dots> = ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p)"
     using \<open>i < j\<close> by simp 
   finally have "p = (take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p)"
     by simp
 
   then have "path M q ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p))"
        and  "path M q (((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p))"
     using \<open>path M q p\<close> by auto
 
   have "path M q (take (Suc i) p)" and "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p) @ drop (Suc j) p)"
     using path_append_elim[OF \<open>path M q ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p))\<close>] 
     by blast+
 
   
   have *: "(take (Suc i) p @ drop (Suc i) (take (Suc j) p)) = (take (Suc j) p)"
       using \<open>i < j\<close> append_take_drop_id
       by (metis \<open>(take (Suc i) (take (Suc j) p) @ drop (Suc i) (take (Suc j) p)) @ drop (Suc j) p = (take (Suc i) p @ drop (Suc i) (take (Suc j) p)) @ drop (Suc j) p\<close> append_same_eq)
 
   have "path M q (take (Suc j) p)" and "path M (target q (take (Suc j) p)) (drop (Suc j) p)"
     using path_append_elim[OF \<open>path M q (((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p))\<close>] 
     unfolding *
     by blast+
 
   have **: "(target q (take (Suc j) p)) = (target q (take (Suc i) p))"
   proof -
     have "p ! i = last (take (Suc i) p)"
       by (metis Suc_lessD assms(3) assms(4) less_trans_Suc take_last_index)
     moreover have "p ! j = last (take (Suc j) p)"
       by (simp add: assms(4) take_last_index)
     ultimately show ?thesis
       using assms(2) unfolding * target.simps visited_states.simps
       by (simp add: last_map) 
   qed
 
   show "path M q ((take (Suc i) p) @ (drop (Suc j) p))"
     using \<open>path M q (take (Suc i) p)\<close> \<open>path M (target q (take (Suc j) p)) (drop (Suc j) p)\<close> unfolding ** by auto
 
   show "target q ((take (Suc i) p) @ (drop (Suc j) p)) = target q p"
     by (metis "**" append_take_drop_id path_append_target)
     
   show "length ((take (Suc i) p) @ (drop (Suc j) p)) < length p"
   proof -
     have ***: "length p = length ((take (Suc j) p) @ (drop (Suc j) p))"
       by auto
 
     have "length (take (Suc i) p) < length (take (Suc j) p)"
       using assms(3,4)
       by (simp add: min_absorb2) 
 
     have scheme: "\<And> a b c . length a < length b \<Longrightarrow> length (a@c) < length (b@c)"
       by auto
     
     show ?thesis 
       unfolding *** using scheme[OF \<open>length (take (Suc i) p) < length (take (Suc j) p)\<close>, of "(drop (Suc j) p)"]
       by assumption
   qed
 
   show "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p))"
     using \<open>path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p) @ drop (Suc j) p)\<close> by blast
 
   show "target (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p)) = (target q (take (Suc i) p))"
     by (metis "*" "**" path_append_target) 
 qed
       
 
 lemma path_prefix_take :
   assumes "path M q p"
   shows "path M q (take i p)"
 proof -
   have "p = (take i p)@(drop i p)" by auto
   then have "path M q ((take i p)@(drop i p))" using assms by auto
   then show ?thesis
     by blast 
 qed
 
 
 
 subsection \<open>Acyclic Paths\<close>
 
 lemma cyclic_path_loop :
   assumes "path M q p"
   and     "\<not> distinct (visited_states q p)"
 shows "\<exists> p1 p2 p3 . p = p1@p2@p3 \<and> p2 \<noteq> [] \<and> target q p1 = target q (p1@p2)"
 using assms proof (induction p arbitrary: q)
   case (nil M q)
   then show ?case by auto
 next
   case (cons t M ts)
   then show ?case 
   proof (cases "distinct (visited_states (t_target t) ts)")
     case True
     then have "q \<in> set (visited_states (t_target t) ts)"
       using cons.prems by simp 
     then obtain p2 p3 where "ts = p2@p3" and "target (t_target t) p2 = q" 
       using visited_states_prefix[of q "t_target t" ts] by blast
     then have "(t#ts) = []@(t#p2)@p3 \<and> (t#p2) \<noteq> [] \<and> target q [] = target q ([]@(t#p2))"
       using cons.hyps by auto
     then show ?thesis by blast
   next
     case False
     then obtain p1 p2 p3 where "ts = p1@p2@p3" and "p2 \<noteq> []" 
                            and "target (t_target t) p1 = target (t_target t) (p1@p2)" 
       using cons.IH by blast
     then have "t#ts = (t#p1)@p2@p3 \<and> p2 \<noteq> [] \<and> target q (t#p1) = target q ((t#p1)@p2)"
       by simp
     then show ?thesis by blast    
   qed
 qed
 
 
 lemma cyclic_path_pumping :
   assumes "path M (initial M) p" 
       and "\<not> distinct (visited_states (initial M) p)"
   shows "\<exists> p . path M (initial M) p \<and> length p \<ge> n"
 proof -
   from assms obtain p1 p2 p3 where "p = p1 @ p2 @ p3" and "p2 \<noteq> []" 
                                and "target (initial M) p1 = target (initial M) (p1 @ p2)"
     using cyclic_path_loop[of M "initial M" p] by blast
   then have "path M (target (initial M) p1) p3"
     using path_suffix[of M "initial M" "p1@p2" p3] \<open>path M (initial M) p\<close> by auto
   
   have "path M (initial M) p1"
     using path_prefix[of M "initial M" p1 "p2@p3"] \<open>path M (initial M) p\<close> \<open>p = p1 @ p2 @ p3\<close> 
     by auto
   have "path M (initial M) ((p1@p2)@p3)"
     using \<open>path M (initial M) p\<close> \<open>p = p1 @ p2 @ p3\<close> 
     by auto
   have "path M (target (initial M) p1) p2" 
     using path_suffix[of M "initial M" p1 p2, OF path_prefix[of M "initial M" "p1@p2" p3, OF \<open>path M (initial M) ((p1@p2)@p3)\<close>]] 
     by assumption
   have "target (target (initial M) p1) p2 = (target (initial M) p1)"
     using path_append_target \<open>target (initial M) p1 = target (initial M) (p1 @ p2)\<close> 
     by auto
   
   have "path M (initial M) (p1 @ (concat (replicate n p2)) @ p3)"  
   proof (induction n)
     case 0 
     then show ?case 
       using path_append[OF \<open>path M (initial M) p1\<close> \<open>path M (target (initial M) p1) p3\<close>]  
       by auto
   next
     case (Suc n)
     then show ?case
       using \<open>path M (target (initial M) p1) p2\<close> \<open>target (target (initial M) p1) p2 = target (initial M) p1\<close> 
       by auto 
   qed
   moreover have "length (p1 @ (concat (replicate n p2)) @ p3) \<ge> n"
   proof -
     have "length (concat (replicate n p2)) = n * (length p2)" 
       using concat_replicate_length by metis
     moreover have "length p2 > 0"
       using \<open>p2 \<noteq> []\<close> by auto
     ultimately have "length (concat (replicate n p2)) \<ge> n"
       by (simp add: Suc_leI)
     then show ?thesis by auto
   qed
   ultimately show "\<exists> p . path M (initial M) p \<and> length p \<ge> n" by blast
 qed
 
 
 lemma cyclic_path_shortening : 
   assumes "path M q p"
   and     "\<not> distinct (visited_states q p)"
 shows "\<exists> p' . path M q p' \<and> target q p' = target q p \<and> length p' < length p"
 proof -
   obtain p1 p2 p3 where *: "p = p1@p2@p3 \<and> p2 \<noteq> [] \<and> target q p1 = target q (p1@p2)" 
     using cyclic_path_loop[OF assms] by blast
   then have "path M q (p1@p3)"
     using assms(1) by force
   moreover have "target q (p1@p3) = target q p"
     by (metis (full_types) * path_append_target)
   moreover have "length (p1@p3) < length p"
     using * by auto
   ultimately show ?thesis by blast
 qed
 
 
 lemma acyclic_path_from_cyclic_path :
   assumes "path M q p"
   and     "\<not> distinct (visited_states q p)"
 obtains p' where "path M q p'" and "target q p = target q p'" and "distinct (visited_states q p')"
 proof -
   
   let ?paths = "{p' . (path M q p' \<and> target q p' = target q p \<and> length p' \<le> length p)}"
   let ?minPath = "arg_min length (\<lambda> io . io \<in> ?paths)" 
   
   have "?paths \<noteq> empty" 
     using assms(1) by auto
   moreover have "finite ?paths" 
     using paths_finite[of M q "length p"]
     by (metis (no_types, lifting) Collect_mono rev_finite_subset)
   ultimately have minPath_def : "?minPath \<in> ?paths \<and> (\<forall> p' \<in> ?paths . length ?minPath \<le> length p')" 
     by (meson arg_min_nat_lemma equals0I)
   then have "path M q ?minPath" and "target q ?minPath = target q p" 
     by auto
   
   moreover have "distinct (visited_states q ?minPath)"
   proof (rule ccontr)
     assume "\<not> distinct (visited_states q ?minPath)"
     have "\<exists> p' . path M q p' \<and> target q p' = target q p \<and> length p' < length ?minPath" 
       using cyclic_path_shortening[OF \<open>path M q ?minPath\<close> \<open>\<not> distinct (visited_states q ?minPath)\<close>] minPath_def
             \<open>target q ?minPath= target q p\<close> by auto
     then show "False" 
       using minPath_def using arg_min_nat_le dual_order.strict_trans1 by auto 
   qed
 
   ultimately show ?thesis
     by (simp add: that)
 qed    
 
 
 lemma acyclic_path_length_limit :
   assumes "path M q p"
   and     "distinct (visited_states q p)"
 shows "length p < size M"
 proof (rule ccontr)
   assume *: "\<not> length p < size M"
   then have "length p \<ge> card (states M)"
     using size_def by auto
   then have "length (visited_states q p) > card (states M)"
     by auto
   moreover have "set (visited_states q p) \<subseteq> states M"
     by (metis assms(1) path_prefix path_target_is_state subsetI visited_states_prefix)
   ultimately have "\<not> distinct (visited_states q p)"
     using distinct_card[OF assms(2)] 
     using List.finite_set[of "visited_states q p"]
     by (metis card_mono fsm_states_finite leD) 
   then show "False" using assms(2) by blast
 qed
 
 
 
 
 
 subsection \<open>Reachable States\<close>
 
 definition reachable :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where
   "reachable M q = (\<exists> p . path M (initial M) p \<and> target (initial M) p = q)"
 
 definition reachable_states :: "('a,'b,'c) fsm \<Rightarrow> 'a set" where
   "reachable_states M  = {target (initial M) p | p . path M (initial M) p }"
 
 abbreviation "size_r M \<equiv> card (reachable_states M)"
 
 lemma acyclic_paths_set :
   "acyclic_paths_up_to_length M q (size M - 1) = {p . path M q p \<and> distinct (visited_states q p)}"
   unfolding acyclic_paths_up_to_length.simps using acyclic_path_length_limit[of M q]
   by (metis (no_types, lifting) One_nat_def Suc_pred cyclic_path_shortening leD list.size(3) 
        not_less_eq_eq not_less_zero path.intros(1) path_begin_state) 
 
 
 (* inefficient calculation, as a state may be target of a large number of acyclic paths *)
 lemma reachable_states_code[code] : 
   "reachable_states M = image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
 proof -
   have "\<And> q' . q' \<in> reachable_states M 
             \<Longrightarrow> q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
   proof -
     fix q' assume "q' \<in> reachable_states M"
     then obtain p where "path M (initial M) p" and "target (initial M) p = q'"
       unfolding reachable_states_def by blast
     
     obtain p' where "path M (initial M) p'" and "target (initial M) p' = q'" 
                 and "distinct (visited_states (initial M) p')"
     proof (cases "distinct (visited_states (initial M) p)")
       case True
       then show ?thesis using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q'\<close> that by auto
     next
       case False
       then show ?thesis 
         using acyclic_path_from_cyclic_path[OF \<open>path M (initial M) p\<close>] 
         unfolding \<open>target (initial M) p = q'\<close> using that by blast
     qed
     then show "q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
       unfolding acyclic_paths_set by force
   qed
   moreover have "\<And> q' . q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1)) 
                     \<Longrightarrow> q' \<in> reachable_states M"
     unfolding reachable_states_def acyclic_paths_set by blast
   ultimately show ?thesis by blast
 qed
 
 
 
 lemma reachable_states_intro[intro!] :
   assumes "path M (initial M) p"
   shows "target (initial M) p \<in> reachable_states M"
   using assms unfolding reachable_states_def by auto
 
 
 lemma reachable_states_initial :
   "initial M \<in> reachable_states M"
   unfolding reachable_states_def by auto
 
 
 lemma reachable_states_next : 
   assumes "q \<in> reachable_states M" and "t \<in> transitions M" and "t_source t = q" 
   shows "t_target t \<in> reachable_states M" 
 proof -
   from \<open>q \<in> reachable_states M\<close> obtain p where * :"path M (initial M) p"
                                         and   **:"target (initial M) p = q"
     unfolding reachable_states_def by auto
 
   then have "path M (initial M) (p@[t])" using assms(2,3) path_append_transition by metis
   moreover have "target (initial M) (p@[t]) = t_target t" by auto
   ultimately show ?thesis 
     unfolding reachable_states_def
     by (metis (mono_tags, lifting) mem_Collect_eq)
 qed
 
 
 lemma reachable_states_path :
   assumes "q \<in> reachable_states M"
   and     "path M q p"
   and     "t \<in> set p"
 shows "t_source t \<in> reachable_states M"
 using assms unfolding reachable_states_def proof (induction p arbitrary: q)
   case Nil
   then show ?case by auto
 next
   case (Cons t' p')
   then show ?case proof (cases "t = t'")
     case True
     then show ?thesis using Cons.prems(1,2) by force
   next
     case False then show ?thesis using Cons
       by (metis (mono_tags, lifting) path_cons_elim reachable_states_def reachable_states_next 
             set_ConsD) 
   qed
 qed
 
 
 lemma reachable_states_initial_or_target :
   assumes "q \<in> reachable_states M"
   shows "q = initial M \<or> (\<exists> t \<in> transitions M . t_source t \<in> reachable_states M \<and> t_target t = q)"
 proof -
   obtain p where "path M (initial M) p" and "target (initial M) p = q"
     using assms unfolding reachable_states_def by auto 
   
   show ?thesis proof (cases p rule: rev_cases)
     case Nil
     then show ?thesis using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q\<close> by auto
   next
     case (snoc p' t)
     
     have "t \<in> transitions M"
       using \<open>path M (initial M) p\<close> unfolding snoc by auto
     moreover have "t_target t = q"
       using \<open>target (initial M) p = q\<close> unfolding snoc by auto
     moreover have "t_source t \<in> reachable_states M"
       using \<open>path M (initial M) p\<close> unfolding snoc
       by (metis append_is_Nil_conv last_in_set last_snoc not_Cons_self2 reachable_states_initial reachable_states_path) 
 
     ultimately show ?thesis
       by blast 
   qed 
 qed
 
 lemma reachable_state_is_state : 
   "q \<in> reachable_states M \<Longrightarrow> q \<in> states M" 
   unfolding reachable_states_def using path_target_is_state by fastforce 
 
 lemma reachable_states_finite : "finite (reachable_states M)"
   using fsm_states_finite[of M] reachable_state_is_state[of _ M]
   by (meson finite_subset subset_eq)  
 
 
 subsection \<open>Language\<close>
 
 abbreviation "p_io (p :: ('state,'input,'output) path) \<equiv> map (\<lambda> t . (t_input t, t_output t)) p"
 
 fun language_state_for_input :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input list \<Rightarrow> ('input \<times> 'output) list set" where
   "language_state_for_input M q xs = {p_io p | p . path M q p \<and> map fst (p_io p) = xs}"
 
 fun LS\<^sub>i\<^sub>n :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input list set \<Rightarrow> ('input \<times> 'output) list set" where
   "LS\<^sub>i\<^sub>n M q xss = {p_io p | p . path M q p \<and> map fst (p_io p) \<in> xss}"
 
 abbreviation(input) "L\<^sub>i\<^sub>n M \<equiv> LS\<^sub>i\<^sub>n M (initial M)"
 
 lemma language_state_for_input_inputs : 
   assumes "io \<in> language_state_for_input M q xs"
   shows "map fst io = xs" 
   using assms by auto
 
 lemma language_state_for_inputs_inputs : 
   assumes "io \<in> LS\<^sub>i\<^sub>n M q xss"
   shows "map fst io \<in> xss" using assms by auto 
 
 
 fun LS :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> ('input \<times> 'output) list set" where
   "LS M q = { p_io p | p . path M q p }"
 
 abbreviation "L M \<equiv> LS M (initial M)"
 
 lemma language_state_containment :
   assumes "path M q p"
   and     "p_io p = io"
 shows "io \<in> LS M q"
   using assms by auto
 
 lemma language_prefix : 
   assumes "io1@io2 \<in> LS M q"
   shows "io1 \<in> LS M q"
 proof -
   obtain p where "path M q p" and "p_io p = io1@io2" 
     using assms by auto
   let ?tp = "take (length io1) p"
   have "path M q ?tp"
     by (metis (no_types) \<open>path M q p\<close> append_take_drop_id path_prefix) 
   moreover have "p_io ?tp = io1"
     using \<open>p_io p = io1@io2\<close> by (metis append_eq_conv_conj take_map) 
   ultimately show ?thesis
     by force 
 qed
 
 lemma language_contains_empty_sequence : "[] \<in> L M" 
   by auto
 
 
 lemma language_state_split :
   assumes "io1 @ io2 \<in> LS M q1"
   obtains  p1 p2 where "path M q1 p1" 
                    and "path M (target q1 p1) p2"  
                    and "p_io p1 = io1" 
                    and "p_io p2 = io2"
 proof -
   obtain p12 where "path M q1 p12" and "p_io p12 = io1 @ io2"
     using assms unfolding LS.simps by auto
 
   let ?p1 = "take (length io1) p12"
   let ?p2 = "drop (length io1) p12"
 
   have "p12 = ?p1 @ ?p2" 
     by auto
   then have "path M q1 (?p1 @ ?p2)"
     using \<open>path M q1 p12\<close> by auto
 
   have "path M q1 ?p1" and "path M (target q1 ?p1) ?p2"
     using path_append_elim[OF \<open>path M q1 (?p1 @ ?p2)\<close>] by blast+
   moreover have "p_io ?p1 = io1"
     using \<open>p12 = ?p1 @ ?p2\<close> \<open>p_io p12 = io1 @ io2\<close>
     by (metis append_eq_conv_conj take_map)
   moreover have "p_io ?p2 = io2"
     using \<open>p12 = ?p1 @ ?p2\<close> \<open>p_io p12 = io1 @ io2\<close>
     by (metis (no_types) \<open>p_io p12 = io1 @ io2\<close> append_eq_conv_conj drop_map) 
   ultimately show ?thesis using that by blast
 qed
 
 
 lemma language_initial_path_append_transition :
   assumes "ios @ [io] \<in> L M"
   obtains p t where "path M (initial M) (p@[t])" and "p_io (p@[t]) = ios @ [io]"
 proof -
   obtain pt where "path M (initial M) pt" and "p_io pt = ios @ [io]"
     using assms unfolding LS.simps by auto
   then have "pt \<noteq> []"
     by auto
   then obtain p t where "pt = p @ [t]"
     using rev_exhaust by blast  
   then have "path M (initial M) (p@[t])" and "p_io (p@[t]) = ios @ [io]"
     using \<open>path M (initial M) pt\<close> \<open>p_io pt = ios @ [io]\<close> by auto
   then show ?thesis using that by simp
 qed
 
 lemma language_path_append_transition :
   assumes "ios @ [io] \<in> LS M q"
   obtains p t where "path M q (p@[t])" and "p_io (p@[t]) = ios @ [io]"
 proof -
   obtain pt where "path M q pt" and "p_io pt = ios @ [io]"
     using assms unfolding LS.simps by auto
   then have "pt \<noteq> []"
     by auto
   then obtain p t where "pt = p @ [t]"
     using rev_exhaust by blast  
   then have "path M q (p@[t])" and "p_io (p@[t]) = ios @ [io]"
     using \<open>path M q pt\<close> \<open>p_io pt = ios @ [io]\<close> by auto
   then show ?thesis using that by simp
 qed
 
 
 lemma language_split :
   assumes "io1@io2 \<in> L M"
   obtains p1 p2 where "path M (initial M) (p1@p2)" and "p_io p1 = io1" and "p_io p2 = io2"
 proof -
   from assms obtain p where "path M (initial M) p" and "p_io p = io1 @ io2"
     by auto
 
   let ?p1 = "take (length io1) p"
   let ?p2 = "drop (length io1) p"
 
   have "path M (initial M) (?p1@?p2)"
     using \<open>path M (initial M) p\<close> by simp 
   moreover have "p_io ?p1 = io1" 
     using \<open>p_io p = io1 @ io2\<close>
     by (metis append_eq_conv_conj take_map) 
   moreover have "p_io ?p2 = io2" 
     using \<open>p_io p = io1 @ io2\<close>
     by (metis append_eq_conv_conj drop_map)
   ultimately show ?thesis using that by blast
 qed
 
 
 
 lemma language_io : 
   assumes "io \<in> LS M q"
   and     "(x,y) \<in> set io"
 shows "x \<in> (inputs M)"
 and   "y \<in> outputs M"
 proof -
   obtain p where "path M q p" and "p_io p = io"
     using \<open>io \<in> LS M q\<close> by auto
   then obtain t where "t \<in> set p" and "t_input t = x" and "t_output t = y"
     using \<open>(x,y) \<in> set io\<close> by auto
   
   have "t \<in> transitions M"
     using \<open>path M q p\<close> \<open>t \<in> set p\<close>
     by (induction p; auto)
 
   show "x \<in> (inputs M)"
     using \<open>t \<in> transitions M\<close> \<open>t_input t = x\<close> by auto
 
   show "y \<in> outputs M"
     using \<open>t \<in> transitions M\<close> \<open>t_output t = y\<close> by auto
 qed
 
 
 lemma path_io_split :
   assumes "path M q p"
   and     "p_io p = io1@io2"
 shows "path M q (take (length io1) p)"
 and   "p_io (take (length io1) p) = io1"
 and   "path M (target q (take (length io1) p)) (drop (length io1) p)"
 and   "p_io (drop (length io1) p) = io2"
 proof -
   have "length io1 \<le> length p"
     using \<open>p_io p = io1@io2\<close> 
     unfolding length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric]
     by auto
 
   have "p = (take (length io1) p)@(drop (length io1) p)"
     by simp
   then have *: "path M q ((take (length io1) p)@(drop (length io1) p))"
     using \<open>path M q p\<close> by auto
 
   show "path M q (take (length io1) p)"
        and  "path M (target q (take (length io1) p)) (drop (length io1) p)"
     using path_append_elim[OF *] by blast+
 
   show "p_io (take (length io1) p) = io1"
     using \<open>p = (take (length io1) p)@(drop (length io1) p)\<close> \<open>p_io p = io1@io2\<close>
     by (metis append_eq_conv_conj take_map) 
 
   show "p_io (drop (length io1) p) = io2"
     using \<open>p = (take (length io1) p)@(drop (length io1) p)\<close> \<open>p_io p = io1@io2\<close>
     by (metis append_eq_conv_conj drop_map)
 qed
 
 
 lemma language_intro :
   assumes "path M q p"
   shows "p_io p \<in> LS M q"
   using assms unfolding LS.simps by auto
 
 
 lemma language_prefix_append :
   assumes "io1 @ (p_io p) \<in> L M"
 shows   "io1 @ p_io (take i p) \<in> L M"
 proof -
   fix i
   have "p_io p = (p_io (take i p)) @ (p_io (drop i p))"
     by (metis append_take_drop_id map_append) 
   then have "(io1 @ (p_io (take i p))) @ (p_io (drop i p)) \<in> L M"
     using \<open>io1 @ p_io p \<in> L M\<close> by auto
   show "io1 @ p_io (take i p) \<in> L M" 
     using language_prefix[OF \<open>(io1 @ (p_io (take i p))) @ (p_io (drop i p)) \<in> L M\<close>] 
     by assumption
 qed
 
 
 lemma language_finite: "finite {io . io \<in> L M \<and> length io \<le> k}"
 proof -
   have "{io . io \<in> L M \<and> length io \<le> k} \<subseteq> p_io  ` {p. path M (FSM.initial M) p \<and> length p \<le> k}"
     by auto
   then show ?thesis
     using paths_finite[of M "initial M" k]
     using finite_surj by auto 
 qed
 
 lemma LS_prepend_transition : 
   assumes "t \<in> transitions M"
   and     "io \<in> LS M (t_target t)"
 shows "(t_input t, t_output t) # io \<in> LS M (t_source t)"
 proof -
   obtain p where "path M (t_target t) p" and "p_io p = io"
     using assms(2) by auto
   then have "path M (t_source t) (t#p)" and "p_io (t#p) = (t_input t, t_output t) # io"
     using assms(1) by auto
   then show ?thesis 
     unfolding LS.simps
     by (metis (mono_tags, lifting) mem_Collect_eq) 
 qed
 
 lemma language_empty_IO :
   assumes "inputs M = {} \<or> outputs M = {}"
   shows "L M = {[]}"
 proof -
   consider "inputs M = {}" | "outputs M = {}" using assms by blast
   then show ?thesis proof cases
     case 1
 
     show "L M = {[]}"
       using language_io(1)[of _ M "initial M"] unfolding 1
       by (metis (no_types, opaque_lifting) ex_in_conv is_singletonI' is_singleton_the_elem language_contains_empty_sequence set_empty2 singleton_iff surj_pair) 
   next
     case 2
     show "L M = {[]}"
       using language_io(2)[of _ M "initial M"] unfolding 2
       by (metis (no_types, opaque_lifting) ex_in_conv is_singletonI' is_singleton_the_elem language_contains_empty_sequence set_empty2 singleton_iff surj_pair) 
   qed
 qed
 
 lemma language_equivalence_from_isomorphism_helper :
   assumes "bij_betw f (states M1) (states M2)"
   and     "f (initial M1) = initial M2"
   and     "\<And> q x y q' . q \<in> states M1 \<Longrightarrow> q' \<in> states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
   and     "q \<in> states M1"
 shows "LS M1 q \<subseteq> LS M2 (f q)"
 proof 
   fix io assume "io \<in> LS M1 q"
 
   then obtain p where "path M1 q p" and "p_io p = io"
     by auto
 
   let ?f = "\<lambda>(q,x,y,q') . (f q,x,y,f q')"
   let ?p = "map ?f p"
 
   have "f q \<in> states M2"
     using assms(1,4)
     using bij_betwE by auto 
 
   have "path M2 (f q) ?p"
   using \<open>path M1 q p\<close> proof (induction p rule: rev_induct)
     case Nil
     show ?case using \<open>f q \<in> states M2\<close> by auto
   next
     case (snoc a p)
     then have "path M2 (f q) (map ?f p)"
       by auto
 
     have "target (f q) (map ?f p) = f (target q p)"
       using \<open>f (initial M1) = initial M2\<close> assms(2)
       by (induction p; auto)
     then have "t_source (?f a) = target (f q) (map ?f p)"
       by (metis (no_types, lifting) case_prod_beta' fst_conv path_append_transition_elim(3) snoc.prems)
   
     have "a \<in> transitions M1"
       using snoc.prems by auto
     then have "?f a \<in> transitions M2"
       by (metis (mono_tags, lifting) assms(3) case_prod_beta fsm_transition_source fsm_transition_target surjective_pairing)
       
     have "map ?f (p@[a]) = (map ?f p)@[?f a]"
       by auto
 
     show ?case 
       unfolding \<open>map ?f (p@[a]) = (map ?f p)@[?f a]\<close>
       using path_append_transition[OF \<open>path M2 (f q) (map ?f p)\<close> \<open>?f a \<in> transitions M2\<close> \<open>t_source (?f a) = target (f q) (map ?f p)\<close>]
       by assumption
   qed
   moreover have "p_io ?p = io"
     using \<open>p_io p = io\<close>
     by (induction p; auto)
   ultimately show "io \<in> LS M2 (f q)"
     using language_state_containment by fastforce
 qed
 
 
 lemma language_equivalence_from_isomorphism :
   assumes "bij_betw f (states M1) (states M2)"
   and     "f (initial M1) = initial M2"
   and     "\<And> q x y q' . q \<in> states M1 \<Longrightarrow> q' \<in> states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
   and     "q \<in> states M1"
 shows "LS M1 q = LS M2 (f q)"
 proof 
   show "LS M1 q \<subseteq> LS M2 (f q)"
     using language_equivalence_from_isomorphism_helper[OF assms] .
 
   have "f q \<in> states M2"
     using assms(1,4)
     using bij_betwE by auto 
   have "(inv_into (FSM.states M1) f (f q)) = q"
     by (meson assms(1) assms(4) bij_betw_imp_inj_on inv_into_f_f) 
 
 
   have "bij_betw (inv_into (states M1) f) (states M2) (states M1)"
     using bij_betw_inv_into[OF assms(1)] .
   moreover have "(inv_into (states M1) f) (initial M2) = (initial M1)"
     using assms(1,2)
     by (metis bij_betw_inv_into_left fsm_initial) 
   moreover have "\<And> q x y q' . q \<in> states M2 \<Longrightarrow> q' \<in> states M2 \<Longrightarrow> (q,x,y,q') \<in> transitions M2 \<longleftrightarrow> ((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1"
   proof 
     fix q x y q' assume "q \<in> states M2" and "q' \<in> states M2"
     
     show "(q,x,y,q') \<in> transitions M2 \<Longrightarrow> ((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1"
     proof -
       assume a1: "(q, x, y, q') \<in> FSM.transitions M2"
       have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
         using bij_betwE by blast
       then have f3: "inv_into (states M1) f q \<in> states M1"
         using \<open>q \<in> states M2\<close> calculation(1) by blast
       have "inv_into (states M1) f q' \<in> states M1"
         using f2 \<open>q' \<in> states M2\<close> calculation(1) by blast
       then show ?thesis
         using f3 a1 \<open>q \<in> states M2\<close> \<open>q' \<in> states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
     qed
 
     show "((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M2"
     proof -
       assume a1: "(inv_into (states M1) f q, x, y, inv_into (states M1) f q') \<in> FSM.transitions M1"
       have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
         by (metis (full_types) bij_betwE)
       then have f3: "inv_into (states M1) f q' \<in> states M1"
         using \<open>q' \<in> states M2\<close> calculation(1) by blast
       have "inv_into (states M1) f q \<in> states M1"
         using f2 \<open>q \<in> states M2\<close> calculation(1) by blast
       then show ?thesis
         using f3 a1 \<open>q \<in> states M2\<close> \<open>q' \<in> states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
     qed
   qed
   ultimately show "LS M2 (f q) \<subseteq> LS M1 q"
     using language_equivalence_from_isomorphism_helper[of "(inv_into (states M1) f)" M2 M1, OF _ _ _ \<open>f q \<in> states M2\<close>]
     unfolding \<open>(inv_into (FSM.states M1) f (f q)) = q\<close>
     by blast
 qed
 
 
 
 lemma language_equivalence_from_isomorphism_helper_reachable :
   assumes "bij_betw f (reachable_states M1) (reachable_states M2)"
   and     "f (initial M1) = initial M2"
   and     "\<And> q x y q' . q \<in> reachable_states M1 \<Longrightarrow> q' \<in> reachable_states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
 shows "L M1 \<subseteq> L M2"
 proof 
   fix io assume "io \<in> L M1"
 
   then obtain p where "path M1 (initial M1) p" and "p_io p = io"
     by auto
 
   let ?f = "\<lambda>(q,x,y,q') . (f q,x,y,f q')"
   let ?p = "map ?f p"
 
   have "path M2 (initial M2) ?p"
   using \<open>path M1 (initial M1) p\<close> proof (induction p rule: rev_induct)
     case Nil
     then show ?case by auto
   next
     case (snoc a p)
     then have "path M2 (initial M2) (map ?f p)"
       by auto
 
     have "target (initial M2) (map ?f p) = f (target (initial M1) p)"
       using \<open>f (initial M1) = initial M2\<close> assms(2)
       by (induction p; auto)
     then have "t_source (?f a) = target (initial M2) (map ?f p)"
       by (metis (no_types, lifting) case_prod_beta' fst_conv path_append_transition_elim(3) snoc.prems)
       
 
     have "t_source a \<in> reachable_states M1"
       using \<open>path M1 (FSM.initial M1) (p @ [a])\<close>
       by (metis path_append_transition_elim(3) path_prefix reachable_states_intro) 
     have "t_target a \<in> reachable_states M1"
       using \<open>path M1 (FSM.initial M1) (p @ [a])\<close>
       by (meson \<open>t_source a \<in> reachable_states M1\<close> path_append_transition_elim(2) reachable_states_next) 
 
     have "a \<in> transitions M1"
       using snoc.prems by auto
     then have "?f a \<in> transitions M2"
       using assms(3)[OF \<open>t_source a \<in> reachable_states M1\<close> \<open>t_target a \<in> reachable_states M1\<close>]
       by (metis (mono_tags, lifting) prod.case_eq_if prod.collapse)
       
     have "map ?f (p@[a]) = (map ?f p)@[?f a]"
       by auto
 
     show ?case 
       unfolding \<open>map ?f (p@[a]) = (map ?f p)@[?f a]\<close>
       using path_append_transition[OF \<open>path M2 (initial M2) (map ?f p)\<close> \<open>?f a \<in> transitions M2\<close> \<open>t_source (?f a) = target (initial M2) (map ?f p)\<close>]
       by assumption
   qed
   moreover have "p_io ?p = io"
     using \<open>p_io p = io\<close>
     by (induction p; auto)
   ultimately show "io \<in> L M2"
     using language_state_containment by fastforce
 qed
     
 
 
 lemma language_equivalence_from_isomorphism_reachable :
   assumes "bij_betw f (reachable_states M1) (reachable_states M2)"
   and     "f (initial M1) = initial M2"
   and     "\<And> q x y q' . q \<in> reachable_states M1 \<Longrightarrow> q' \<in> reachable_states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
 shows "L M1 = L M2"
 proof 
   show "L M1 \<subseteq> L M2"
     using language_equivalence_from_isomorphism_helper_reachable[OF assms] .
 
   have "bij_betw (inv_into (reachable_states M1) f) (reachable_states M2) (reachable_states M1)"
     using bij_betw_inv_into[OF assms(1)] .
   moreover have "(inv_into (reachable_states M1) f) (initial M2) = (initial M1)"
     using assms(1,2) reachable_states_initial
     by (metis bij_betw_inv_into_left) 
   moreover have "\<And> q x y q' . q \<in> reachable_states M2 \<Longrightarrow> q' \<in> reachable_states M2 \<Longrightarrow> (q,x,y,q') \<in> transitions M2 \<longleftrightarrow> ((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1"
   proof 
     fix q x y q' assume "q \<in> reachable_states M2" and "q' \<in> reachable_states M2"
     
     show "(q,x,y,q') \<in> transitions M2 \<Longrightarrow> ((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1"
     proof -
       assume a1: "(q, x, y, q') \<in> FSM.transitions M2"
       have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
         using bij_betwE by blast
       then have f3: "inv_into (FSM.reachable_states M1) f q \<in> FSM.reachable_states M1"
         using \<open>q \<in> FSM.reachable_states M2\<close> calculation(1) by blast
       have "inv_into (FSM.reachable_states M1) f q' \<in> FSM.reachable_states M1"
         using f2 \<open>q' \<in> FSM.reachable_states M2\<close> calculation(1) by blast
       then show ?thesis
         using f3 a1 \<open>q \<in> FSM.reachable_states M2\<close> \<open>q' \<in> FSM.reachable_states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
     qed
 
     show "((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M2"
     proof -
       assume a1: "(inv_into (FSM.reachable_states M1) f q, x, y, inv_into (FSM.reachable_states M1) f q') \<in> FSM.transitions M1"
       have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
         by (metis (full_types) bij_betwE)
       then have f3: "inv_into (FSM.reachable_states M1) f q' \<in> FSM.reachable_states M1"
         using \<open>q' \<in> FSM.reachable_states M2\<close> calculation(1) by blast
       have "inv_into (FSM.reachable_states M1) f q \<in> FSM.reachable_states M1"
         using f2 \<open>q \<in> FSM.reachable_states M2\<close> calculation(1) by blast
       then show ?thesis
         using f3 a1 \<open>q \<in> FSM.reachable_states M2\<close> \<open>q' \<in> FSM.reachable_states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
     qed
   qed
   ultimately show "L M2 \<subseteq> L M1"
     using language_equivalence_from_isomorphism_helper_reachable[of "(inv_into (reachable_states M1) f)" M2 M1]
     by blast
 qed
 
 lemma language_empty_io :
   assumes "inputs M = {} \<or> outputs M = {}"
   shows "L M = {[]}"
 proof -
   have "transitions M = {}"
     using assms fsm_transition_input fsm_transition_output
     by auto
   then have "\<And> p . path M (initial M) p \<Longrightarrow> p = []"
     by (metis empty_iff path.cases)
   then show ?thesis 
     unfolding LS.simps
     by blast
 qed
 
 
 
 subsection \<open>Basic FSM Properties\<close>
 
 subsubsection \<open>Completely Specified\<close>
 
 fun completely_specified :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x)"
 
 
 lemma completely_specified_alt_def : 
   "completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . \<exists> q' y . (q,x,y,q') \<in> transitions M)"
   by force
 
 lemma completely_specified_alt_def_h : 
   "completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . h M (q,x) \<noteq> {})"
   by force
 
 
 
 fun completely_specified_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where
   "completely_specified_state M q = (\<forall> x \<in> inputs M . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x)"
 
 lemma completely_specified_states :
   "completely_specified M = (\<forall> q \<in> states M . completely_specified_state M q)"
   unfolding completely_specified.simps completely_specified_state.simps by force
 
 lemma completely_specified_state_alt_def_h : 
   "completely_specified_state M q = (\<forall> x \<in> inputs M . h M (q,x) \<noteq> {})"
   by force
 
 
 lemma completely_specified_path_extension : 
   assumes "completely_specified M"
   and     "q \<in> states M"
   and     "path M q p"
   and     "x \<in> (inputs M)"
 obtains t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
 proof -
   have "target q p \<in> states M"
     using path_target_is_state \<open>path M q p\<close> by metis
   then obtain t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
     using \<open>completely_specified M\<close> \<open>x \<in> (inputs M)\<close> 
     unfolding completely_specified.simps by blast
   then show ?thesis using that by blast
 qed
 
 
 lemma completely_specified_language_extension :
   assumes "completely_specified M"
   and     "q \<in> states M"
   and     "io \<in> LS M q"
   and     "x \<in> (inputs M)"
 obtains y where "io@[(x,y)] \<in> LS M q"
 proof -
   obtain p where "path M q p" and "p_io p = io"
     using \<open>io \<in> LS M q\<close> by auto
   
   moreover obtain t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
     using completely_specified_path_extension[OF assms(1,2) \<open>path M q p\<close> assms(4)] by blast
 
   ultimately have "path M q (p@[t])" and "p_io (p@[t]) = io@[(x,t_output t)]"
     by (simp add: path_append_transition)+
     
   then have "io@[(x,t_output t)] \<in> LS M q"
     using language_state_containment[of M q "p@[t]" "io@[(x,t_output t)]"] by auto
   then show ?thesis using that by blast
 qed
   
 
 lemma path_of_length_ex :
   assumes "completely_specified M"
   and     "q \<in> states M"
   and     "inputs M \<noteq> {}"
 shows "\<exists> p . path M q p \<and> length p = k" 
 using assms(2) proof (induction k arbitrary: q)
   case 0
   then show ?case by auto
 next
   case (Suc k)
 
   obtain t where "t_source t = q" and "t \<in> transitions M"
     by (meson Suc.prems assms(1) assms(3) completely_specified.simps equals0I)
   then have "t_target t \<in> states M"
     using fsm_transition_target by blast
   then obtain p where "path M (t_target t) p \<and> length p = k"
     using Suc.IH by blast
   then show ?case 
     using \<open>t_source t = q\<close> \<open>t \<in> transitions M\<close>
     by auto 
 qed
 
 
 subsubsection \<open>Deterministic\<close>
 
 fun deterministic :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "deterministic M = (\<forall> t1 \<in> transitions M . 
                         \<forall> t2 \<in> transitions M . 
                           (t_source t1 = t_source t2 \<and> t_input t1 = t_input t2) 
                           \<longrightarrow> (t_output t1 = t_output t2 \<and> t_target t1 = t_target t2))" 
 
 lemma deterministic_alt_def : 
   "deterministic M = (\<forall> q1 x y' y''  q1' q1'' . (q1,x,y',q1') \<in> transitions M \<and> (q1,x,y'',q1'') \<in> transitions M \<longrightarrow> y' = y'' \<and> q1' = q1'')" 
   by auto
 
 lemma deterministic_alt_def_h : 
   "deterministic M = (\<forall> q1 x yq yq' . (yq \<in> h M (q1,x) \<and> yq' \<in> h M (q1,x)) \<longrightarrow> yq = yq')"
   by auto
 
 
 
 subsubsection \<open>Observable\<close>
 
 fun observable :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "observable M = (\<forall> t1 \<in> transitions M . 
                     \<forall> t2 \<in> transitions M . 
                       (t_source t1 = t_source t2 \<and> t_input t1 = t_input t2 \<and> t_output t1 = t_output t2) 
                         \<longrightarrow> t_target t1 = t_target t2)" 
 
 lemma observable_alt_def : 
   "observable M = (\<forall> q1 x y q1' q1'' . (q1,x,y,q1') \<in> transitions M \<and> (q1,x,y,q1'') \<in> transitions M \<longrightarrow> q1' = q1'')" 
   by auto
 
 lemma observable_alt_def_h : 
   "observable M = (\<forall> q1 x yq yq' . (yq \<in> h M (q1,x) \<and> yq' \<in> h M (q1,x)) \<longrightarrow> fst yq = fst yq' \<longrightarrow> snd yq = snd yq')"
   by auto
 
 
 lemma language_append_path_ob :
   assumes "io@[(x,y)] \<in> L M"
   obtains p t where "path M (initial M) (p@[t])" and "p_io p = io" and "t_input t = x" and "t_output t = y"
 proof -
   obtain p p2 where "path M (initial M) p" and "path M (target (initial M) p) p2"  and "p_io p = io" and "p_io p2 = [(x,y)]"
     using language_state_split[OF assms] by blast
 
   obtain t where "p2 = [t]" and "t_input t = x" and "t_output t = y"
     using \<open>p_io p2 = [(x,y)]\<close> by auto
 
   have "path M (initial M) (p@[t])"
     using \<open>path M (initial M) p\<close> \<open>path M (target (initial M) p) p2\<close> unfolding \<open>p2 = [t]\<close> by auto
   then show ?thesis using that[OF _ \<open>p_io p = io\<close> \<open>t_input t = x\<close> \<open>t_output t = y\<close>]
     by simp 
 qed
 
 
 subsubsection \<open>Single Input\<close>
 
 (* each state has at most one input, but may have none *)
 fun single_input :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "single_input M = (\<forall> t1 \<in> transitions M . 
                       \<forall> t2 \<in> transitions M . 
                         t_source t1 = t_source t2 \<longrightarrow> t_input t1 = t_input t2)" 
 
 
 lemma single_input_alt_def : 
   "single_input M = (\<forall> q1 x x' y y' q1' q1'' . (q1,x,y,q1') \<in> transitions M \<and> (q1,x',y',q1'') \<in> transitions M \<longrightarrow> x = x')"
   by fastforce
 
 lemma single_input_alt_def_h : 
   "single_input M = (\<forall> q x x' . (h M (q,x) \<noteq> {} \<and> h M (q,x') \<noteq> {}) \<longrightarrow> x = x')"
   by force
     
 
 subsubsection \<open>Output Complete\<close>
 
 fun output_complete :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "output_complete M = (\<forall> t \<in> transitions M . 
                           \<forall> y \<in> outputs M . 
                             \<exists> t' \<in> transitions M . t_source t = t_source t' \<and> 
                                                     t_input t = t_input t' \<and> 
                                                     t_output t' = y)" 
 
 lemma output_complete_alt_def : 
   "output_complete M = (\<forall> q x . (\<exists> y q' . (q,x,y,q') \<in> transitions M) \<longrightarrow> (\<forall> y \<in> (outputs M) . \<exists> q' . (q,x,y,q') \<in> transitions M))" 
   by force
 
 lemma output_complete_alt_def_h : 
   "output_complete M = (\<forall> q x . h M (q,x) \<noteq> {} \<longrightarrow> (\<forall> y \<in> outputs M . \<exists> q' . (y,q') \<in> h M (q,x)))"
   by force
 
 
 
 subsubsection \<open>Acyclic\<close>
 
 fun acyclic :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "acyclic M = (\<forall> p . path M (initial M) p \<longrightarrow> distinct (visited_states (initial M) p))"
 
 
 lemma visited_states_length : "length (visited_states q p) = Suc (length p)" by auto
 
 lemma visited_states_take : 
   "(take (Suc n) (visited_states q p)) = (visited_states q (take n p))"
 proof (induction p rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
   then show ?case by (cases "n \<le> length xs"; auto)
 qed
 
 
 (* very inefficient calculation *)
 lemma acyclic_code[code] : 
   "acyclic M = (\<not>(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) . 
                     \<exists> t \<in> transitions M . t_source t = target (initial M) p \<and> 
                                            t_target t \<in> set (visited_states (initial M) p)))"
 proof -
   have "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) . 
           \<exists> t \<in> transitions M . t_source t = target (initial M) p \<and> 
                 t_target t \<in> set (visited_states (initial M) p)) 
         \<Longrightarrow> \<not> FSM.acyclic M"
   proof -
     assume "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) . 
               \<exists> t \<in> transitions M . t_source t = target (initial M) p \<and> 
                                     t_target t \<in> set (visited_states (initial M) p))"
     then obtain p t where "path M (initial M) p"
                     and   "distinct (visited_states (initial M) p)"
                     and   "t \<in> transitions M"
                     and   "t_source t = target (initial M) p" 
                     and   "t_target t \<in> set (visited_states (initial M) p)"
       unfolding acyclic_paths_set by blast
     then have "path M (initial M) (p@[t])"
       by (simp add: path_append_transition) 
     moreover have "\<not> (distinct (visited_states (initial M) (p@[t])))"
       using \<open>t_target t \<in> set (visited_states (initial M) p)\<close> by auto
     ultimately show "\<not> FSM.acyclic M"
       by (meson acyclic.elims(2))
   qed
   moreover have "\<not> FSM.acyclic M \<Longrightarrow> 
                   (\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) . 
                     \<exists> t \<in> transitions M . t_source t = target (initial M) p \<and> 
                                           t_target t \<in> set (visited_states (initial M) p))"
   proof -
     assume "\<not> FSM.acyclic M"
     then obtain p where "path M (initial M) p"
                   and   "\<not> distinct (visited_states (initial M) p)"
       by auto
     then obtain n where "distinct (take (Suc n) (visited_states (initial M) p))"
                   and   "\<not> distinct (take (Suc (Suc n)) (visited_states (initial M) p))"
       using maximal_distinct_prefix by blast
     then have "distinct (visited_states (initial M) (take n p))"
          and   "\<not> distinct (visited_states (initial M)(take (Suc n) p))"
       unfolding visited_states_take by simp+
 
     then obtain p' t' where *: "take n p = p'"
                       and   **: "take (Suc n) p = p' @ [t']"
       by (metis Suc_less_eq \<open>\<not> distinct (visited_states (FSM.initial M) p)\<close> 
             le_imp_less_Suc not_less_eq_eq take_all take_hd_drop)
     
     have ***: "visited_states (FSM.initial M) (p' @ [t']) = (visited_states (FSM.initial M) p')@[t_target t']"
       by auto
 
     have "path M (initial M) p'"
       using * \<open>path M (initial M) p\<close>
       by (metis append_take_drop_id path_prefix)
     then have "p' \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
       using \<open>distinct (visited_states (initial M) (take n p))\<close>
       unfolding * acyclic_paths_set by blast
     moreover have "t' \<in> transitions M \<and> t_source t' = target (initial M) p'"
       using * ** \<open>path M (initial M) p\<close>
       by (metis append_take_drop_id path_append_elim path_cons_elim)
        
     moreover have "t_target t' \<in> set (visited_states (initial M) p')"
       using \<open>distinct (visited_states (initial M) (take n p))\<close> 
             \<open>\<not> distinct (visited_states (initial M)(take (Suc n) p))\<close>
       unfolding * ** *** by auto 
     ultimately show "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) . 
                       \<exists> t \<in> transitions M . t_source t = target (initial M) p \<and> 
                                             t_target t \<in> set (visited_states (initial M) p))"
       by blast
   qed
   ultimately show ?thesis by blast
 qed
 
 
 
 
 lemma acyclic_alt_def : "acyclic M = finite (L M)"
 proof 
   show "acyclic M \<Longrightarrow> finite (L M)"
   proof -
     assume "acyclic M"
     then have "{ p . path M (initial M) p} \<subseteq> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
       unfolding acyclic_paths_set by auto
     moreover have "finite (acyclic_paths_up_to_length M (initial M) (size M - 1))"
       unfolding acyclic_paths_up_to_length.simps using paths_finite[of M "initial M" "size M - 1"]
       by (metis (mono_tags, lifting) Collect_cong \<open>FSM.acyclic M\<close> acyclic.elims(2)) 
     ultimately have "finite { p . path M (initial M) p}"
       using finite_subset by blast
     then show "finite (L M)"
       unfolding LS.simps by auto
   qed
 
   show "finite (L M) \<Longrightarrow> acyclic M"
   proof (rule ccontr)
     assume "finite (L M)"
     assume "\<not> acyclic M"
     
     obtain max_io_len where "\<forall>io \<in> L M . length io < max_io_len"
       using finite_maxlen[OF \<open>finite (L M)\<close>] by blast
     then have "\<And> p . path M (initial M) p \<Longrightarrow> length p < max_io_len"
     proof -
       fix p assume "path M (initial M) p"
       show "length p < max_io_len"
       proof (rule ccontr)
         assume "\<not> length p < max_io_len"
         then have "\<not> length (p_io p) < max_io_len" by auto
         moreover have "p_io p \<in> L M"
           unfolding LS.simps using \<open>path M (initial M) p\<close> by blast
         ultimately show "False"
           using \<open>\<forall>io \<in> L M . length io < max_io_len\<close> by blast
       qed
     qed
 
     obtain p where "path M (initial M) p" and "\<not> distinct (visited_states (initial M) p)"
       using \<open>\<not> acyclic M\<close> unfolding acyclic.simps by blast
     then obtain pL where "path M (initial M) pL" and "max_io_len \<le> length pL"
       using cyclic_path_pumping[of M p max_io_len] by blast
     then show "False"
       using \<open>\<And> p . path M (initial M) p \<Longrightarrow> length p < max_io_len\<close>
       using not_le by blast 
   qed
 qed
 
 
 lemma acyclic_finite_paths_from_reachable_state :
   assumes "acyclic M"
   and     "path M (initial M) p" 
   and     "target (initial M) p = q"
     shows "finite {p . path M q p}"
 proof -
   from assms have "{ p . path M (initial M) p} \<subseteq> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
     unfolding acyclic_paths_set by auto
   moreover have "finite (acyclic_paths_up_to_length M (initial M) (size M - 1))"
     unfolding acyclic_paths_up_to_length.simps using paths_finite[of M "initial M" "size M - 1"]
     by (metis (mono_tags, lifting) Collect_cong \<open>FSM.acyclic M\<close> acyclic.elims(2)) 
   ultimately have "finite { p . path M (initial M) p}"
     using finite_subset by blast
 
   show "finite {p . path M q p}"
   proof (cases "q \<in> states M")
     case True
         
     have "image (\<lambda>p' . p@p') {p' . path M q p'} \<subseteq> {p' . path M (initial M) p'}"
     proof 
       fix x assume "x \<in> image (\<lambda>p' . p@p') {p' . path M q p'}"
       then obtain p' where "x = p@p'" and "p' \<in> {p' . path M q p'}"
         by blast
       then have "path M q p'" by auto
       then have "path M (initial M) (p@p')"
         using path_append[OF \<open>path M (initial M) p\<close>] \<open>target (initial M) p = q\<close> by auto
       then show "x \<in> {p' . path M (initial M) p'}" using \<open>x = p@p'\<close> by blast
     qed
     
     then have "finite (image (\<lambda>p' . p@p') {p' . path M q p'})"
       using \<open>finite { p . path M (initial M) p}\<close> finite_subset by auto 
     show ?thesis using finite_imageD[OF \<open>finite (image (\<lambda>p' . p@p') {p' . path M q p'})\<close>]
       by (meson inj_onI same_append_eq) 
   next
     case False
     then show ?thesis
       by (meson not_finite_existsD path_begin_state) 
   qed
 qed
 
 
 lemma acyclic_paths_from_reachable_states :
   assumes "acyclic M" 
   and     "path M (initial M) p'" 
   and     "target (initial M) p' = q"
   and     "path M q p"
 shows "distinct (visited_states q p)"
 proof -
   have "path M (initial M) (p'@p)"
     using assms(2,3,4) path_append by metis
   then have "distinct (visited_states (initial M) (p'@p))"
     using assms(1) unfolding acyclic.simps by blast
   then have "distinct (initial M # (map t_target p') @ map t_target p)"
     by auto
   moreover have "initial M # (map t_target p') @ map t_target p 
                   = (butlast (initial M # map t_target p')) @ ((last (initial M # map t_target p')) # map t_target p)"
     by auto
   ultimately have "distinct ((last (initial M # map t_target p')) # map t_target p)"
     by auto
   then show ?thesis 
     using \<open>target (initial M) p' = q\<close> unfolding visited_states.simps target.simps by simp
 qed
 
 definition LS_acyclic :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set" where
   "LS_acyclic M q = {p_io p | p .  path M q p \<and> distinct (visited_states q p)}"
 
 lemma LS_acyclic_code[code] : 
   "LS_acyclic M q = image p_io (acyclic_paths_up_to_length M q (size M - 1))"
   unfolding acyclic_paths_set LS_acyclic_def by blast
 
 lemma LS_from_LS_acyclic : 
   assumes "acyclic M" 
   shows "L M = LS_acyclic M (initial M)"
 proof -
   obtain pps :: "(('b \<times> 'c) list \<Rightarrow> bool) \<Rightarrow> (('b \<times> 'c) list \<Rightarrow> bool) \<Rightarrow> ('b \<times> 'c) list" where
     f1: "\<forall>p pa. (\<not> p (pps pa p)) = pa (pps pa p) \<or> Collect p = Collect pa"
     by (metis (no_types) Collect_cong)
   have "\<forall>ps. \<not> path M (FSM.initial M) ps \<or> distinct (visited_states (FSM.initial M) ps)"
     using acyclic.simps assms by blast
   then have "(\<nexists>ps. pps (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa) 
                        (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa 
                                     \<and> distinct (visited_states (FSM.initial M) psa)) 
                   = p_io ps \<and> path M (FSM.initial M) ps \<and> distinct (visited_states (FSM.initial M) ps)) 
             \<noteq> (\<exists>ps. pps (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa) 
                         (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa 
                                     \<and> distinct (visited_states (FSM.initial M) psa)) 
                   = p_io ps \<and> path M (FSM.initial M) ps)"
     by blast
   then have "{p_io ps |ps. path M (FSM.initial M) ps \<and> distinct (visited_states (FSM.initial M) ps)} 
               = {p_io ps |ps. path M (FSM.initial M) ps}"
     using f1 
     by (meson \<open>\<forall>ps. \<not> path M (FSM.initial M) ps \<or> distinct (visited_states (FSM.initial M) ps)\<close>) 
   then show ?thesis
     by (simp add: LS_acyclic_def)
 qed
 
 
 
 lemma cyclic_cycle :
   assumes "\<not> acyclic M"
   shows "\<exists> q p . path M q p \<and> p \<noteq> [] \<and> target q p = q" 
 proof -
   from \<open>\<not> acyclic M\<close> obtain p t where "path M (initial M) (p@[t])" 
                                   and "\<not>distinct (visited_states (initial M) (p@[t]))"
     by (metis (no_types, opaque_lifting) Nil_is_append_conv acyclic.simps append_take_drop_id 
           maximal_distinct_prefix rev_exhaust visited_states_take)
      
 
   show ?thesis
   proof (cases "initial M \<in> set (map t_target (p@[t]))")
     case True
     then obtain i where "last (take i (map t_target (p@[t]))) = initial M" 
                     and "i \<le> length (map t_target (p@[t]))" and "0 < i"
       using list_contains_last_take by metis
 
     let ?p = "take i (p@[t])"
     have "path M (initial M) (?p@(drop i (p@[t])))" 
       using \<open>path M (initial M) (p@[t])\<close>
       by (metis append_take_drop_id)  
     then have "path M (initial M) ?p" by auto
     moreover have "?p \<noteq> []" using \<open>0 < i\<close> by auto
     moreover have "target (initial M) ?p = initial M"
       using \<open>last (take i (map t_target (p@[t]))) = initial M\<close> 
       unfolding target.simps visited_states.simps
       by (metis (no_types, lifting) calculation(2) last_ConsR list.map_disc_iff take_map) 
     ultimately show ?thesis by blast
   next
     case False
     then have "\<not> distinct (map t_target (p@[t]))"
       using \<open>\<not>distinct (visited_states (initial M) (p@[t]))\<close> 
       unfolding visited_states.simps 
       by auto
     then obtain i j where "i < j" and "j < length (map t_target (p@[t]))" 
                       and "(map t_target (p@[t])) ! i = (map t_target (p@[t])) ! j"
       using non_distinct_repetition_indices by blast
 
     let ?pre_i = "take (Suc i) (p@[t])"
     let ?p = "take ((Suc j)-(Suc i)) (drop (Suc i) (p@[t]))"
     let ?post_j = "drop ((Suc j)-(Suc i)) (drop (Suc i) (p@[t]))"
 
     have "p@[t] = ?pre_i @ ?p @ ?post_j"
       using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close>
       by (metis append_take_drop_id) 
     then have "path M (target (initial M) ?pre_i) ?p" 
       using \<open>path M (initial M) (p@[t])\<close>
       by (metis path_prefix path_suffix) 
 
     have "?p \<noteq> []"
       using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close> by auto
 
     have "i < length (map t_target (p@[t]))"
       using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close> by auto
     have "(target (initial M) ?pre_i) = (map t_target (p@[t])) ! i"
       unfolding target.simps visited_states.simps  
       using take_last_index[OF \<open>i < length (map t_target (p@[t]))\<close>]
       by (metis (no_types, lifting) \<open>i < length (map t_target (p @ [t]))\<close> 
           last_ConsR snoc_eq_iff_butlast take_Suc_conv_app_nth take_map) 
     
     have "?pre_i@?p = take (Suc j) (p@[t])"
       by (metis (no_types) \<open>i < j\<close> add_Suc add_diff_cancel_left' less_SucI less_imp_Suc_add take_add)
     moreover have "(target (initial M) (take (Suc j) (p@[t]))) = (map t_target (p@[t])) ! j"
       unfolding target.simps visited_states.simps  
       using take_last_index[OF \<open>j < length (map t_target (p@[t]))\<close>]
       by (metis (no_types, lifting) \<open>j < length (map t_target (p @ [t]))\<close> 
             last_ConsR snoc_eq_iff_butlast take_Suc_conv_app_nth take_map) 
     ultimately have "(target (initial M) (?pre_i@?p)) = (map t_target (p@[t])) ! j"
       by auto
     then have "(target (initial M) (?pre_i@?p)) = (map t_target (p@[t])) ! i"
       using \<open>(map t_target (p@[t])) ! i = (map t_target (p@[t])) ! j\<close> by simp
     moreover have "(target (initial M) (?pre_i@?p)) = (target (target (initial M) ?pre_i) ?p)"
       unfolding target.simps visited_states.simps last.simps by auto
     ultimately have "(target (target (initial M) ?pre_i) ?p) = (map t_target (p@[t])) ! i"
       by auto
     then have "(target (target (initial M) ?pre_i) ?p) = (target (initial M) ?pre_i)"
       using \<open>(target (initial M) ?pre_i) = (map t_target (p@[t])) ! i\<close> by auto
 
     show ?thesis
       using \<open>path M (target (initial M) ?pre_i) ?p\<close> \<open>?p \<noteq> []\<close> 
             \<open>(target (target (initial M) ?pre_i) ?p) = (target (initial M) ?pre_i)\<close>
       by blast
   qed
 qed
 
 
 lemma cyclic_cycle_rev :
   fixes M :: "('a,'b,'c) fsm"
   assumes "path M (initial M) p'"
   and     "target (initial M) p' = q" 
   and     "path M q p"
   and     "p \<noteq> []"
   and     "target q p = q"
 shows "\<not> acyclic M"
   using assms unfolding acyclic.simps target.simps visited_states.simps
   using distinct.simps(2) by fastforce
 
 lemma acyclic_initial :
   assumes "acyclic M"
   shows "\<not> (\<exists> t \<in> transitions M . t_target t = initial M \<and> 
                                   (\<exists> p . path M (initial M) p \<and> target (initial M) p = t_source t))"
   by (metis append_Cons assms cyclic_cycle_rev list.distinct(1) path.simps 
         path_append path_append_transition_elim(3) single_transition_path) 
 
 lemma cyclic_path_shift : 
   assumes "path M q p"
   and     "target q p = q"
 shows "path M (target q (take i p)) ((drop i p) @ (take i p))"
   and "target (target q (take i p)) ((drop i p) @ (take i p)) = (target q (take i p))"
 proof -
   show "path M (target q (take i p)) ((drop i p) @ (take i p))"
     by (metis append_take_drop_id assms(1) assms(2) path_append path_append_elim path_append_target)
   show "target (target q (take i p)) ((drop i p) @ (take i p)) = (target q (take i p))"
     by (metis append_take_drop_id assms(2) path_append_target)
 qed
 
 
 lemma cyclic_path_transition_states_property :
   assumes "\<exists> t \<in> set p . P (t_source t)"
   and     "\<forall> t \<in> set p . P (t_source t) \<longrightarrow> P (t_target t)"
   and     "path M q p"
   and     "target q p = q"
 shows "\<forall> t \<in> set p . P (t_source t)"
   and "\<forall> t \<in> set p . P (t_target t)"
 proof -
   obtain t0 where "t0 \<in> set p" and "P (t_source t0)"
     using assms(1) by blast
   then obtain i where "i < length p" and "p ! i = t0"
     by (meson in_set_conv_nth)
 
   let ?p = "(drop i p @ take i p)"
   have "path M (target q (take i p)) ?p"
     using cyclic_path_shift(1)[OF assms(3,4), of i] by assumption
   
   have "set ?p = set p"
   proof -
     have "set ?p = set (take i p @ drop i p)" 
       using list_set_sym by metis
     then show ?thesis by auto
   qed
   then have "\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)"
     using assms(2) by blast
   
   have "\<And> j . j < length ?p \<Longrightarrow> P (t_source (?p ! j))"
   proof -
     fix j assume "j < length ?p"
     then show "P (t_source (?p ! j))"
     proof (induction j)
       case 0
       then show ?case 
         using \<open>p ! i = t0\<close> \<open>P (t_source t0)\<close>
         by (metis \<open>i < length p\<close> drop_eq_Nil hd_append2 hd_conv_nth hd_drop_conv_nth leD 
               length_greater_0_conv)  
     next
       case (Suc j)
       then have "P (t_source (?p ! j))"
         by auto
       then have "P (t_target (?p ! j))"
         using Suc.prems \<open>\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)\<close>[of "?p ! j"]
         using Suc_lessD nth_mem by blast 
       moreover have "t_target (?p ! j) = t_source (?p ! (Suc j))"
         using path_source_target_index[OF Suc.prems \<open>path M (target q (take i p)) ?p\<close>] 
         by assumption
       ultimately show ?case 
         using \<open>\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)\<close>[of "?p ! j"]
         by simp
     qed
   qed
   then have "\<forall> t \<in> set ?p . P (t_source t)"
     by (metis in_set_conv_nth)
   then show "\<forall> t \<in> set p . P (t_source t)"
     using \<open>set ?p = set p\<close> by blast
   then show "\<forall> t \<in> set p . P (t_target t)"
     using assms(2) by blast
 qed
 
 
 lemma cycle_incoming_transition_ex :
   assumes "path M q p"
   and     "p \<noteq> []"
   and     "target q p = q"
   and     "t \<in> set p"
 shows "\<exists> tI \<in> set p . t_target tI = t_source t"
 proof -
   obtain i where "i < length p" and "p ! i = t"
     using assms(4) by (meson in_set_conv_nth)
 
   let ?p = "(drop i p @ take i p)"
   have "path M (target q (take i p)) ?p"
   and  "target (target q (take i p)) ?p = target q (take i p)"
     using cyclic_path_shift[OF assms(1,3), of i] by linarith+
 
   have "p = (take i p @ drop i p)" by auto
   then have "path M (target q (take i p)) (drop i p)" 
     using path_suffix assms(1) by metis
   moreover have "t = hd (drop i p)"
     using \<open>i < length p\<close> \<open>p ! i = t\<close>
     by (simp add: hd_drop_conv_nth) 
   ultimately have "path M (target q (take i p)) [t]"
     by (metis \<open>i < length p\<close> append_take_drop_id assms(1) path_append_elim take_hd_drop)
   then have "t_source t = (target q (take i p))"
     by auto  
   moreover have "t_target (last ?p) = (target q (take i p))" 
     using \<open>path M (target q (take i p)) ?p\<close> \<open>target (target q (take i p)) ?p = target q (take i p)\<close> 
           assms(2)
     unfolding target.simps visited_states.simps last.simps
     by (metis (no_types, lifting) \<open>p = take i p @ drop i p\<close> append_is_Nil_conv last_map 
           list.map_disc_iff)
     
   
   moreover have "set ?p = set p"
   proof -
     have "set ?p = set (take i p @ drop i p)" 
       using list_set_sym by metis
     then show ?thesis by auto
   qed
 
   ultimately show ?thesis
     by (metis \<open>i < length p\<close> append_is_Nil_conv drop_eq_Nil last_in_set leD) 
 qed
 
 
 lemma acyclic_paths_finite :
   "finite {p . path M q p \<and> distinct (visited_states q p) }"
 proof -
   have "\<And> p . path M q p \<Longrightarrow> distinct (visited_states q p) \<Longrightarrow> distinct p"
   proof -
     fix p assume "path M q p" and "distinct (visited_states q p)"
     then have "distinct (map t_target p)" by auto
     then show "distinct p" by (simp add: distinct_map) 
   qed
   
   then show ?thesis
-    using distinct_lists_finite[OF fsm_transitions_finite, of M]  path_transitions[of M q]
+    using finite_subset_distinct[OF fsm_transitions_finite, of M]  path_transitions[of M q]
     by (metis (no_types, lifting) infinite_super mem_Collect_eq path_transitions subsetI)
 qed
 
 
 lemma acyclic_no_self_loop :
   assumes "acyclic M"
   and     "q \<in> reachable_states M"
 shows "\<not> (\<exists> x y . (q,x,y,q) \<in> transitions M)" 
 proof 
   assume "\<exists>x y. (q, x, y, q) \<in> FSM.transitions M"
   then obtain x y where "(q, x, y, q) \<in> FSM.transitions M" by blast
   moreover obtain p where "path M (initial M) p" and "target (initial M) p = q"
     using assms(2) unfolding reachable_states_def by blast
   ultimately have "path M (initial M) (p@[(q,x,y,q)])" 
     by (simp add: path_append_transition) 
   moreover have "\<not> (distinct (visited_states (initial M) (p@[(q,x,y,q)])))"
     using \<open>target (initial M) p = q\<close> unfolding visited_states.simps target.simps by (cases p rule: rev_cases; auto)
   ultimately show "False"
     using assms(1) unfolding acyclic.simps
     by meson 
 qed
 
 
 subsubsection \<open>Deadlock States\<close>
 
 fun deadlock_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where 
   "deadlock_state M q = (\<not>(\<exists> t \<in> transitions M . t_source t = q))"
 
 lemma deadlock_state_alt_def : "deadlock_state M q = (LS M q \<subseteq> {[]})" 
 proof 
   show "deadlock_state M q \<Longrightarrow> LS M q \<subseteq> {[]}" 
   proof -
     assume "deadlock_state M q"
     moreover have "\<And> p . deadlock_state M q \<Longrightarrow> path M q p \<Longrightarrow> p = []"
       unfolding deadlock_state.simps by (metis path.cases) 
     ultimately show "LS M q \<subseteq> {[]}"
       unfolding LS.simps by blast
   qed
   show "LS M q \<subseteq> {[]} \<Longrightarrow> deadlock_state M q"
     unfolding LS.simps deadlock_state.simps using path.cases[of M q] by blast
 qed
 
 lemma deadlock_state_alt_def_h : "deadlock_state M q = (\<forall> x \<in> inputs M . h M (q,x) = {})" 
   unfolding deadlock_state.simps h.simps 
   using fsm_transition_input by force
 
 
 lemma acyclic_deadlock_reachable :
   assumes "acyclic M"
   shows "\<exists> q \<in> reachable_states M . deadlock_state M q"
 proof (rule ccontr)
   assume "\<not> (\<exists>q\<in>reachable_states M. deadlock_state M q)"
   then have *: "\<And> q . q \<in> reachable_states M \<Longrightarrow> (\<exists> t \<in> transitions M . t_source t = q)"
     unfolding deadlock_state.simps by blast
 
   let ?p = "arg_max_on length {p. path M (initial M) p}"
   
 
   have "finite {p. path M (initial M) p}" 
     by (metis Collect_cong acyclic_finite_paths_from_reachable_state assms eq_Nil_appendI fsm_initial 
           nil path_append path_append_elim) 
     
   moreover have "{p. path M (initial M) p} \<noteq> {}" 
     by auto
   ultimately obtain p where "path M (initial M) p" 
                         and "\<And> p' . path M (initial M) p' \<Longrightarrow> length p' \<le> length p" 
     using max_length_elem
     by (metis mem_Collect_eq not_le_imp_less)
 
   then obtain t where "t \<in> transitions M" and "t_source t = target (initial M) p"
     using *[of "target (initial M) p"] unfolding reachable_states_def
     by blast
 
   then have "path M (initial M) (p@[t])"
     using \<open>path M (initial M) p\<close>
     by (simp add: path_append_transition)
 
   then show "False"
     using \<open>\<And> p' . path M (initial M) p' \<Longrightarrow> length p' \<le> length p\<close>
     by (metis impossible_Cons length_rotate1 rotate1.simps(2)) 
 qed
 
 lemma deadlock_prefix :
   assumes "path M q p"
   and     "t \<in> set (butlast p)"
 shows "\<not> (deadlock_state M (t_target t))"
   using assms proof (induction p rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc t' p')
   
   show ?case proof (cases "t \<in> set (butlast p')")
     case True
     show ?thesis 
       using snoc.IH[OF _ True] snoc.prems(1)
       by blast 
   next
     case False
     then have "p' = (butlast p')@[t]"
       using snoc.prems(2) by (metis append_butlast_last_id append_self_conv2 butlast_snoc 
                                 in_set_butlast_appendI list_prefix_elem set_ConsD)
     then have "path M q ((butlast p'@[t])@[t'])"
       using snoc.prems(1)
       by auto 
     
     have "t' \<in> transitions M" and "t_source t' = target q (butlast p'@[t])"
       using path_suffix[OF \<open>path M q ((butlast p'@[t])@[t'])\<close>]
       by auto
     then have "t' \<in> transitions M \<and> t_source t' = t_target t"
       unfolding target.simps visited_states.simps by auto
     then show ?thesis 
       unfolding deadlock_state.simps using \<open>t' \<in> transitions M\<close> by blast
   qed
 qed
 
 
 lemma states_initial_deadlock :
   assumes "deadlock_state M (initial M)"
   shows "reachable_states M = {initial M}"
   
 proof -
   have "\<And> q . q \<in> reachable_states M \<Longrightarrow> q = initial M"
   proof -
     fix q assume "q \<in> reachable_states M"
     then obtain p where "path M (initial M) p" and "target (initial M) p = q"
       unfolding reachable_states_def by auto
     
     show "q = initial M" proof (cases p)
       case Nil
       then show ?thesis using \<open>target (initial M) p = q\<close> by auto
     next
       case (Cons t p')
       then have "False" using assms \<open>path M (initial M) p\<close> unfolding deadlock_state.simps
         by auto 
       then show ?thesis by simp
     qed
   qed
   then show ?thesis
     using reachable_states_initial[of M] by blast
 qed
 
 subsubsection \<open>Other\<close>
 
 fun completed_path :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> bool" where
   "completed_path M q p = deadlock_state M (target q p)"
 
 fun minimal :: "('a,'b,'c) fsm \<Rightarrow> bool" where
   "minimal M = (\<forall> q \<in> states M . \<forall> q' \<in> states M . q \<noteq> q' \<longrightarrow> LS M q \<noteq> LS M q')"
 
 lemma minimal_alt_def : "minimal M = (\<forall> q q' . q \<in> states M \<longrightarrow> q' \<in> states M \<longrightarrow> LS M q = LS M q' \<longrightarrow> q = q')" 
   by auto  
 
 definition retains_outputs_for_states_and_inputs :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where
   "retains_outputs_for_states_and_inputs M S 
     = (\<forall> tS \<in> transitions S . 
         \<forall> tM \<in> transitions M . 
           (t_source tS = t_source tM \<and> t_input tS = t_input tM) \<longrightarrow> tM \<in> transitions S)"
 
 
 
 
 
 subsection \<open>IO Targets and Observability\<close>
 
 fun paths_for_io' :: "(('a \<times> 'b) \<Rightarrow> ('c \<times> 'a) set) \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> ('a,'b,'c) path set" where
   "paths_for_io' f [] q prev = {prev}" |
   "paths_for_io' f ((x,y)#io) q prev = \<Union>(image (\<lambda>yq' . paths_for_io' f io (snd yq') (prev@[(q,x,y,(snd yq'))])) (Set.filter (\<lambda>yq' . fst yq' = y) (f (q,x))))"
 
 lemma paths_for_io'_set :
   assumes "q \<in> states M"
   shows   "paths_for_io' (h M) io q prev = {prev@p | p . path M q p \<and> p_io p = io}"
 using assms proof (induction io arbitrary: q prev)
   case Nil
   then show ?case by auto
 next
   case (Cons xy io)
   obtain x y where "xy = (x,y)"
     by (meson surj_pair) 
 
   let ?UN = "\<Union>(image (\<lambda>yq' . paths_for_io' (h M) io (snd yq') (prev@[(q,x,y,(snd yq'))])) 
                       (Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x))))"
 
   have "?UN = {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
   proof 
     have "\<And> p . p \<in> ?UN \<Longrightarrow> p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
     proof -
       fix p assume "p \<in> ?UN"
       then obtain q' where "(y,q') \<in> (Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x)))"
                      and   "p \<in> paths_for_io' (h M) io q' (prev@[(q,x,y,q')])"
         by auto
       
       from \<open>(y,q') \<in> (Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x)))\<close> have "q' \<in> states M" 
                                                                      and "(q,x,y,q') \<in> transitions M"
         using fsm_transition_target unfolding h.simps by auto
 
       have "p \<in> {(prev @ [(q, x, y, q')]) @ p |p. path M q' p \<and> p_io p = io}"
         using \<open>p \<in> paths_for_io' (h M) io q' (prev@[(q,x,y,q')])\<close>
         unfolding Cons.IH[OF \<open>q' \<in> states M\<close>] by assumption
       moreover have "{(prev @ [(q, x, y, q')]) @ p |p. path M q' p \<and> p_io p = io} 
                       \<subseteq> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
         using \<open>(q,x,y,q') \<in> transitions M\<close>
         using cons by force 
       ultimately show "p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}" 
         by blast
     qed
     then show "?UN \<subseteq> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
       by blast
 
     have "\<And> p . p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io} \<Longrightarrow> p \<in> ?UN"
     proof -
       fix pp assume "pp \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
       then obtain p where "pp = prev@p" and "path M q p" and "p_io p = (x,y)#io"
         by fastforce
       then obtain t p' where "p = t#p'" and "path M q (t#p')" and "p_io (t#p') = (x,y)#io" 
                          and "p_io p' = io"
         by (metis (no_types, lifting) map_eq_Cons_D)
       then have "path M (t_target t) p'" and "t_source t = q" and "t_input t = x" 
                                          and "t_output t = y" and "t_target t \<in> states M"
                                          and "t \<in> transitions M"
         by auto
 
       have "(y,t_target t) \<in> Set.filter (\<lambda>yq'. fst yq' = y) (h M (q, x))"
         using \<open>t \<in> transitions M\<close> \<open>t_output t = y\<close> \<open>t_input t = x\<close> \<open>t_source t = q\<close>
         unfolding h.simps
         by auto 
       moreover have "(prev@p) \<in> paths_for_io' (h M) io (snd (y,t_target t)) (prev @ [(q, x, y, snd (y,t_target t))])"
         using Cons.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[(q, x, y, t_target t)]"]
         using \<open>p = t # p'\<close> \<open>p_io p' = io\<close> \<open>path M (t_target t) p'\<close> \<open>t_input t = x\<close> 
               \<open>t_output t = y\<close> \<open>t_source t = q\<close> 
         by auto
 
       ultimately show "pp \<in> ?UN" unfolding \<open>pp = prev@p\<close>
         by blast 
     qed
     then show "{prev@p | p . path M q p \<and> p_io p = (x,y)#io} \<subseteq> ?UN"
       by (meson subsetI) 
   qed
 
   then show ?case
     by (simp add: \<open>xy = (x, y)\<close>) 
 qed
 
 
 
 definition paths_for_io :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> ('a,'b,'c) path set" where
   "paths_for_io M q io = {p . path M q p \<and> p_io p = io}"
 
 lemma paths_for_io_set_code[code] :
   "paths_for_io M q io = (if q \<in> states M then paths_for_io' (h M) io q [] else {})"
   using paths_for_io'_set[of q M io "[]"]
   unfolding paths_for_io_def
 proof -
   have "{[] @ ps |ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {}) 
         \<longrightarrow> {ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
     by auto
   moreover
     { assume "{[] @ ps |ps. path M q ps \<and> p_io ps = io} \<noteq> (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
       then have "q \<notin> FSM.states M"
         using \<open>q \<in> FSM.states M \<Longrightarrow> paths_for_io' (h M) io q [] = {[] @ p |p. path M q p \<and> p_io p = io}\<close> by force
       then have "{ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
       using path_begin_state by force }
   ultimately show "{ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
     by linarith
 qed 
 
 
 fun io_targets :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a \<Rightarrow> 'a set" where
   "io_targets M io q = {target q p | p . path M q p \<and> p_io p = io}"
 
 lemma io_targets_code[code] : "io_targets M io q = image (target q) (paths_for_io M q io)"
   unfolding io_targets.simps paths_for_io_def by blast
 
 lemma io_targets_states :
   "io_targets M io q \<subseteq> states M"
   using path_target_is_state by fastforce
 
 
 
 lemma observable_transition_unique :
   assumes "observable M"
       and "t \<in> transitions M"
     shows "\<exists>! t' \<in> transitions M . t_source t' = t_source t \<and> 
                                     t_input t' = t_input t \<and> 
                                     t_output t' = t_output t"
   by (metis assms observable.elims(2) prod.expand)
 
 lemma observable_path_unique :
   assumes "observable M"
   and     "path M q p"
   and     "path M q p'"
   and     "p_io p = p_io p'"
 shows "p = p'"
 proof -
   have "length p = length p'"
     using assms(4) map_eq_imp_length_eq by blast 
   then show ?thesis
     using \<open>p_io p = p_io p'\<close> \<open>path M q p\<close> \<open>path M q p'\<close>
   proof (induction p p' arbitrary: q rule: list_induct2)
     case Nil
     then show ?case by auto
   next
     case (Cons x xs y ys)
     then have *: "x \<in> transitions M \<and> y \<in> transitions M \<and> t_source x = t_source y 
                                     \<and> t_input x = t_input y \<and> t_output x = t_output y" 
       by auto
     then have "t_target x = t_target y" 
       using assms(1) observable.elims(2) by blast 
     then have "x = y"
       by (simp add: "*" prod.expand) 
       
 
     have "p_io xs = p_io ys" 
       using Cons by auto
 
     moreover have "path M (t_target x) xs" 
       using Cons by auto
     moreover have "path M (t_target x) ys"
       using Cons \<open>t_target x = t_target y\<close> by auto
     ultimately have "xs = ys" 
       using Cons by auto
 
     then show ?case 
       using \<open>x = y\<close> by simp
   qed
 qed
 
 
 lemma observable_io_targets : 
   assumes "observable M"
   and "io \<in> LS M q"
 obtains q'
 where "io_targets M io q = {q'}"
 proof -
 
   obtain p where "path M q p" and "p_io p = io" 
     using assms(2) by auto 
   then have "target q p \<in> io_targets M io q"
     by auto   
 
   have "\<exists> q' . io_targets M io q = {q'}"
   proof (rule ccontr)
     assume "\<not>(\<exists>q'. io_targets M io q = {q'})"
     then have "\<exists> q' . q' \<noteq> target q p \<and> q' \<in> io_targets M io q"
     proof -
       have "\<not> io_targets M io q \<subseteq> {target q p}"
         using \<open>\<not>(\<exists>q'. io_targets M io q = {q'})\<close> \<open>target q p \<in> io_targets M io q\<close> by blast
       then show ?thesis
         by blast
     qed       
     then obtain q' where "q' \<noteq> target q p" and "q' \<in> io_targets M io q" 
       by blast
     then obtain p' where "path M q p'" and "target q p' = q'" and "p_io p' = io"
       by auto 
     then have "p_io p = p_io p'" 
       using \<open>p_io p = io\<close> by simp
     then have "p = p'"
       using observable_path_unique[OF assms(1) \<open>path M q p\<close> \<open>path M q p'\<close>] by simp
     then show "False"
       using \<open>q' \<noteq> target q p\<close> \<open>target q p' = q'\<close> by auto
   qed
 
   then show ?thesis using that by blast
 qed
 
 
 lemma observable_path_io_target : 
   assumes "observable M"
   and     "path M q p"
 shows "io_targets M (p_io p) q = {target q p}"
   using observable_io_targets[OF assms(1) language_state_containment[OF assms(2)], of "p_io p"] 
         singletonD[of "target q p"]
   unfolding io_targets.simps
 proof -
   assume a1: "\<And>a. target q p \<in> {a} \<Longrightarrow> target q p = a"
   assume "\<And>thesis. \<lbrakk>p_io p = p_io p; \<And>q'. {target q pa |pa. path M q pa \<and> p_io pa = p_io p} = {q'} \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis"
   then obtain aa :: 'a where "\<And>b. {target q ps |ps. path M q ps \<and> p_io ps = p_io p} = {aa} \<or> b"
     by meson
   then show "{target q ps |ps. path M q ps \<and> p_io ps = p_io p} = {target q p}"
     using a1 assms(2) by blast
 qed
 
 
 lemma completely_specified_io_targets : 
   assumes "completely_specified M"
   shows "\<forall> q \<in> io_targets M io (initial M) . \<forall> x \<in> (inputs M) . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x"
   by (meson assms completely_specified.elims(2) io_targets_states subsetD)
   
 
 
 lemma observable_path_language_step :
   assumes "observable M"
       and "path M q p"
       and "\<not> (\<exists>t\<in>transitions M.
                t_source t = target q p \<and>
                t_input t = x \<and> t_output t = y)"
     shows "(p_io p)@[(x,y)] \<notin> LS M q"
 using assms proof (induction p rule: rev_induct)
   case Nil
   show ?case proof
     assume "p_io [] @ [(x, y)] \<in> LS M q"
     then obtain p' where "path M q p'" and "p_io p' = [(x,y)]" unfolding LS.simps
       by force 
     then obtain t where "p' = [t]" by blast
     
     have "t\<in>transitions M" and "t_source t = target q []"
       using \<open>path M q p'\<close> \<open>p' = [t]\<close> by auto
     moreover have "t_input t = x \<and> t_output t = y"
       using \<open>p_io p' = [(x,y)]\<close> \<open>p' = [t]\<close> by auto
     ultimately show "False"
       using Nil.prems(3) by blast
   qed
 next
   case (snoc t p)
   
   from \<open>path M q (p @ [t])\<close> have "path M q p" and "t_source t = target q p" 
                                               and "t \<in> transitions M" 
     by auto
 
   show ?case proof
     assume "p_io (p @ [t]) @ [(x, y)] \<in> LS M q"
     then obtain p' where "path M q p'" and "p_io p' = p_io (p @ [t]) @ [(x, y)]"
       by auto
     then obtain p'' t' t'' where "p' = p''@[t']@[t'']"
       by (metis (no_types, lifting) append.assoc map_butlast map_is_Nil_conv snoc_eq_iff_butlast)
     then have "path M q p''" 
       using \<open>path M q p'\<close> by blast
     
     
     have "p_io p'' = p_io p"
       using \<open>p' = p''@[t']@[t'']\<close> \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> by auto
     then have "p'' = p"
       using observable_path_unique[OF assms(1) \<open>path M q p''\<close> \<open>path M q p\<close>] by blast
 
     have "t_source t' = target q p''" and "t' \<in> transitions M"
       using \<open>path M q p'\<close> \<open>p' = p''@[t']@[t'']\<close> by auto
     then have "t_source t' = t_source t"
       using \<open>p'' = p\<close> \<open>t_source t = target q p\<close> by auto 
     moreover have "t_input t' = t_input t \<and> t_output t' = t_output t"
       using \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> \<open>p' = p''@[t']@[t'']\<close> \<open>p'' = p\<close> by auto
     ultimately have "t' = t"
       using \<open>t \<in> transitions M\<close> \<open>t' \<in> transitions M\<close> assms(1) unfolding observable.simps 
       by (meson prod.expand) 
 
     have "t'' \<in> transitions M" and "t_source t'' = target q (p@[t])"
       using \<open>path M q p'\<close> \<open>p' = p''@[t']@[t'']\<close> \<open>p'' = p\<close> \<open>t' = t\<close> by auto
     moreover have "t_input t'' = x \<and> t_output t'' = y"
       using \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> \<open>p' = p''@[t']@[t'']\<close> by auto
     ultimately show "False"
       using snoc.prems(3) by blast
   qed
 qed
 
 lemma observable_io_targets_language :
   assumes "io1 @ io2 \<in> LS M q1"
   and     "observable M"
   and     "q2 \<in> io_targets M io1 q1"
 shows "io2 \<in> LS M q2" 
 proof -
   obtain p1 p2 where "path M q1 p1" and "path M (target q1 p1) p2"  
                  and "p_io p1 = io1" and "p_io p2 = io2"
     using language_state_split[OF assms(1)] by blast
   then have "io1 \<in> LS M q1" and "io2 \<in> LS M (target q1 p1)"
     by auto
   
   have "target q1 p1 \<in> io_targets M io1 q1"
     using \<open>path M q1 p1\<close> \<open>p_io p1 = io1\<close>
     unfolding io_targets.simps by blast
   then have "target q1 p1 = q2"
     using observable_io_targets[OF assms(2) \<open>io1 \<in> LS M q1\<close>]
     by (metis assms(3) singletonD) 
   then show ?thesis
     using \<open>io2 \<in> LS M (target q1 p1)\<close> by auto
 qed
 
 
 lemma io_targets_language_append :
   assumes "q1 \<in> io_targets M io1 q"
   and     "io2 \<in> LS M q1"
 shows "io1@io2 \<in> LS M q" 
 proof -
   obtain p1 where "path M q p1" and "p_io p1 = io1" and "target q p1 = q1" 
     using assms(1) by auto
   moreover obtain p2 where "path M q1 p2" and "p_io p2 = io2" 
     using assms(2) by auto
   ultimately have "path M q (p1@p2)" and "p_io (p1@p2) = io1@io2"
     by auto
   then show ?thesis 
     using language_state_containment[of M q "p1@p2" "io1@io2"] by simp
 qed
 
 
 lemma io_targets_next :
   assumes "t \<in> transitions M"
   shows "io_targets M io (t_target t) \<subseteq> io_targets M (p_io [t] @ io) (t_source t)"
 unfolding io_targets.simps
 proof 
   fix q assume "q \<in> {target (t_target t) p |p. path M (t_target t) p \<and> p_io p = io}"
   then obtain p where "path M (t_target t) p \<and> p_io p = io \<and> target (t_target t) p = q"
     by auto
   then have "path M (t_source t) (t#p) \<and> p_io (t#p) = p_io [t] @ io \<and> target (t_source t) (t#p) = q"
     using FSM.path.cons[OF assms] by auto
   then show "q \<in> {target (t_source t) p |p. path M (t_source t) p \<and> p_io p = p_io [t] @ io}"
     by blast
 qed
 
 
 lemma observable_io_targets_next :
   assumes "observable M"
   and     "t \<in> transitions M"
 shows "io_targets M (p_io [t] @ io) (t_source t) = io_targets M io (t_target t)" 
 proof 
   show "io_targets M (p_io [t] @ io) (t_source t) \<subseteq> io_targets M io (t_target t)"
   proof 
     fix q assume "q \<in> io_targets M (p_io [t] @ io) (t_source t)"
     then obtain p where "q = target (t_source t) p" 
                     and "path M (t_source t) p"
                     and "p_io p = p_io [t] @ io"
       unfolding io_targets.simps by blast
     then have "q = t_target (last p)" unfolding target.simps visited_states.simps
       using last_map by auto 
 
     obtain t' p' where "p = t' # p'"
       using \<open>p_io p = p_io [t] @ io\<close> by auto
     then have "t' \<in> transitions M" and "t_source t' = t_source t"
       using \<open>path M (t_source t) p\<close> by auto
     moreover have "t_input t' = t_input t" and "t_output t' = t_output t"
       using \<open>p = t' # p'\<close> \<open>p_io p = p_io [t] @ io\<close> by auto
     ultimately have "t' = t"
       using \<open>t \<in> transitions M\<close> \<open>observable M\<close> unfolding observable.simps
       by (meson prod.expand) 
 
     then have "path M (t_target t) p'"
       using \<open>path M (t_source t) p\<close> \<open>p = t' # p'\<close> by auto
     moreover have "p_io p' = io"
       using \<open>p_io p = p_io [t] @ io\<close> \<open>p = t' # p'\<close> by auto
     moreover have "q = target (t_target t) p'"
       using \<open>q = target (t_source t) p\<close> \<open>p = t' # p'\<close> \<open>t' = t\<close> by auto
     ultimately show "q \<in> io_targets M io (t_target t)"
       by auto
   qed
 
   show "io_targets M io (t_target t) \<subseteq> io_targets M (p_io [t] @ io) (t_source t)"
     using io_targets_next[OF assms(2)] by assumption
 qed
 
 
 
 lemma observable_language_target :
   assumes "observable M"
   and     "q \<in> io_targets M io1 (initial M)"
   and     "t \<in> io_targets T io1 (initial T)"
   and     "L T \<subseteq> L M"
 shows "LS T t \<subseteq> LS M q"
 proof 
   fix io2 assume "io2 \<in> LS T t"
   then obtain pT2 where "path T t pT2" and "p_io pT2 = io2"
     by auto  
   
   obtain pT1 where "path T (initial T) pT1" and "p_io pT1 = io1" and "target (initial T) pT1 = t"
     using \<open>t \<in> io_targets T io1 (initial T)\<close> by auto
   then have "path T (initial T) (pT1@pT2)" 
     using \<open>path T t pT2\<close> using path_append by metis
   moreover have "p_io (pT1@pT2) = io1@io2"
     using \<open>p_io pT1 = io1\<close> \<open>p_io pT2 = io2\<close> by auto
   ultimately have "io1@io2 \<in> L T"
     using language_state_containment[of T] by auto
   then have "io1@io2 \<in> L M"
     using \<open>L T \<subseteq> L M\<close> by blast
   then obtain pM where "path M (initial M) pM" and "p_io pM = io1@io2"
     by auto
 
   let ?pM1 = "take (length io1) pM"
   let ?pM2 = "drop (length io1) pM"
 
   have "path M (initial M) (?pM1@?pM2)"
     using \<open>path M (initial M) pM\<close> by auto
   then have "path M (initial M) ?pM1" and "path M (target (initial M) ?pM1) ?pM2"
     by blast+
   
   have "p_io ?pM1 = io1"
     using \<open>p_io pM = io1@io2\<close> 
     by (metis append_eq_conv_conj take_map)
   have "p_io ?pM2 = io2"
     using \<open>p_io pM = io1@io2\<close> 
     by (metis append_eq_conv_conj drop_map)
 
   obtain pM1 where "path M (initial M) pM1" and "p_io pM1 = io1" and "target (initial M) pM1 = q"
     using \<open>q \<in> io_targets M io1 (initial M)\<close> by auto
 
   have "pM1 = ?pM1"
     using observable_path_unique[OF \<open>observable M\<close> \<open>path M (initial M) pM1\<close> \<open>path M (initial M) ?pM1\<close>]
     unfolding \<open>p_io pM1 = io1\<close> \<open>p_io ?pM1 = io1\<close> by simp
 
   then have "path M q ?pM2"
     using \<open>path M (target (initial M) ?pM1) ?pM2\<close> \<open>target (initial M) pM1 = q\<close> by auto
   then show "io2 \<in> LS M q"
     using language_state_containment[OF _ \<open>p_io ?pM2 = io2\<close>, of M] by auto
 qed
 
 
 lemma observable_language_target_failure :
   assumes "observable M"
   and     "q \<in> io_targets M io1 (initial M)"
   and     "t \<in> io_targets T io1 (initial T)"
   and     "\<not> LS T t \<subseteq> LS M q"
 shows "\<not> L T \<subseteq> L M"
   using observable_language_target[OF assms(1,2,3)] assms(4) by blast
     
 
 lemma language_path_append_transition_observable :
   assumes "(p_io p) @ [(x,y)] \<in> LS M q"
   and     "path M q p"
   and     "observable M"
   obtains t where "path M q (p@[t])" and "t_input t = x" and "t_output t = y"
 proof -
   obtain p' t where "path M q (p'@[t])" and "p_io (p'@[t]) = (p_io p) @ [(x,y)]"
     using language_path_append_transition[OF assms(1)] by blast
   then have "path M q p'" and "p_io p' = p_io p" and "t_input t = x" and "t_output t = y"
     by auto
 
   have "p' = p"
     using observable_path_unique[OF assms(3) \<open>path M q p'\<close> \<open>path M q p\<close> \<open>p_io p' = p_io p\<close>] by assumption
   then have "path M q (p@[t])"
     using \<open>path M q (p'@[t])\<close> by auto
   then show ?thesis using that \<open>t_input t = x\<close> \<open>t_output t = y\<close> by metis
 qed
 
 
 lemma language_io_target_append :
   assumes "q' \<in> io_targets M io1 q"
   and     "io2 \<in> LS M q'"
 shows "(io1@io2) \<in> LS M q"
 proof - 
   obtain p2 where "path M q' p2" and "p_io p2 = io2"
     using assms(2) by auto
 
   moreover obtain p1 where "q' = target q p1" and "path M q p1" and "p_io p1 = io1"
     using assms(1) by auto
 
   ultimately show ?thesis unfolding LS.simps
     by (metis (mono_tags, lifting) map_append mem_Collect_eq path_append) 
 qed
 
 
 lemma observable_path_suffix :
   assumes "(p_io p)@io \<in> LS M q"
   and     "path M q p"
   and     "observable M"
 obtains p' where "path M (target q p) p'" and "p_io p' = io"
 proof -
   obtain p1 p2 where "path M q p1" and "path M (target q p1) p2"  and "p_io p1 = p_io p" and "p_io p2 = io"
     using language_state_split[OF assms(1)] by blast
 
   have "p1 = p"
     using observable_path_unique[OF assms(3,2) \<open>path M q p1\<close> \<open>p_io p1 = p_io p\<close>[symmetric]]
     by simp
 
   show ?thesis using that[of p2] \<open>path M (target q p1) p2\<close> \<open>p_io p2 = io\<close> unfolding \<open>p1 = p\<close>
     by blast
 qed
 
 
 lemma io_targets_finite :
   "finite (io_targets M io q)"
 proof -
   have "(io_targets M io q) \<subseteq> {target q p | p . path M q p \<and> length p \<le> length io}"
     unfolding io_targets.simps length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric] by force
   moreover have "finite {target q p | p . path M q p \<and> length p \<le> length io}"
     using paths_finite[of M q "length io"]
     by simp 
   ultimately show ?thesis
     using rev_finite_subset by blast 
 qed
 
 lemma language_next_transition_ob :
   assumes "(x,y)#ios \<in> LS M q"
 obtains t where "t_source t = q"
             and "t \<in> transitions M"
             and "t_input t = x"
             and "t_output t = y"
             and "ios \<in> LS M (t_target t)"
 proof -
   obtain p where "path M q p" and "p_io p = (x,y)#ios"
     using assms unfolding LS.simps mem_Collect_eq
     by (metis (no_types, lifting)) 
   then obtain t p' where "p = t#p'"
     by blast
 
   have "t_source t = q"
    and "t \<in> transitions M"
    and "path M (t_target t) p'"
     using \<open>path M q p\<close> unfolding \<open>p = t#p'\<close> by auto
   moreover have "t_input t = x"
             and "t_output t = y"
             and "p_io p' = ios"
     using \<open>p_io p = (x,y)#ios\<close> unfolding \<open>p = t#p'\<close> by auto
   ultimately show ?thesis using that[of t] by auto
 qed
 
 lemma h_observable_card :
   assumes "observable M"
   shows "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
   and "finite (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)))"
 proof -
   have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q' . (q,x,y,q') \<in> transitions M}"
     unfolding h.simps by force
   moreover have "{q' . (q,x,y,q') \<in> transitions M} = {} \<or> (\<exists> q' . {q' . (q,x,y,q') \<in> transitions M} = {q'})"
     using assms unfolding observable_alt_def by blast
   ultimately show "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
               and "finite (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)))"
     by auto
 qed
 
 lemma h_obs_None : 
   assumes "observable M"
 shows "(h_obs M q x y = None) = (\<nexists>q' . (q,x,y,q') \<in> transitions M)"
 proof 
   show "(h_obs M q x y = None) \<Longrightarrow> (\<nexists>q' . (q,x,y,q') \<in> transitions M)"
   proof -
     assume "h_obs M q x y = None"
     then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<noteq> 1"
       by auto
     then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 0"
       using h_observable_card(1)[OF assms, of y q x] by presburger
     then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {}"
       using h_observable_card(2)[OF assms, of y q x] card_0_eq[of "(snd ` Set.filter (\<lambda>(y', q'). y' = y) (h M (q, x)))"] by blast
     then show ?thesis 
       unfolding h.simps by force
   qed
   show "(\<nexists>q' . (q,x,y,q') \<in> transitions M) \<Longrightarrow> (h_obs M q x y = None)"
   proof -
     assume "(\<nexists>q' . (q,x,y,q') \<in> transitions M)"
     then have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {}"
       unfolding h.simps by force
     then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 0"
       by simp
     then show ?thesis
       unfolding h_obs_simps Let_def \<open>snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {}\<close>
       by auto
   qed
 qed
 
 lemma h_obs_Some : 
   assumes "observable M"
   shows "(h_obs M q x y = Some q') = ({q' . (q,x,y,q') \<in> transitions M} = {q'})"
 proof 
   have *: "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q' . (q,x,y,q') \<in> transitions M}"
     unfolding h.simps by force
 
   show "h_obs M q x y = Some q' \<Longrightarrow> ({q' . (q,x,y,q') \<in> transitions M} = {q'})"
   proof -
     assume "h_obs M q x y = Some q'"
     then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<noteq> {}"
       by force 
     then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) > 0"
       unfolding h_simps using fsm_transitions_finite[of M]
       by (metis assms card_0_eq h_observable_card(2) h_simps neq0_conv) 
     moreover have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
       using assms unfolding observable_alt_def h_simps
       by (metis assms h_observable_card(1) h_simps)
     ultimately have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 1"
       by auto
     then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {q'}" 
       using \<open>h_obs M q x y = Some q'\<close> unfolding h_obs_simps Let_def        
       by (metis card_1_singletonE option.inject the_elem_eq) 
     then show ?thesis 
       using * unfolding h.simps by blast
   qed
 
   show "({q' . (q,x,y,q') \<in> transitions M} = {q'}) \<Longrightarrow> (h_obs M q x y = Some q')"
   proof -
     assume "({q' . (q,x,y,q') \<in> transitions M} = {q'})"
     then have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q'}"
       unfolding h.simps by force
     then show ?thesis
       unfolding Let_def
       by simp 
   qed
 qed
 
 lemma h_obs_state :
   assumes "h_obs M q x y = Some q'"
   shows "q' \<in> states M"
 proof (cases "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 1")
   case True
   then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {q'}" 
     using \<open>h_obs M q x y = Some q'\<close> unfolding h_obs_simps Let_def        
     by (metis card_1_singletonE option.inject the_elem_eq) 
   then have "(q,x,y,q') \<in> transitions M"
     unfolding h_simps by auto
   then show ?thesis
     by (metis fsm_transition_target snd_conv) 
 next
   case False
   then have "h_obs M q x y = None"
     using False unfolding h_obs_simps Let_def by auto
   then show ?thesis using assms by auto 
 qed 
 
 
 fun after :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a" where
   "after M q [] = q" |
   "after M q ((x,y)#io) = after M (the (h_obs M q x y)) io"
 
 (*abbreviation(input) "after_initial M io \<equiv> after M (initial M) io" *)
 abbreviation "after_initial M io \<equiv> after M (initial M) io"
 
 lemma after_path :
   assumes "observable M"
   and     "path M q p"
 shows "after M q (p_io p) = target q p"
 using assms(2) proof (induction p arbitrary: q rule: list.induct)
   case Nil
   then show ?case by auto
 next
   case (Cons t p)
   then have "t \<in> transitions M" and "path M (t_target t) p" and "t_source t = q"
     by auto
 
   have "\<And> q' . (q, t_input t, t_output t, q') \<in> FSM.transitions M \<Longrightarrow> q' = t_target t"
     using observable_transition_unique[OF assms(1) \<open>t \<in> transitions M\<close>] \<open>t \<in> transitions M\<close> 
     using \<open>t_source t = q\<close> assms(1) by auto 
   then have "({q'. (q, t_input t, t_output t, q') \<in> FSM.transitions M} = {t_target t})"
     using \<open>t \<in> transitions M\<close> \<open>t_source t = q\<close> by auto
   then have "(h_obs M q (t_input t) (t_output t)) = Some (t_target t)"
     using h_obs_Some[OF assms(1), of q "t_input t" "t_output t" "t_target t"]
     by blast 
   then have "after M q (p_io (t#p)) = after M (t_target t) (p_io p)"    
     by auto
   moreover have "target (t_target t) p = target q (t#p)"
     using \<open>t_source t = q\<close> by auto
   ultimately show ?case 
     using Cons.IH[OF \<open>path M (t_target t) p\<close>] 
     by simp
 qed
 
 lemma observable_after_path :
   assumes "observable M"
   and     "io \<in> LS M q"
 obtains p where "path M q p"
             and "p_io p = io"
             and "target q p = after M q io"
   using after_path[OF assms(1)]
   using assms(2) by auto
 
 lemma h_obs_from_LS :
   assumes "observable M"
   and     "[(x,y)] \<in> LS M q"
 obtains q' where "h_obs M q x y = Some q'"
   using assms(2) h_obs_None[OF assms(1), of q x y] by force 
 
 lemma after_h_obs :
   assumes "observable M"
   and     "h_obs M q x y = Some q'"
 shows "after M q [(x,y)] = q'"
 proof -
   have "path M q [(q,x,y,q')]"
     using assms(2) unfolding h_obs_Some[OF assms(1)]
     using single_transition_path by fastforce 
   then show ?thesis
     using assms(2) after_path[OF assms(1), of q "[(q,x,y,q')]"] by auto
 qed
 
 lemma after_h_obs_prepend :
   assumes "observable M"
   and     "h_obs M q x y = Some q'"
   and     "io \<in> LS M q'"
 shows "after M q ((x,y)#io) = after M q' io" 
 proof -
   obtain p where "path M q' p" and "p_io p = io"
     using assms(3) by auto
   then have "after M q' io = target q' p"
     using after_path[OF assms(1)]
     by blast 
 
   have "path M q ((q,x,y,q')#p)"
     using assms(2) path_prepend_t[OF \<open>path M q' p\<close>, of q x y] unfolding h_obs_Some[OF assms(1)] by auto
   moreover have "p_io ((q,x,y,q')#p) = (x,y)#io"
     using \<open>p_io p = io\<close> by auto
   ultimately have "after M q ((x,y)#io) = target q ((q,x,y,q')#p)"
     using after_path[OF assms(1), of q "(q,x,y,q')#p"] by simp
   moreover have "target q ((q,x,y,q')#p) = target q' p"
     by auto
   ultimately show ?thesis
     using \<open>after M q' io = target q' p\<close> by simp
 qed
 
 lemma after_split :
   assumes "observable M"
   and     "\<alpha>@\<gamma> \<in> LS M q"
 shows "after M (after M q \<alpha>) \<gamma> = after M q (\<alpha> @ \<gamma>)"
 proof -
   obtain p1 p2 where "path M q p1" and "path M (target q p1) p2" and "p_io p1 = \<alpha>" and "p_io p2 = \<gamma>"
     using language_state_split[OF assms(2)] 
     by blast
   then have "path M q (p1@p2)" and "p_io (p1@p2) = (\<alpha> @ \<gamma>)"
     by auto
   then have "after M q (\<alpha> @ \<gamma>) = target q (p1@p2)"
     using assms(1)
     by (metis (mono_tags, lifting) after_path) 
   moreover have "after M q \<alpha> = target q p1"
     using \<open>path M q p1\<close> \<open>p_io p1 = \<alpha>\<close> assms(1)
     by (metis (mono_tags, lifting) after_path) 
   moreover have "after M (target q p1) \<gamma> = target (target q p1) p2"
     using \<open>path M (target q p1) p2\<close> \<open>p_io p2 = \<gamma>\<close> assms(1)
     by (metis (mono_tags, lifting) after_path)
   moreover have "target (target q p1) p2 = target q (p1@p2)"
     by auto
   ultimately show ?thesis 
     by auto
 qed
 
 
 lemma after_io_targets :
   assumes "observable M"
   and     "io \<in> LS M q"
 shows "after M q io = the_elem (io_targets M io q)"
 proof -
   have "after M q io \<in> io_targets M io q"
     using after_path[OF assms(1)] assms(2)
     unfolding io_targets.simps LS.simps
     by blast 
   then show ?thesis
     using observable_io_targets[OF assms]
     by (metis singletonD the_elem_eq)
 qed
     
 
 
 lemma after_language_subset :
   assumes "observable M"
   and     "\<alpha>@\<gamma> \<in> L M"
   and     "\<beta> \<in> LS M (after_initial M (\<alpha>@\<gamma>))"
 shows "\<gamma>@\<beta> \<in> LS M (after_initial M \<alpha>)"
   by (metis after_io_targets after_split assms(1) assms(2) assms(3) language_io_target_append language_prefix observable_io_targets observable_io_targets_language singletonI the_elem_eq)
 
 
 lemma after_language_append_iff :
   assumes "observable M"
   and     "\<alpha>@\<gamma> \<in> L M"
 shows "\<beta> \<in> LS M (after_initial M (\<alpha>@\<gamma>)) = (\<gamma>@\<beta> \<in> LS M (after_initial M \<alpha>))"
   by (metis after_io_targets after_language_subset after_split assms(1) assms(2) language_prefix observable_io_targets observable_io_targets_language singletonI the_elem_eq) 
 
 
 lemma h_obs_language_iff :
   assumes "observable M"
   shows "(x,y)#io \<in> LS M q = (\<exists> q' . h_obs M q x y = Some q' \<and> io \<in> LS M q')"
     (is "?P1 = ?P2")
 proof 
   show "?P1 \<Longrightarrow> ?P2"
   proof -
     assume ?P1
     then obtain t p where "t \<in> transitions M"
                       and "path M (t_target t) p"
                       and "t_input t = x"
                       and "t_output t = y"
                       and "t_source t = q"
                       and "p_io p = io"
       by auto
     then have "(q,x,y,t_target t) \<in> transitions M"
       by auto
     then have "h_obs M q x y = Some (t_target t)"
       unfolding h_obs_Some[OF assms]
       using assms by auto 
     moreover have "io \<in> LS M (t_target t)"
       using \<open>path M (t_target t) p\<close> \<open>p_io p = io\<close>
       by auto
     ultimately show ?P2
       by blast
   qed
   show "?P2 \<Longrightarrow> ?P1"
     unfolding h_obs_Some[OF assms] using LS_prepend_transition[where io=io and M=M]
     by (metis fst_conv mem_Collect_eq singletonI snd_conv)
 qed
 
 lemma after_language_iff :
   assumes "observable M"
   and     "\<alpha> \<in> LS M q"
 shows "(\<gamma> \<in> LS M (after M q \<alpha>)) = (\<alpha>@\<gamma> \<in> LS M q)"
   by (metis after_io_targets assms(1) assms(2) language_io_target_append observable_io_targets observable_io_targets_language singletonI the_elem_eq)
 
 (* TODO: generalise to non-observable FSMs *)
 lemma language_maximal_contained_prefix_ob :
   assumes "io \<notin> LS M q"
   and     "q \<in> states M"
   and     "observable M"
 obtains io' x y io'' where "io = io'@[(x,y)]@io''"
                        and "io' \<in> LS M q"
                        and "io'@[(x,y)] \<notin> LS M q"
 proof -
   have "\<exists> io' x y io'' . io = io'@[(x,y)]@io'' \<and> io' \<in> LS M q \<and> io'@[(x,y)] \<notin> LS M q"
     using assms(1,2) proof (induction io arbitrary: q)
     case Nil
     then show ?case by auto
   next
     case (Cons xy io)
 
     obtain x y where "xy = (x,y)"
       by fastforce
 
     show ?case proof (cases "h_obs M q x y")
       case None
       then have "[]@[(x,y)] \<notin> LS M q"
         unfolding h_obs_None[OF assms(3)] by auto
       moreover have "[] \<in> LS M q"
         using Cons.prems by auto
       moreover have "(x,y)#io = []@[(x,y)]@io"
         using Cons.prems 
         unfolding \<open>xy = (x,y)\<close> by auto
       ultimately show ?thesis
         unfolding \<open>xy = (x,y)\<close> by blast
     next
       case (Some q')
       then have "io \<notin> LS M q'"
         using h_obs_language_iff[OF assms(3), of x y io q] Cons.prems(1) 
         unfolding \<open>xy = (x,y)\<close>
         by auto
       then obtain io' x' y' io'' where "io = io'@[(x',y')]@io''"
                                    and "io' \<in> LS M q'"
                                    and "io'@[(x',y')] \<notin> LS M q'" 
         using Cons.IH[OF _ h_obs_state[OF Some]]
         by blast
 
       have "xy#io = (xy#io')@[(x',y')]@io''"
         using \<open>io = io'@[(x',y')]@io''\<close> by auto
       moreover have "(xy#io') \<in> LS M q"
         using \<open>io' \<in> LS M q'\<close> Some 
         unfolding \<open>xy = (x,y)\<close> h_obs_language_iff[OF assms(3)]
         by blast
       moreover have "(xy#io')@[(x',y')] \<notin> LS M q"
         using \<open>io'@[(x',y')] \<notin> LS M q'\<close> Some h_obs_language_iff[OF assms(3), of x y "io'@[(x',y')]" q]
         unfolding \<open>xy = (x,y)\<close> 
         by auto
       ultimately show ?thesis
         by blast
     qed
   qed
   then show ?thesis 
     using that by blast
 qed
 
 lemma after_is_state :
   assumes "observable M"
   assumes "io \<in> LS M q"
   shows "FSM.after M q io \<in> states M" 
   using assms
   by (metis observable_after_path path_target_is_state) 
 
 lemma after_reachable_initial :
   assumes "observable M"
   and     "io \<in> L M"
 shows "after_initial M io \<in> reachable_states M" 
 proof -
   obtain p where "path M (initial M) p" and "p_io p = io"
     using assms(2) by auto
   then have "after_initial M io = target (initial M) p"
     using after_path[OF assms(1)]
     by blast 
   then show ?thesis
     unfolding reachable_states_def using \<open>path M (initial M) p\<close> by blast
 qed
 
 lemma after_transition :
   assumes "observable M"
   and     "(q,x,y,q') \<in> transitions M"
 shows "after M q [(x,y)] = q'"
   using after_path[OF assms(1) single_transition_path[OF assms(2)]] 
   by auto
 
 lemma after_transition_exhaust :
   assumes "observable M"
   and     "t \<in> transitions M"
 shows "t_target t = after M (t_source t) [(t_input t, t_output t)]"
   using after_transition[OF assms(1)] assms(2)
   by (metis surjective_pairing) 
 
 lemma after_reachable :
   assumes "observable M"
   and     "io \<in> LS M q"
   and     "q \<in> reachable_states M"
 shows "after M q io \<in> reachable_states M"
 proof -
   obtain p where "path M q p" and "p_io p = io"
     using assms(2) by auto
   then have "after M q io = target q p"
     using after_path[OF assms(1)] by force
 
   obtain p' where "path M (initial M) p'" and "target (initial M) p' = q"
     using assms(3) unfolding reachable_states_def by blast
 
   then have "path M (initial M) (p'@p)"
     using \<open>path M q p\<close> by auto
   moreover have "after M q io = target (initial M) (p'@p)"
     using \<open>target (initial M) p' = q\<close>
     unfolding \<open>after M q io = target q p\<close> 
     by auto
   ultimately show ?thesis
     unfolding reachable_states_def by blast
 qed
 
 lemma observable_after_language_append :
   assumes "observable M"
   and     "io1 \<in> LS M q"
   and     "io2 \<in> LS M (after M q io1)"
 shows "io1@io2 \<in> LS M q"
   using observable_after_path[OF assms(1,2)] assms(3)
 proof -
   assume a1: "\<And>thesis. (\<And>p. \<lbrakk>path M q p; p_io p = io1; target q p = after M q io1\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis"
   have "\<exists>ps. io2 = p_io ps \<and> path M (after M q io1) ps"
     using \<open>io2 \<in> LS M (after M q io1)\<close> by auto
   moreover
   { assume "(\<exists>ps. io2 = p_io ps \<and> path M (after M q io1) ps) \<and> (\<forall>ps. io1 @ io2 \<noteq> p_io ps \<or> \<not> path M q ps)"
     then have "io1 @ io2 \<in> {p_io ps |ps. path M q ps}"
       using a1 by (metis (lifting) map_append path_append) }
   ultimately show ?thesis
     by auto
 qed 
 
 
 lemma observable_after_language_none :
   assumes "observable M"
   and     "io1 \<in> LS M q"
   and     "io2 \<notin> LS M (after M q io1)"
 shows "io1@io2 \<notin> LS M q"
   using after_path[OF assms(1)] language_state_split[of  io1 io2 M q]
   by (metis (mono_tags, lifting) assms(3) language_intro) 
 
 
 lemma observable_after_eq :
   assumes "observable M"
   and     "after M q io1 = after M q io2"
   and     "io1 \<in> LS M q"
   and     "io2 \<in> LS M q"
 shows "io1@io \<in> LS M q \<longleftrightarrow> io2@io \<in> LS M q"
   using observable_after_language_append[OF assms(1,3), of io]
         observable_after_language_append[OF assms(1,4), of io]
         assms(2)
   by (metis assms(1) language_prefix observable_after_language_none) 
 
 lemma observable_after_target : 
   assumes "observable M"
   and     "io @ io' \<in> LS M q"
   and     "path M (FSM.after M q io) p"
   and     "p_io p = io'"
 shows "target (FSM.after M q io) p = (FSM.after M q (io @ io'))"
 proof -
   obtain p' where "path M q p'" and "p_io p' = io @ io'"
     using \<open>io @ io' \<in> LS M q\<close> by auto
 
   then have "path M q (take (length io) p')"
         and "p_io (take (length io) p') = io"
         and "path M (target q (take (length io) p')) (drop (length io) p')"
         and "p_io (drop (length io) p') = io'"
     using path_io_split[of M q p' io io']
     by auto
   then have "FSM.after M q io = target q (take (length io) p')"
     using after_path assms(1) by fastforce
   then have "p = (drop (length io) p')"   
     using \<open>path M (target q (take (length io) p')) (drop (length io) p')\<close> \<open>p_io (drop (length io) p') = io'\<close>
           assms(3,4)
           observable_path_unique[OF \<open>observable M\<close>]
     by force
 
   have "(FSM.after M q (io @ io')) = target q p'"
     using after_path[OF \<open>observable M\<close> \<open>path M q p'\<close>] unfolding \<open>p_io p' = io @ io'\<close> .
   moreover have "target (FSM.after M q io) p = target q p'"
     using \<open>FSM.after M q io = target q (take (length io) p')\<close>
     by (metis \<open>p = drop (length io) p'\<close> append_take_drop_id path_append_target) 
   ultimately show ?thesis
     by simp
 qed
 
 
 fun is_in_language :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
   "is_in_language M q [] = True" |
   "is_in_language M q ((x,y)#io) = (case h_obs M q x y of
     None \<Rightarrow> False |
     Some q' \<Rightarrow> is_in_language M q' io)"
 
 lemma is_in_language_iff :
   assumes "observable M"
   and     "q \<in> states M"
   shows "is_in_language M q io \<longleftrightarrow> io \<in> LS M q"
 using assms(2) proof (induction io arbitrary: q)
   case Nil
   then show ?case
     by auto 
 next
   case (Cons xy io)
 
   obtain x y where "xy = (x,y)"
     using prod.exhaust by metis
 
   show ?case 
     unfolding \<open>xy = (x,y)\<close>
     unfolding h_obs_language_iff[OF assms(1), of x y io q] 
     unfolding is_in_language.simps
     apply (cases "h_obs M q x y") 
     apply auto[1]
     by (metis Cons.IH h_obs_state option.simps(5))  
 qed
 
 lemma observable_paths_for_io :
   assumes "observable M"
   and     "io \<in> LS M q"
 obtains p where "paths_for_io M q io = {p}"
 proof -
   obtain p where "path M q p" and "p_io p = io"
     using assms(2) by auto
   then have "p \<in> paths_for_io M q io"
     unfolding paths_for_io_def 
     by blast
   then show ?thesis 
     using that[of p]
     using observable_path_unique[OF assms(1) \<open>path M q p\<close>] \<open>p_io p = io\<close>
     unfolding paths_for_io_def 
     by force
 qed
 
 lemma io_targets_language :
   assumes "q' \<in> io_targets M io q"
   shows "io \<in> LS M q"
   using assms by auto
 
 
 lemma observable_after_reachable_surj :
   assumes "observable M"
   shows "(after_initial M) ` (L M) = reachable_states M"
 proof 
   show "after_initial M ` L M \<subseteq> reachable_states M"
     using after_reachable[OF assms _ reachable_states_initial]
     by blast
   show "reachable_states M \<subseteq> after_initial M ` L M"
     unfolding reachable_states_def
     using after_path[OF assms]
     using image_iff by fastforce 
 qed
 
 
 lemma observable_minimal_size_r_language_distinct :
   assumes "minimal M1"
   and     "minimal M2"
   and     "observable M1"
   and     "observable M2"
   and     "size_r M1 < size_r M2" 
 shows "L M1 \<noteq> L M2"
 proof 
   assume "L M1 = L M2"
 
   define V where "V = (\<lambda> q . SOME io . io \<in> L M1 \<and> after_initial M2 io = q)"
 
   have "\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q"
   proof -
     fix q assume "q \<in> reachable_states M2"
     then have "\<exists> io . io \<in> L M1 \<and> after_initial M2 io = q"
       unfolding \<open>L M1 = L M2\<close>
       by (metis assms(4) imageE observable_after_reachable_surj)
     then show "V q \<in> L M1 \<and> after_initial M2 (V q) = q"
       unfolding V_def 
       using someI_ex[of "\<lambda> io . io \<in> L M1 \<and> after_initial M2 io = q"] by blast
   qed
   then have "(after_initial M1) ` V ` reachable_states M2 \<subseteq> reachable_states M1"
     by (metis assms(3) image_mono image_subsetI observable_after_reachable_surj)
   then have "card (after_initial M1 ` V ` reachable_states M2) \<le> size_r M1"
     using reachable_states_finite[of M1]
     by (meson card_mono) 
 
   have "(after_initial M2) ` V ` reachable_states M2 = reachable_states M2"
   proof 
     show "after_initial M2 ` V ` reachable_states M2 \<subseteq> reachable_states M2"
       using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> by auto
     show "reachable_states M2 \<subseteq> after_initial M2 ` V ` reachable_states M2"
       using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> observable_after_reachable_surj[OF assms(4)] unfolding \<open>L M1 = L M2\<close>
       using image_iff by fastforce
   qed
   then have "card ((after_initial M2) ` V ` reachable_states M2) = size_r M2" 
     by auto
 
   have *: "finite (V ` reachable_states M2)"
     by (simp add: reachable_states_finite) 
 
   have **: "card ((after_initial M1) ` V ` reachable_states M2) < card ((after_initial M2) ` V ` reachable_states M2)"
     using assms(5) \<open>card (after_initial M1 ` V ` reachable_states M2) \<le> size_r M1\<close>
     unfolding \<open>card ((after_initial M2) ` V ` reachable_states M2) = size_r M2\<close> 
     by linarith
 
   obtain io1 io2 where "io1 \<in> V ` reachable_states M2"
                        "io2 \<in> V ` reachable_states M2" 
                        "after_initial M2 io1 \<noteq> after_initial M2 io2" 
                        "after_initial M1 io1 = after_initial M1 io2"
     using finite_card_less_witnesses[OF * **]
     by blast
   then have "io1 \<in> L M1" and "io2 \<in> L M1" and "io1 \<in> L M2" and "io2 \<in> L M2"
     using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> unfolding \<open>L M1 = L M2\<close>
     by auto
   then have "after_initial M1 io1 \<in> reachable_states M1"
             "after_initial M1 io2 \<in> reachable_states M1"
             "after_initial M2 io1 \<in> reachable_states M2"
             "after_initial M2 io2 \<in> reachable_states M2"
     using after_reachable[OF assms(3) _ reachable_states_initial] after_reachable[OF assms(4) _ reachable_states_initial]
     by blast+
 
   obtain io3 where "io3 \<in> LS M2 (after_initial M2 io1) = (io3 \<notin> LS M2 (after_initial M2 io2))"
     using reachable_state_is_state[OF \<open>after_initial M2 io1 \<in> reachable_states M2\<close>] 
           reachable_state_is_state[OF \<open>after_initial M2 io2 \<in> reachable_states M2\<close>] 
           \<open>after_initial M2 io1 \<noteq> after_initial M2 io2\<close> assms(2)
     unfolding minimal.simps by blast
   then have "io1@io3 \<in> L M2 = (io2@io3 \<notin> L M2)"
     using observable_after_language_append[OF assms(4) \<open>io1 \<in> L M2\<close>]
           observable_after_language_append[OF assms(4) \<open>io2 \<in> L M2\<close>]
           observable_after_language_none[OF assms(4) \<open>io1 \<in> L M2\<close>]
           observable_after_language_none[OF assms(4) \<open>io2 \<in> L M2\<close>]
     by blast
   moreover have "io1@io3 \<in> L M1 = (io2@io3 \<in> L M1)"
     by (meson \<open>after_initial M1 io1 = after_initial M1 io2\<close> \<open>io1 \<in> L M1\<close> \<open>io2 \<in> L M1\<close> assms(3) observable_after_eq) 
   ultimately show False
     using \<open>L M1 = L M2\<close> by blast
 qed
 
 (* language equivalent minimal FSMs have the same number of reachable states *)
 lemma minimal_equivalence_size_r :
   assumes "minimal M1"
   and     "minimal M2"
   and     "observable M1"
   and     "observable M2"
   and     "L M1 = L M2"
 shows "size_r M1 = size_r M2" 
   using observable_minimal_size_r_language_distinct[OF assms(1-4)]
         observable_minimal_size_r_language_distinct[OF assms(2,1,4,3)]
         assms(5)
   using nat_neq_iff by auto
 
 
 subsection \<open>Conformity Relations\<close>
 
 fun is_io_reduction_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> 'd \<Rightarrow> bool" where
   "is_io_reduction_state A a B b = (LS A a \<subseteq> LS B b)"
 
 abbreviation(input) "is_io_reduction A B \<equiv> is_io_reduction_state A (initial A) B (initial B)" 
 notation 
   is_io_reduction ("_ \<preceq> _")
 
 
 fun is_io_reduction_state_on_inputs :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b list set \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> 'd \<Rightarrow> bool" where
   "is_io_reduction_state_on_inputs A a U B b = (LS\<^sub>i\<^sub>n A a U \<subseteq> LS\<^sub>i\<^sub>n B b U)"
 
 abbreviation(input) "is_io_reduction_on_inputs A U B \<equiv> is_io_reduction_state_on_inputs A (initial A) U B (initial B)" 
 notation 
   is_io_reduction_on_inputs ("_ \<preceq>\<lbrakk>_\<rbrakk> _")
 
 
 
 
 
 subsection \<open>A Pass Relation for Reduction and Test Represented as Sets of Input-Output Sequences\<close>
 
 definition pass_io_set :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
   "pass_io_set M ios = (\<forall> io x y . io@[(x,y)] \<in> ios \<longrightarrow> (\<forall> y' . io@[(x,y')] \<in> L M \<longrightarrow> io@[(x,y')] \<in> ios))"
 
 definition pass_io_set_maximal :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
   "pass_io_set_maximal M ios = (\<forall> io x y io' . io@[(x,y)]@io' \<in> ios \<longrightarrow> (\<forall> y' . io@[(x,y')] \<in> L M \<longrightarrow> (\<exists> io''. io@[(x,y')]@io'' \<in> ios)))"
 
 
 lemma pass_io_set_from_pass_io_set_maximal :
   "pass_io_set_maximal M ios = pass_io_set M {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios}"
 proof -
   have "\<And> io x y io' . io@[(x,y)]@io' \<in> ios \<Longrightarrow> io@[(x,y)] \<in> {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios}"
     by auto
   moreover have "\<And> io x y . io@[(x,y)] \<in> {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios} \<Longrightarrow> \<exists> io' . io@[(x,y)]@io' \<in> ios"
     by auto
   ultimately show ?thesis
     unfolding pass_io_set_def pass_io_set_maximal_def
     by meson 
 qed
 
 
 lemma pass_io_set_maximal_from_pass_io_set :
   assumes "finite ios"
   and     "\<And> io' io'' . io'@io'' \<in> ios \<Longrightarrow> io' \<in> ios"
 shows "pass_io_set M ios = pass_io_set_maximal M {io' \<in> ios . \<not> (\<exists> io'' . io'' \<noteq> [] \<and> io'@io'' \<in> ios)}"
 proof -
   have "\<And> io x y . io@[(x,y)] \<in> ios \<Longrightarrow> \<exists> io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)}"
   proof -
     fix io x y assume "io@[(x,y)] \<in> ios"
     show "\<exists> io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)}"
       using finite_set_elem_maximal_extension_ex[OF \<open>io@[(x,y)] \<in> ios\<close> assms(1)] by force
   qed
   moreover have "\<And> io x y io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)} \<Longrightarrow> io@[(x,y)] \<in> ios"
     using \<open>\<And> io' io'' . io'@io'' \<in> ios \<Longrightarrow> io' \<in> ios\<close> by force
   ultimately show ?thesis
     unfolding pass_io_set_def pass_io_set_maximal_def 
     by meson 
 qed
 
 
 subsection \<open>Relaxation of IO based test suites to sets of input sequences\<close>
 
 abbreviation(input) "input_portion xs \<equiv> map fst xs"
 
 lemma equivalence_io_relaxation :
   assumes "(L M1 = L M2) \<longleftrightarrow> (L M1 \<inter> T = L M2 \<inter> T)"
 shows "(L M1 = L M2) \<longleftrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})" 
 proof 
   show "(L M1 = L M2) \<Longrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
     by blast
   show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 = L M2" 
   proof -
     have *:"\<And> M . {io . io \<in> L M \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = L M \<inter> {io . \<exists> io' \<in> T . input_portion io = input_portion io'}"
       by blast
 
     have "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> (L M1 \<inter> T = L M2 \<inter> T)"
       unfolding * by blast
     then show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 = L M2"
       using assms by blast
   qed
 qed
 
 lemma reduction_io_relaxation :
   assumes "(L M1 \<subseteq> L M2) \<longleftrightarrow> (L M1 \<inter> T \<subseteq> L M2 \<inter> T)"
 shows "(L M1 \<subseteq> L M2) \<longleftrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})" 
 proof 
   show "(L M1 \<subseteq> L M2) \<Longrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
     by blast
   show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 \<subseteq> L M2" 
   proof -
     have *:"\<And> M . {io . io \<in> L M \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> L M \<inter> {io . \<exists> io' \<in> T . input_portion io = input_portion io'}"
       by blast
 
     have "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> (L M1 \<inter> T \<subseteq> L M2 \<inter> T)"
       unfolding * by blast
     then show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 \<subseteq> L M2"
       using assms by blast
   qed
 qed
 
 
 
 subsection \<open>Submachines\<close>
 
 fun is_submachine :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where 
   "is_submachine A B = (initial A = initial B \<and> transitions A \<subseteq> transitions B \<and> inputs A = inputs B \<and> outputs A = outputs B \<and> states A \<subseteq> states B)"
   
 
 lemma submachine_path_initial :
   assumes "is_submachine A B"
   and     "path A (initial A) p"
 shows "path B (initial B) p"
   using assms proof (induction p rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc a p)
   then show ?case
     by fastforce
 qed
    
 
 lemma submachine_path :
   assumes "is_submachine A B"
   and     "path A q p"
 shows "path B q p"
   by (meson assms(1) assms(2) is_submachine.elims(2) path_begin_state subsetD transition_subset_path)
   
 
 lemma submachine_reduction : 
   assumes "is_submachine A B"
   shows "is_io_reduction A B"
   using submachine_path[OF assms] assms by auto 
 
 
 lemma complete_submachine_initial :
   assumes "is_submachine A B"
       and "completely_specified A"
   shows "completely_specified_state B (initial B)"
   using assms(1) assms(2) fsm_initial subset_iff by fastforce
 
 
 lemma submachine_language :
   assumes "is_submachine S M"
   shows "L S \<subseteq> L M"
   by (meson assms is_io_reduction_state.elims(2) submachine_reduction)
 
 
 lemma submachine_observable :
   assumes "is_submachine S M"
   and     "observable M"
 shows "observable S"
   using assms unfolding is_submachine.simps observable.simps by blast
 
 
 lemma submachine_transitive :
   assumes "is_submachine S M"
   and     "is_submachine S' S"
 shows "is_submachine S' M"
   using assms unfolding is_submachine.simps by force
 
 
 lemma transitions_subset_path :
   assumes "set p \<subseteq> transitions M"
   and     "p \<noteq> []"
   and     "path S q p"
 shows "path M q p"
   using assms by (induction p arbitrary: q; auto)
 
 
 lemma transition_subset_paths :
   assumes "transitions S \<subseteq> transitions M"
   and "initial S \<in> states M"
   and "inputs S = inputs M"
   and "outputs S = outputs M"
   and "path S (initial S) p"
 shows "path M (initial S) p"
   using assms(5) proof (induction p rule: rev_induct)
 case Nil
   then show ?case using assms(2) by auto
 next
   case (snoc t p)
   then have "path S (initial S) p" 
         and "t \<in> transitions S" 
         and "t_source t = target (initial S) p" 
         and "path M (initial S) p"
     by auto
 
   have "t \<in> transitions M"
     using assms(1) \<open>t \<in> transitions S\<close> by auto
   moreover have "t_source t \<in> states M"
     using \<open>t_source t = target (initial S) p\<close> \<open>path M (initial S) p\<close>
     using path_target_is_state by fastforce 
   ultimately have "t \<in> transitions M"
     using \<open>t \<in> transitions S\<close> assms(3,4) by auto
   then show ?case
     using \<open>path M (initial S) p\<close>
     using snoc.prems by auto 
 qed 
 
 
 lemma submachine_reachable_subset :
   assumes "is_submachine A B"
 shows "reachable_states A \<subseteq> reachable_states B" 
   using assms submachine_path_initial[OF assms] 
   unfolding is_submachine.simps reachable_states_def by force
 
 
 lemma submachine_simps :
   assumes "is_submachine A B"
 shows "initial A = initial B"
 and   "states A \<subseteq> states B"
 and   "inputs A = inputs B"
 and   "outputs A = outputs B"
 and   "transitions A \<subseteq> transitions B"
   using assms unfolding is_submachine.simps by blast+
 
 
 lemma submachine_deadlock :
   assumes "is_submachine A B"
       and "deadlock_state B q"
     shows "deadlock_state A q"
   using assms(1) assms(2) in_mono by auto 
 
 
 
 subsection \<open>Changing Initial States\<close>
 
 lift_definition from_FSM :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.from_FSMI
   by simp 
 
 lemma from_FSM_simps[simp]:
   assumes "q \<in> states M"
   shows
   "initial (from_FSM M q) = q"  
   "inputs (from_FSM M q) = inputs M"
   "outputs (from_FSM M q) = outputs M"
   "transitions (from_FSM M q) = transitions M"
   "states (from_FSM M q) = states M" using assms by (transfer; simp)+
 
 
 lemma from_FSM_path_initial :
   assumes "q \<in> states M"
   shows "path M q p = path (from_FSM M q) (initial (from_FSM M q)) p"
   by (metis assms from_FSM_simps(1) from_FSM_simps(4) from_FSM_simps(5) order_refl 
         transition_subset_path)
 
 
 lemma from_FSM_path :
   assumes "q \<in> states M"
       and "path (from_FSM M q) q' p"
     shows "path M q' p"
   using assms(1) assms(2) path_transitions transitions_subset_path by fastforce
 
 
 lemma from_FSM_reachable_states :
   assumes "q \<in> reachable_states M"
   shows "reachable_states (from_FSM M q) \<subseteq> reachable_states M"
 proof
   from assms obtain p where "path M (initial M) p" and "target (initial M) p = q"
     unfolding reachable_states_def by blast
   then have "q \<in> states M"
     by (meson path_target_is_state)
 
   fix q' assume "q' \<in> reachable_states (from_FSM M q)"
   then obtain p' where "path (from_FSM M q) q p'" and "target q p' = q'"
     unfolding reachable_states_def from_FSM_simps[OF \<open>q \<in> states M\<close>] by blast
   then have "path M (initial M) (p@p')" and "target (initial M) (p@p') = q'"
     using from_FSM_path[OF \<open>q \<in> states M\<close> ] \<open>path M (initial M) p\<close>
     using \<open>target (FSM.initial M) p = q\<close> by auto
 
   then show "q' \<in> reachable_states M"
     unfolding reachable_states_def by blast
 qed
   
 
 lemma submachine_from :
   assumes "is_submachine S M"
       and "q \<in> states S"
   shows "is_submachine (from_FSM S q) (from_FSM M q)"
 proof -
   have "path S q []"
     using assms(2) by blast
   then have "path M q []"
     by (meson assms(1) submachine_path)
   then show ?thesis
     using assms(1) assms(2) by force
 qed
 
 
 lemma from_FSM_path_rev_initial :
   assumes "path M q p"
   shows "path (from_FSM M q) q p"
   by (metis (no_types) assms from_FSM_path_initial from_FSM_simps(1) path_begin_state)
 
 
 lemma from_from[simp] :  
   assumes "q1 \<in> states M"
   and     "q1' \<in> states M"
 shows "from_FSM (from_FSM M q1) q1' = from_FSM M q1'" (is "?M = ?M'") 
 proof -
   have *: "q1' \<in> states (from_FSM M q1)"
     using assms(2) unfolding from_FSM_simps(5)[OF assms(1)] by assumption
   
   have "initial ?M = initial ?M'"
   and  "states ?M = states ?M'"
   and  "inputs ?M = inputs ?M'"
   and  "outputs ?M = outputs ?M'"
   and  "transitions ?M = transitions ?M'"
     unfolding  from_FSM_simps[OF *] from_FSM_simps[OF assms(1)] from_FSM_simps[OF assms(2)] by simp+
 
   then show ?thesis by (transfer; force)
 qed
 
 
 lemma from_FSM_completely_specified : 
   assumes "completely_specified M"
 shows "completely_specified (from_FSM M q)" proof (cases "q \<in> states M")
   case True
   then show ?thesis
     using assms by auto 
 next
   case False
   then have "from_FSM M q = M" by (transfer; auto)
   then show ?thesis using assms by auto
 qed
 
 
 lemma from_FSM_single_input : 
   assumes "single_input M"
 shows "single_input (from_FSM M q)" proof (cases "q \<in> states M")
   case True
   then show ?thesis
     using assms
     by (metis from_FSM_simps(4) single_input.elims(1))  
 next
   case False
   then have "from_FSM M q = M" by (transfer; auto)
   then show ?thesis using assms
     by presburger 
 qed
 
 
 lemma from_FSM_acyclic :
   assumes "q \<in> reachable_states M"
   and     "acyclic M"
 shows "acyclic (from_FSM M q)"
   using assms(1)
         acyclic_paths_from_reachable_states[OF assms(2), of _ q]
         from_FSM_path[of q M q]
         path_target_is_state
         reachable_state_is_state[OF assms(1)]
         from_FSM_simps(1)
   unfolding acyclic.simps
             reachable_states_def
   by force
   
 
 
 lemma from_FSM_observable :
   assumes "observable M"
 shows "observable (from_FSM M q)"
 proof (cases "q \<in> states M")
   case True
   then show ?thesis
     using assms
   proof -
     have f1: "\<forall>f. observable f = (\<forall>a b c aa ab. ((a::'a, b::'b, c::'c, aa) \<notin> FSM.transitions f \<or> (a, b, c, ab) \<notin> FSM.transitions f) \<or> aa = ab)"
       by force
     have "\<forall>a f. a \<notin> FSM.states (f::('a, 'b, 'c) fsm) \<or> FSM.transitions (FSM.from_FSM f a) = FSM.transitions f"
       by (meson from_FSM_simps(4))
     then show ?thesis
       using f1 True assms by presburger
   qed  
 next
   case False
   then have "from_FSM M q = M" by (transfer; auto)
   then show ?thesis using assms by presburger
 qed
 
 
 lemma observable_language_next :
   assumes "io#ios \<in> LS M (t_source t)"
   and     "observable M"
   and     "t \<in> transitions M"
   and     "t_input t = fst io"
   and     "t_output t = snd io"
 shows "ios \<in> L (from_FSM M (t_target t))"
 proof -
   obtain p where "path M (t_source t) p" and "p_io p = io#ios"
     using assms(1)
   proof -
     assume a1: "\<And>p. \<lbrakk>path M (t_source t) p; p_io p = io # ios\<rbrakk> \<Longrightarrow> thesis"
     obtain pps :: "('a \<times> 'b) list \<Rightarrow> 'c \<Rightarrow> ('c, 'a, 'b) fsm \<Rightarrow> ('c \<times> 'a \<times> 'b \<times> 'c) list" where
       "\<forall>x0 x1 x2. (\<exists>v3. x0 = p_io v3 \<and> path x2 x1 v3) = (x0 = p_io (pps x0 x1 x2) \<and> path x2 x1 (pps x0 x1 x2))"
       by moura
     then have "\<exists>ps. path M (t_source t) ps \<and> p_io ps = io # ios"
       using assms(1) by auto
     then show ?thesis
       using a1 by meson
   qed
   then obtain t' p' where "p = t' # p'"
     by auto
   then have "t' \<in> transitions M" and "t_source t' = t_source t" and "t_input t' = fst io" and "t_output t' = snd io" 
     using \<open>path M (t_source t) p\<close> \<open>p_io p = io#ios\<close> by auto
   then have "t = t'"
     using assms(2,3,4,5) unfolding observable.simps
     by (metis (no_types, opaque_lifting) prod.expand) 
 
   then have "path M (t_target t) p'" and "p_io p' = ios"
     using \<open>p = t' # p'\<close> \<open>path M (t_source t) p\<close> \<open>p_io p = io#ios\<close> by auto
   then have "path (from_FSM M (t_target t)) (initial (from_FSM M (t_target t))) p'"
     by (meson assms(3) from_FSM_path_initial fsm_transition_target)
 
   then show ?thesis using \<open>p_io p' = ios\<close> by auto
 qed
 
 
 lemma from_FSM_language :
   assumes "q \<in> states M"
   shows "L (from_FSM M q) = LS M q"
   using assms unfolding LS.simps by (meson from_FSM_path_initial)
 
 
 lemma observable_transition_target_language_subset :
   assumes "LS M (t_source t1) \<subseteq> LS M (t_source t2)"
   and     "t1 \<in> transitions M"
   and     "t2 \<in> transitions M"
   and     "t_input t1 = t_input t2"
   and     "t_output t1 = t_output t2"
   and     "observable M"
 shows "LS M (t_target t1) \<subseteq> LS M (t_target t2)"
 proof (rule ccontr)
   assume "\<not> LS M (t_target t1) \<subseteq> LS M (t_target t2)"
   then obtain ioF where "ioF \<in> LS M (t_target t1)" and "ioF \<notin> LS M (t_target t2)"
     by blast
   then have "(t_input t1, t_output t1)#ioF \<in> LS M (t_source t1)"
     using LS_prepend_transition assms(2) by blast
   then have *: "(t_input t1, t_output t1)#ioF \<in> LS M (t_source t2)"
     using assms(1) by blast
   
   have "ioF \<in> LS M (t_target t2)"
     using observable_language_next[OF * \<open>observable M\<close> \<open>t2 \<in> transitions M\<close> ] unfolding assms(4,5) fst_conv snd_conv
     by (metis assms(3) from_FSM_language fsm_transition_target) 
   then show False
     using \<open>ioF \<notin> LS M (t_target t2)\<close> by blast
 qed
 
 lemma observable_transition_target_language_eq :
   assumes "LS M (t_source t1) = LS M (t_source t2)"
   and     "t1 \<in> transitions M"
   and     "t2 \<in> transitions M"
   and     "t_input t1 = t_input t2"
   and     "t_output t1 = t_output t2"
   and     "observable M"
 shows "LS M (t_target t1) = LS M (t_target t2)"
   using observable_transition_target_language_subset[OF _ assms(2,3,4,5,6)]
         observable_transition_target_language_subset[OF _ assms(3,2) assms(4,5)[symmetric] assms(6)]
         assms(1) 
   by blast
 
 
 lemma language_state_prepend_transition : 
   assumes "io \<in> LS (from_FSM A (t_target t)) (initial (from_FSM A (t_target t)))"
   and     "t \<in> transitions A"
 shows "p_io [t] @ io \<in> LS A (t_source t)" 
 proof -
   obtain p where "path (from_FSM A (t_target t)) (initial (from_FSM A (t_target t))) p"
            and   "p_io p = io"
     using assms(1) unfolding LS.simps by blast
   then have "path A (t_target t) p"
     by (meson assms(2) from_FSM_path_initial fsm_transition_target)
   then have "path A (t_source t) (t # p)"
     using assms(2) by auto
   then show ?thesis 
     using \<open>p_io p = io\<close> unfolding LS.simps
     by force 
 qed
 
 lemma observable_language_transition_target :
   assumes "observable M"
   and     "t \<in> transitions M"
   and     "(t_input t, t_output t) # io \<in> LS M (t_source t)"
 shows "io \<in> LS M (t_target t)"
   by (metis (no_types) assms(1) assms(2) assms(3) from_FSM_language fsm_transition_target fst_conv observable_language_next snd_conv)
 
 lemma LS_single_transition :
   "[(x,y)] \<in> LS M q \<longleftrightarrow> (\<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x \<and> t_output t = y)" 
 proof 
   show "[(x, y)] \<in> LS M q \<Longrightarrow> \<exists>t\<in>FSM.transitions M. t_source t = q \<and> t_input t = x \<and> t_output t = y" 
     by auto
   show "\<exists>t\<in>FSM.transitions M. t_source t = q \<and> t_input t = x \<and> t_output t = y \<Longrightarrow> [(x, y)] \<in> LS M q"
     by (metis LS_prepend_transition from_FSM_language fsm_transition_target language_contains_empty_sequence)
 qed
 
 lemma h_obs_language_append :
   assumes "observable M"
   and     "u \<in> L M"
   and     "h_obs M (after_initial M u) x y \<noteq> None"
 shows "u@[(x,y)] \<in> L M"
   using after_language_iff[OF assms(1,2), of "[(x,y)]"]
   using h_obs_None[OF assms(1)] assms(3)
   unfolding LS_single_transition
   by (metis old.prod.inject prod.collapse)
 
 
 lemma h_obs_language_single_transition_iff :
   assumes "observable M"
   shows "[(x,y)] \<in> LS M q \<longleftrightarrow> h_obs M q x y \<noteq> None"
   using h_obs_None[OF assms(1), of q x y] 
   unfolding LS_single_transition
   by (metis fst_conv prod.exhaust_sel snd_conv)
 
 (* TODO: generalise to non-observable FSMs *)
 lemma minimal_failure_prefix_ob :
   assumes "observable M" 
   and     "observable I"
   and     "qM \<in> states M"
   and     "qI \<in> states I"
   and     "io \<in> LS I qI - LS M qM"
 obtains io' xy io'' where "io = io'@[xy]@io''"
                       and "io' \<in> LS I qI \<inter> LS M qM"  
                       and "io'@[xy] \<in> LS I qI - LS M qM"
 proof -
   have "\<exists> io' xy io'' . io = io'@[xy]@io'' \<and> io' \<in> LS I qI \<inter> LS M qM \<and> io'@[xy] \<in> LS I qI - LS M qM"
   using assms(3,4,5) proof (induction io arbitrary: qM qI)
     case Nil
     then show ?case by auto
   next
     case (Cons xy io)
     show ?case proof (cases "[xy] \<in> LS I qI - LS M qM")
       case True
 
       have "xy # io = []@[xy]@io" 
         by auto
       moreover have "[] \<in> LS I qI \<inter> LS M qM"
         using \<open>qM \<in> states M\<close> \<open>qI \<in> states I\<close> by auto
       moreover have "[]@[xy] \<in> LS I qI - LS M qM"
         using True by auto
       ultimately show ?thesis 
         by blast
     next
       case False
 
       obtain x y where "xy = (x,y)"
         by (meson surj_pair)
 
       have "[(x,y)] \<in> LS M qM"
         using \<open>xy = (x,y)\<close> False \<open>xy # io \<in> LS I qI - LS M qM\<close>
         by (metis DiffD1 DiffI append_Cons append_Nil language_prefix)
       then obtain qM' where "(qM,x,y,qM') \<in> transitions M"
         by auto
       then have "io \<notin> LS M qM'"
         using observable_language_transition_target[OF \<open>observable M\<close>]
               \<open>xy = (x,y)\<close> \<open>xy # io \<in> LS I qI - LS M qM\<close>
         by (metis DiffD2 LS_prepend_transition fst_conv snd_conv)
 
       have "[(x,y)] \<in> LS I qI"
         using \<open>xy = (x,y)\<close> \<open>xy # io \<in> LS I qI - LS M qM\<close>
         by (metis DiffD1 append_Cons append_Nil language_prefix)
       then obtain qI' where "(qI,x,y,qI') \<in> transitions I"
         by auto
       then have "io \<in> LS I qI'"
         using observable_language_next[of xy io I "(qI,x,y,qI')", OF _ \<open>observable I\<close>]
               \<open>xy # io \<in> LS I qI - LS M qM\<close> fsm_transition_target[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>]
         unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv
         by (metis DiffD1 from_FSM_language) 
 
       obtain io' xy' io'' where "io = io'@[xy']@io''" and "io' \<in> LS I qI' \<inter> LS M qM'" and "io'@[xy'] \<in> LS I qI' - LS M qM'"
         using \<open>io \<in> LS I qI'\<close> \<open>io \<notin> LS M qM'\<close>
               Cons.IH[OF fsm_transition_target[OF \<open>(qM,x,y,qM') \<in> transitions M\<close>]
                          fsm_transition_target[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>] ] 
         unfolding fst_conv snd_conv
         by blast
 
       have "xy#io = (xy#io')@[xy']@io''"
         using \<open>io = io'@[xy']@io''\<close> \<open>xy = (x,y)\<close> by auto
       moreover have "xy#io' \<in> LS I qI \<inter> LS M qM"
         using LS_prepend_transition[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>, of io'] 
         using LS_prepend_transition[OF \<open>(qM,x,y,qM') \<in> transitions M\<close>, of io'] 
         using \<open>io' \<in> LS I qI' \<inter> LS M qM'\<close>
         unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv 
         by auto
       moreover have "(xy#io')@[xy'] \<in> LS I qI - LS M qM"
         using LS_prepend_transition[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>, of "io'@[xy']"] 
         using observable_language_transition_target[OF \<open>observable M\<close> \<open>(qM,x,y,qM') \<in> transitions M\<close>, of "io'@[xy']"] 
         using \<open>io'@[xy'] \<in> LS I qI' - LS M qM'\<close>
         unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv
         by fastforce
       ultimately show ?thesis 
         by blast
     qed
   qed
   then show ?thesis 
     using that by blast
 qed
 
 subsection \<open>Language and Defined Inputs\<close>
 
 lemma defined_inputs_code : "defined_inputs M q = t_input ` Set.filter (\<lambda>t . t_source t = q) (transitions M)"
   unfolding defined_inputs_set by force
 
 lemma defined_inputs_alt_def : "defined_inputs M q = {t_input t | t . t \<in> transitions M \<and> t_source t = q}"
   unfolding defined_inputs_code by force
 
 lemma defined_inputs_language_diff :
   assumes "x \<in> defined_inputs M1 q1"
       and "x \<notin> defined_inputs M2 q2"
     obtains y where "[(x,y)] \<in> LS M1 q1 - LS M2 q2"
   using assms unfolding defined_inputs_alt_def
 proof -
   assume a1: "x \<notin> {t_input t |t. t \<in> FSM.transitions M2 \<and> t_source t = q2}"
   assume a2: "x \<in> {t_input t |t. t \<in> FSM.transitions M1 \<and> t_source t = q1}"
   assume a3: "\<And>y. [(x, y)] \<in> LS M1 q1 - LS M2 q2 \<Longrightarrow> thesis"
   have f4: "\<nexists>p. x = t_input p \<and> p \<in> FSM.transitions M2 \<and> t_source p = q2"
     using a1 by blast
   obtain pp :: "'a \<Rightarrow> 'b \<times> 'a \<times> 'c \<times> 'b" where
     "\<forall>a. ((\<nexists>p. a = t_input p \<and> p \<in> FSM.transitions M1 \<and> t_source p = q1) \<or> a = t_input (pp a) \<and> pp a \<in> FSM.transitions M1 \<and> t_source (pp a) = q1) \<and> ((\<exists>p. a = t_input p \<and> p \<in> FSM.transitions M1 \<and> t_source p = q1) \<or> (\<forall>p. a \<noteq> t_input p \<or> p \<notin> FSM.transitions M1 \<or> t_source p \<noteq> q1))"
     by moura
   then have "x = t_input (pp x) \<and> pp x \<in> FSM.transitions M1 \<and> t_source (pp x) = q1"
     using a2 by blast
   then show ?thesis
     using f4 a3 by (metis (no_types) DiffI LS_single_transition)
 qed 
 
 lemma language_path_append :
   assumes "path M1 q1 p1"
   and     "io \<in> LS M1 (target q1 p1)"
 shows "(p_io p1 @ io) \<in> LS M1 q1" 
 proof -
   obtain p2 where "path M1 (target q1 p1) p2" and "p_io p2 = io"
     using assms(2) by auto
   then have "path M1 q1 (p1@p2)" 
     using assms(1) by auto
   moreover have "p_io (p1@p2) = (p_io p1 @ io)"
     using \<open>p_io p2 = io\<close> by auto
   ultimately show ?thesis
     by (metis (mono_tags, lifting) language_intro)
 qed
 
 lemma observable_defined_inputs_diff_ob :
   assumes "observable M1"
   and     "observable M2"
   and     "path M1 q1 p1"
   and     "path M2 q2 p2"
   and     "p_io p1 = p_io p2"
   and     "x \<in> defined_inputs M1 (target q1 p1)" 
   and     "x \<notin> defined_inputs M2 (target q2 p2)"
 obtains y where "(p_io p1)@[(x,y)] \<in> LS M1 q1 - LS M2 q2"
 proof -
   obtain y where "[(x,y)] \<in> LS M1 (target q1 p1) - LS M2 (target q2 p2)"
     using defined_inputs_language_diff[OF assms(6,7)] by blast
   then have "(p_io p1)@[(x,y)] \<in> LS M1 q1"
     using language_path_append[OF assms(3)]
     by blast
   moreover have "(p_io p1)@[(x,y)] \<notin> LS M2 q2"
     by (metis (mono_tags, lifting) DiffD2 \<open>[(x, y)] \<in> LS M1 (target q1 p1) - LS M2 (target q2 p2)\<close> assms(2) assms(4) assms(5) language_state_containment observable_path_suffix)
   ultimately show ?thesis 
     using that[of y] by blast
 qed
 
 
 lemma observable_defined_inputs_diff_language :
   assumes "observable M1"
   and     "observable M2"
   and     "path M1 q1 p1"
   and     "path M2 q2 p2"
   and     "p_io p1 = p_io p2"
   and     "defined_inputs M1 (target q1 p1) \<noteq> defined_inputs M2 (target q2 p2)"
 shows "LS M1 q1 \<noteq> LS M2 q2"
 proof -
   obtain x where "(x \<in> defined_inputs M1 (target q1 p1) - defined_inputs M2 (target q2 p2))
                   \<or> (x \<in> defined_inputs M2 (target q2 p2) - defined_inputs M1 (target q1 p1))"
     using assms by blast
   then consider "(x \<in> defined_inputs M1 (target q1 p1) - defined_inputs M2 (target q2 p2))" |
                 "(x \<in> defined_inputs M2 (target q2 p2) - defined_inputs M1 (target q1 p1))" 
     by blast
   then show ?thesis
   proof cases
     case 1
     then show ?thesis 
       using observable_defined_inputs_diff_ob[OF assms(1-5), of x] by blast
   next
     case 2
     then show ?thesis 
       using observable_defined_inputs_diff_ob[OF assms(2,1,4,3) assms(5)[symmetric], of x] by blast
   qed
 qed
 
 fun maximal_prefix_in_language :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> ('b \<times>'c) list" where
   "maximal_prefix_in_language M q [] = []" |
   "maximal_prefix_in_language M q ((x,y)#io) = (case h_obs M q x y of
     None \<Rightarrow> [] |
     Some q' \<Rightarrow> (x,y)#maximal_prefix_in_language M q' io)"
 
 lemma maximal_prefix_in_language_properties :
   assumes "observable M"
   and     "q \<in> states M"
 shows "maximal_prefix_in_language M q io \<in> LS M q"
 and   "maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
 proof -
   have "maximal_prefix_in_language M q io \<in> LS M q \<and> maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
     using assms(2) proof (induction io arbitrary: q)
     case Nil
     then show ?case by auto
   next
     case (Cons xy io)
 
     obtain x y where "xy = (x,y)"
       using prod.exhaust by metis
 
     show ?case proof (cases "h_obs M q x y")
       case None
       then have "maximal_prefix_in_language M q (xy#io) = []"
         unfolding \<open>xy = (x,y)\<close>
         by auto
       then show ?thesis
         by (metis (mono_tags, lifting) Cons.prems append_self_conv2 from_FSM_language language_contains_empty_sequence mem_Collect_eq prefixes_set) 
     next
       case (Some q')
       then have *: "maximal_prefix_in_language M q (xy#io) = (x,y)#maximal_prefix_in_language M q' io"
         unfolding \<open>xy = (x,y)\<close>
         by auto
 
       have "q' \<in> states M"
         using h_obs_state[OF Some] by auto
       then have "maximal_prefix_in_language M q' io \<in> LS M q'" 
             and "maximal_prefix_in_language M q' io \<in> list.set (prefixes io)"
         using Cons.IH by auto
 
       have "maximal_prefix_in_language M q (xy # io) \<in> LS M q"
         unfolding *
         using Some \<open>maximal_prefix_in_language M q' io \<in> LS M q'\<close>
         by (meson assms(1) h_obs_language_iff)
       moreover have "maximal_prefix_in_language M q (xy # io) \<in> list.set (prefixes (xy # io))"
         unfolding * 
         unfolding \<open>xy = (x,y)\<close>
         using \<open>maximal_prefix_in_language M q' io \<in> list.set (prefixes io)\<close> append_Cons
         unfolding prefixes_set
         by auto 
       ultimately show ?thesis
         by blast
     qed
   qed
   then show "maximal_prefix_in_language M q io \<in> LS M q"
        and  "maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
     by auto
 qed
 
 
 subsection \<open>Further Reachability Formalisations\<close>
 
 (* states that are reachable in at most k transitions *)
 fun reachable_k :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a set" where
   "reachable_k M q n = {target q p | p . path M q p \<and> length p \<le> n}" 
 
 
 lemma reachable_k_0_initial : "reachable_k M (initial M) 0 = {initial M}" 
   by auto
 
 lemma reachable_k_states : "reachable_states M = reachable_k M (initial M) ( size M - 1)"
 proof -
   have "\<And>q. q \<in> reachable_states M \<Longrightarrow> q \<in> reachable_k M (initial M) ( size M - 1)"
   proof -
     fix q assume "q \<in> reachable_states M"
     then obtain p where "path M (initial M) p" and "target (initial M) p = q"
       unfolding reachable_states_def by blast
     then obtain p' where "path M (initial M) p'"
                      and "target (initial M) p' = target (initial M) p" 
                      and "length p' < size M"
       by (metis acyclic_path_from_cyclic_path acyclic_path_length_limit)
     then show "q \<in> reachable_k M (initial M) ( size M - 1)"
       using \<open>target (FSM.initial M) p = q\<close> less_trans by auto
   qed
 
   moreover have "\<And>x. x \<in> reachable_k M (initial M) ( size M - 1) \<Longrightarrow> x \<in> reachable_states M"
     unfolding reachable_states_def reachable_k.simps by blast
   
   ultimately show ?thesis by blast
 qed
 
 
   
 subsubsection \<open>Induction Schemes\<close>
 
 
   
 lemma acyclic_induction [consumes 1, case_names reachable_state]:
   assumes "acyclic M"
       and "\<And> q . q \<in> reachable_states M \<Longrightarrow> (\<And> t . t \<in> transitions M \<Longrightarrow> ((t_source t = q) \<Longrightarrow> P (t_target t))) \<Longrightarrow> P q"
     shows "\<forall> q \<in> reachable_states M . P q"
 proof 
   fix q assume "q \<in> reachable_states M"
 
   let ?k = "Max (image length {p . path M q p})"
   have "finite {p . path M q p}" using acyclic_finite_paths_from_reachable_state[OF assms(1)] 
     using \<open>q \<in> reachable_states M\<close> unfolding reachable_states_def by force
   then have k_prop: "(\<forall> p . path M q p \<longrightarrow> length p \<le> ?k)" by auto
 
   moreover have "\<And> q k . q \<in> reachable_states M \<Longrightarrow> (\<forall> p . path M q p \<longrightarrow> length p \<le> k) \<Longrightarrow> P q"
   proof -
     fix q k assume "q \<in> reachable_states M" and "(\<forall> p . path M q p \<longrightarrow> length p \<le> k)"
     then show "P q" 
     proof (induction k arbitrary: q)
       case 0
       then have "{p . path M q p} = {[]}" using reachable_state_is_state[OF \<open>q \<in> reachable_states M\<close>]
         by blast  
       then have "LS M q \<subseteq> {[]}" unfolding LS.simps by blast
       then have "deadlock_state M q" using deadlock_state_alt_def by metis
       then show ?case using assms(2)[OF \<open>q \<in> reachable_states M\<close>] unfolding deadlock_state.simps by blast
     next
       case (Suc k)
       have "\<And> t . t \<in> transitions M \<Longrightarrow> (t_source t = q) \<Longrightarrow> P (t_target t)"
       proof -
         fix t assume "t \<in> transitions M" and "t_source t = q" 
         then have "t_target t \<in> reachable_states M"
           using \<open>q \<in> reachable_states M\<close> using reachable_states_next by metis
         moreover have "\<forall>p. path M (t_target t) p \<longrightarrow> length p \<le> k"
           using Suc.prems(2) \<open>t \<in> transitions M\<close> \<open>t_source t = q\<close> by auto
         ultimately show "P (t_target t)" 
           using Suc.IH unfolding reachable_states_def by blast 
       qed
       then show ?case using assms(2)[OF Suc.prems(1)] by blast
     qed
   qed
 
   ultimately show "P q" using \<open>q \<in> reachable_states M\<close> by blast
 qed
 
 lemma reachable_states_induct [consumes 1, case_names init transition] :
   assumes "q \<in> reachable_states M" 
   and "P (initial M)"
   and     "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t \<in> reachable_states M \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)"
 shows "P q"
 proof -
   from assms(1) obtain p where "path M (initial M) p" and "target (initial M) p = q"
     unfolding reachable_states_def by auto
   then show "P q"
   proof (induction p arbitrary: q rule: rev_induct)
     case Nil
     then show ?case using assms(2) by auto
   next
     case (snoc t p)
 
     then have "target (initial M) p = t_source t"
       by auto
     then have "P (t_source t)"
       using snoc.IH snoc.prems by auto
     moreover have "t \<in> transitions M"
       using snoc.prems by auto
     moreover have "t_source t \<in> reachable_states M"
       by (metis \<open>target (FSM.initial M) p = t_source t\<close> path_prefix reachable_states_intro snoc.prems(1))
     moreover have "t_target t = q"
       using snoc.prems by auto
     ultimately show ?case
       using assms(3) by blast
   qed
 qed
 
 lemma reachable_states_cases [consumes 1, case_names init transition] : 
   assumes "q \<in> reachable_states M"
   and     "P (initial M)"
   and     "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t \<in> reachable_states M \<Longrightarrow> P (t_target t)"
 shows "P q"
   by (metis assms(1) assms(2) assms(3) reachable_states_induct)
 
 
 subsection \<open>Further Path Enumeration Algorithms\<close>
 
 fun paths_for_input' :: "('a \<Rightarrow> ('b \<times> 'c \<times> 'a) set) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> ('a,'b,'c) path set" where
   "paths_for_input' f [] q prev = {prev}" |
   "paths_for_input' f (x#xs) q prev = \<Union>(image (\<lambda>(x',y',q') . paths_for_input' f xs q' (prev@[(q,x,y',q')])) (Set.filter (\<lambda>(x',y',q') . x' = x) (f q)))"
 
 lemma paths_for_input'_set :
   assumes "q \<in> states M"
   shows   "paths_for_input' (h_from M) xs q prev = {prev@p | p . path M q p \<and> map fst (p_io p) = xs}"
 using assms proof (induction xs arbitrary: q prev)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
 
   let ?UN = "\<Union>(image (\<lambda>(x',y',q') . paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])) (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q)))"
 
   have "?UN = {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
   proof 
     have "\<And> p . p \<in> ?UN \<Longrightarrow> p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
     proof -
       fix p assume "p \<in> ?UN"
       then obtain y' q' where "(x,y',q') \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))"
                      and   "p \<in> paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])"
         by auto
       
       from \<open>(x,y',q') \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))\<close> have "q' \<in> states M" and "(q,x,y',q') \<in> transitions M"
         using fsm_transition_target unfolding h.simps by auto
 
       have "p \<in> {(prev @ [(q, x, y', q')]) @ p |p. path M q' p \<and> map fst (p_io p) = xs}"
         using \<open>p \<in> paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])\<close>
         unfolding Cons.IH[OF \<open>q' \<in> states M\<close>] by assumption
       moreover have "{(prev @ [(q, x, y', q')]) @ p |p. path M q' p \<and> map fst (p_io p) = xs} 
                       \<subseteq> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
         using \<open>(q,x,y',q') \<in> transitions M\<close>
         using cons by force 
       ultimately show "p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}" 
         by blast
     qed
     then show "?UN \<subseteq> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
       by blast
 
     have "\<And> p . p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs} \<Longrightarrow> p \<in> ?UN"
     proof -
       fix pp assume "pp \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
       then obtain p where "pp = prev@p" and "path M q p" and "map fst (p_io p) = x#xs"
         by fastforce
       then obtain t p' where "p = t#p'" and "path M q (t#p')" and "map fst (p_io (t#p')) = x#xs" and "map fst (p_io p') = xs"
         by (metis (no_types, lifting) map_eq_Cons_D)
       then have "path M (t_target t) p'" and "t_source t = q" and "t_input t = x" and "t_target t \<in> states M" and "t \<in> transitions M"
         by auto
 
       have "(x,t_output t,t_target t) \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))"
         using \<open>t \<in> transitions M\<close> \<open>t_input t = x\<close> \<open>t_source t = q\<close>
         unfolding h.simps by auto 
       moreover have "(prev@p) \<in> paths_for_input' (h_from M) xs (t_target t) (prev@[(q,x,t_output t,t_target t)])"
         using Cons.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[(q, x, t_output t, t_target t)]"]
         using \<open>\<And>thesis. (\<And>t p'. \<lbrakk>p = t # p'; path M q (t # p'); map fst (p_io (t # p')) = x # xs; map fst (p_io p') = xs\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> 
               \<open>p = t # p'\<close> 
               \<open>paths_for_input' (h_from M) xs (t_target t) (prev @ [(q, x, t_output t, t_target t)]) 
                 = {(prev @ [(q, x, t_output t, t_target t)]) @ p |p. path M (t_target t) p \<and> map fst (p_io p) = xs}\<close> 
               \<open>t_input t = x\<close> 
               \<open>t_source t = q\<close> 
         by fastforce
 
       ultimately show "pp \<in> ?UN" unfolding \<open>pp = prev@p\<close>
         by blast 
     qed
     then show "{prev@p | p . path M q p \<and> map fst (p_io p) = x#xs} \<subseteq> ?UN"
       by (meson subsetI) 
   qed
 
   then show ?case
     by (metis paths_for_input'.simps(2)) 
     
 qed
 
 
 definition paths_for_input :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('a,'b,'c) path set" where
   "paths_for_input M q xs = {p . path M q p \<and> map fst (p_io p) = xs}"
 
 lemma paths_for_input_set_code[code] :
   "paths_for_input M q xs = (if q \<in> states M then paths_for_input' (h_from M) xs q [] else {})"
   using paths_for_input'_set[of q M xs "[]"] 
   unfolding paths_for_input_def
   by (cases "q \<in> states M"; auto; simp add: path_begin_state)
 
 
 fun paths_up_to_length_or_condition_with_witness' :: 
     "('a \<Rightarrow> ('b \<times> 'c \<times> 'a) set) \<Rightarrow> (('a,'b,'c) path \<Rightarrow> 'd option) \<Rightarrow> ('a,'b,'c) path \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> (('a,'b,'c) path \<times> 'd) set" 
   where
   "paths_up_to_length_or_condition_with_witness' f P prev 0 q = (case P prev of Some w \<Rightarrow> {(prev,w)} | None \<Rightarrow> {})" |
   "paths_up_to_length_or_condition_with_witness' f P prev (Suc k) q = (case P prev of 
     Some w \<Rightarrow> {(prev,w)} | 
     None \<Rightarrow> (\<Union>(image (\<lambda>(x,y,q') . paths_up_to_length_or_condition_with_witness' f P (prev@[(q,x,y,q')]) k q') (f q))))"
 
 
 
 lemma paths_up_to_length_or_condition_with_witness'_set :
   assumes "q \<in> states M"
   shows   "paths_up_to_length_or_condition_with_witness' (h_from M) P prev k q 
             = {(prev@p,x) | p x . path M q p 
                                   \<and> length p \<le> k 
                                   \<and> P (prev@p) = Some x 
                                   \<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
 using assms proof (induction k arbitrary: q prev)
   case 0
   then show ?case proof (cases "P prev")
     case None then show ?thesis by auto
   next
     case (Some w) 
     then show ?thesis by (simp add: "0.prems" nil)
   qed
 next
   case (Suc k) 
   then show ?case proof (cases "P prev")
     case (Some w) 
     then have "(prev,w) \<in> {(prev@p,x) | p x . path M q p 
                                               \<and> length p \<le> Suc k 
                                               \<and> P (prev@p) = Some x 
                                               \<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
       by (simp add: Suc.prems nil) 
     then have "{(prev@p,x) | p x . path M q p 
                                     \<and> length p \<le> Suc k 
                                     \<and> P (prev@p) = Some x 
                                     \<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)} 
               = {(prev,w)}"
       using Some by fastforce
       
     then show ?thesis using Some by auto
   next
     case None 
 
     have "(\<Union>(image (\<lambda>(x,y,q') . paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q') (h_from M q))) 
             = {(prev@p,x) | p x . path M q p 
                                   \<and> length p \<le> Suc k 
                                   \<and> P (prev@p) = Some x 
                                   \<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
          (is "?UN = ?PX")
     proof -
       have *: "\<And> pp . pp \<in> ?UN \<Longrightarrow> pp \<in> ?PX"
       proof -
         fix pp assume "pp \<in> ?UN"
         then obtain x y q' where "(x,y,q') \<in> h_from M q"
                            and   "pp \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q'"
           by blast
         then have "(q,x,y,q') \<in> transitions M" by auto
         then have "q' \<in> states M" using fsm_transition_target by auto
         
         obtain p w where "pp = ((prev@[(q,x,y,q')])@p,w)" 
                    and   "path M q' p"
                    and   "length p \<le> k"
                    and   "P ((prev @ [(q, x, y, q')]) @ p) = Some w"
                    and   "\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev @ [(q, x, y, q')]) @ p') = None"
           using \<open>pp \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q'\<close> 
           unfolding Suc.IH[OF \<open>q' \<in> states M\<close>, of "prev@[(q,x,y,q')]"] 
           by blast
         
         have "path M q ((q,x,y,q')#p)" 
           using \<open>path M q' p\<close> \<open>(q,x,y,q') \<in> transitions M\<close> by (simp add: path_prepend_t) 
         moreover have "length ((q,x,y,q')#p) \<le> Suc k" 
           using \<open>length p \<le> k\<close> by auto
         moreover have "P (prev @ ([(q, x, y, q')] @ p)) = Some w" 
           using \<open>P ((prev @ [(q, x, y, q')]) @ p) = Some w\<close> by auto
         moreover have "\<And> p' p''. ((q,x,y,q')#p) = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None" 
           using \<open>\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev @ [(q, x, y, q')]) @ p') = None\<close>
           using None 
           by (metis (no_types, opaque_lifting) append.simps(1) append_Cons append_Nil2 append_assoc 
                 list.inject neq_Nil_conv) 
 
         ultimately show "pp \<in> ?PX" 
           unfolding \<open>pp = ((prev@[(q,x,y,q')])@p,w)\<close> by auto  
       qed
       
       have **: "\<And> pp . pp \<in> ?PX \<Longrightarrow> pp \<in> ?UN"
       proof -
         fix pp assume "pp \<in> ?PX"
         then obtain p' w where "pp = (prev @ p', w)"
                         and   "path M q p'"
                         and   "length p' \<le> Suc k"
                         and   "P (prev @ p') = Some w"
                         and   "\<And> p' p''. p' = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None"
           by blast
         moreover obtain t p where "p' = t#p" using \<open>P (prev @ p') = Some w\<close> using None
           by (metis append_Nil2 list.exhaust option.distinct(1)) 
         
         
         have "pp = ((prev @ [t])@p, w)" 
           using \<open>pp = (prev @ p', w)\<close> unfolding \<open>p' = t#p\<close> by auto
         have "path M q (t#p)" 
           using \<open>path M q p'\<close> unfolding \<open>p' = t#p\<close> by auto
         have p2: "length (t#p) \<le> Suc k" 
           using \<open>length p' \<le> Suc k\<close> unfolding \<open>p' = t#p\<close> by auto
         have p3: "P ((prev @ [t])@p) = Some w" 
           using \<open>P (prev @ p') = Some w\<close> unfolding \<open>p' = t#p\<close> by auto
         have p4: "\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev@[t]) @ p') = None"
           using \<open>\<And> p' p''. p' = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None\<close> \<open>pp \<in> ?PX\<close> 
           unfolding \<open>pp = ((prev @ [t]) @ p, w)\<close> \<open>p' = t#p\<close> 
           by auto
 
         have "t \<in> transitions M" and p1: "path M (t_target t) p" and "t_source t = q"
           using \<open>path M q (t#p)\<close> by auto
         then have "t_target t \<in> states M" 
               and "(t_input t, t_output t, t_target t) \<in> h_from M q" 
               and "t_source t = q"
           using fsm_transition_target by auto
         then have "t = (q,t_input t, t_output t, t_target t)"
           by auto
 
         have "((prev @ [t])@p, w) \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[t]) k (t_target t)"
           unfolding Suc.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[t]"]
           using p1 p2 p3 p4 by auto
           
 
         then show "pp \<in> ?UN"
           unfolding \<open>pp = ((prev @ [t])@p, w)\<close>  
         proof -
           have "paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [t]) k (t_target t) 
                 = paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [(q, t_input t, t_output t, t_target t)]) k (t_target t)"
             using \<open>t = (q, t_input t, t_output t, t_target t)\<close> by presburger
           then show "((prev @ [t]) @ p, w) \<in> (\<Union>(b, c, a)\<in>h_from M q. paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [(q, b, c, a)]) k a)"
             using \<open>((prev @ [t]) @ p, w) \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [t]) k (t_target t)\<close> 
                   \<open>(t_input t, t_output t, t_target t) \<in> h_from M q\<close> 
             by blast
         qed
       qed
 
       show ?thesis
         using subsetI[of ?UN ?PX, OF *] subsetI[of ?PX ?UN, OF **] subset_antisym by blast
     qed
 
     then show ?thesis 
       using None unfolding paths_up_to_length_or_condition_with_witness'.simps by simp
   qed
 qed
 
 
 definition paths_up_to_length_or_condition_with_witness :: 
   "('a,'b,'c) fsm \<Rightarrow> (('a,'b,'c) path \<Rightarrow> 'd option) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> (('a,'b,'c) path \<times> 'd) set" 
   where
   "paths_up_to_length_or_condition_with_witness M P k q 
     = {(p,x) | p x . path M q p 
                       \<and> length p \<le> k 
                       \<and> P p = Some x 
                       \<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P p' = None)}"
 
 
 lemma paths_up_to_length_or_condition_with_witness_code[code] :
   "paths_up_to_length_or_condition_with_witness M P k q 
     = (if q \<in> states M then paths_up_to_length_or_condition_with_witness' (h_from M) P [] k q
                       else {})" 
 proof (cases "q \<in> states M")
   case True
   then show ?thesis 
     unfolding paths_up_to_length_or_condition_with_witness_def 
               paths_up_to_length_or_condition_with_witness'_set[OF True] 
     by auto
 next
   case False
   then show ?thesis 
     unfolding paths_up_to_length_or_condition_with_witness_def
     using path_begin_state by fastforce 
 qed
 
 
 lemma paths_up_to_length_or_condition_with_witness_finite : 
   "finite (paths_up_to_length_or_condition_with_witness M P k q)"
 proof -
   have "paths_up_to_length_or_condition_with_witness M P k q 
           \<subseteq> {(p, the (P p)) | p . path M q p \<and> length p \<le> k}"
     unfolding paths_up_to_length_or_condition_with_witness_def
     by auto 
   moreover have "finite {(p, the (P p)) | p . path M q p \<and> length p \<le> k}" 
     using paths_finite[of M q k]
     by simp 
   ultimately show ?thesis
     using rev_finite_subset by auto 
 qed
 
   
 
 
 subsection \<open>More Acyclicity Properties\<close>
 
 
 lemma maximal_path_target_deadlock :
   assumes "path M (initial M) p"
   and     "\<not>(\<exists> p' . path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p')"
 shows "deadlock_state M (target (initial M) p)"
 proof -
   have "\<not>(\<exists> t \<in> transitions M . t_source t = target (initial M) p)"
     using assms(2) unfolding is_prefix_prefix
     by (metis append_Nil2 assms(1) not_Cons_self2 path_append_transition same_append_eq)
   then show ?thesis by auto
 qed
 
 lemma path_to_deadlock_is_maximal :
   assumes "path M (initial M) p"
   and     "deadlock_state M (target (initial M) p)"
 shows "\<not>(\<exists> p' . path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p')"
 proof 
   assume "\<exists>p'. path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p'"
   then obtain p' where "path M (initial M) p'" and "is_prefix p p'" and "p \<noteq> p'" by blast
   then have "length p' > length p"
     unfolding is_prefix_prefix by auto
   then obtain t p2 where "p' = p @ [t] @ p2"
     using \<open>is_prefix p p'\<close> unfolding is_prefix_prefix
     by (metis \<open>p \<noteq> p'\<close> append.left_neutral append_Cons append_Nil2 non_sym_dist_pairs'.cases) 
   then have "path M (initial M) (p@[t])"
     using \<open>path M (initial M) p'\<close> by auto
   then have "t \<in> transitions M" and "t_source t = target (initial M) p"
     by auto
   then show "False"
     using \<open>deadlock_state M (target (initial M) p)\<close> unfolding deadlock_state.simps by blast
 qed
 
 
 
 definition maximal_acyclic_paths :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) path set" where
   "maximal_acyclic_paths M = {p . path M (initial M) p 
                                   \<and> distinct (visited_states (initial M) p) 
                                   \<and> \<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p') 
                                               \<and> distinct (visited_states (initial M) (p@p')))}"
 
 
 (* very inefficient construction *)
 lemma maximal_acyclic_paths_code[code] :  
   "maximal_acyclic_paths M = (let ps = acyclic_paths_up_to_length M (initial M) (size M - 1)
                                in Set.filter (\<lambda>p . \<not> (\<exists> p' \<in> ps . p' \<noteq> p \<and> is_prefix p p')) ps)"
 proof -
   have scheme1: "\<And> P p . (\<exists> p' . p' \<noteq> [] \<and> P (p@p')) = (\<exists> p' \<in> {p . P p} . p' \<noteq> p \<and> is_prefix p p')"
     unfolding is_prefix_prefix by blast
 
   have scheme2: "\<And> p . (path M (FSM.initial M) p 
                           \<and> length p \<le> FSM.size M - 1 
                           \<and> distinct (visited_states (FSM.initial M) p)) 
                       = (path M (FSM.initial M) p \<and> distinct (visited_states (FSM.initial M) p))"
     using acyclic_path_length_limit by fastforce 
 
   show ?thesis
     unfolding maximal_acyclic_paths_def acyclic_paths_up_to_length.simps Let_def 
     unfolding scheme1[of "\<lambda>p . path M (initial M) p \<and> distinct (visited_states (initial M) p)"]
     unfolding scheme2 by fastforce
 qed
 
 
 
 lemma maximal_acyclic_path_deadlock :
   assumes "acyclic M"
   and     "path M (initial M) p"
 shows "\<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p') \<and> distinct (visited_states (initial M) (p@p'))) 
         = deadlock_state M (target (initial M) p)"
 proof -
   have "deadlock_state M (target (initial M) p) \<Longrightarrow> \<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p') 
           \<and> distinct (visited_states (initial M) (p@p')))"
     unfolding deadlock_state.simps 
     using assms(2) by (metis path.cases path_suffix) 
   then show ?thesis
     by (metis acyclic.elims(2) assms(1) assms(2) is_prefix_prefix maximal_path_target_deadlock 
           self_append_conv) 
 qed
   
 
 lemma maximal_acyclic_paths_deadlock_targets : 
   assumes "acyclic M"
   shows "maximal_acyclic_paths M 
           = { p . path M (initial M) p \<and> deadlock_state M (target (initial M) p)}"
   using maximal_acyclic_path_deadlock[OF assms] 
   unfolding maximal_acyclic_paths_def
   by (metis (no_types, lifting) acyclic.elims(2) assms)
 
 
 lemma cycle_from_cyclic_path :
   assumes "path M q p"
   and     "\<not> distinct (visited_states q p)"
 obtains i j where
   "take j (drop i p) \<noteq> []"
   "target (target q (take i p)) (take j (drop i p)) = (target q (take i p))"
   "path M (target q (take i p)) (take j (drop i p))"
 proof -
   obtain i j where "i < j" and "j < length (visited_states q p)" 
                and "(visited_states q p) ! i = (visited_states q p) ! j"
     using assms(2) non_distinct_repetition_indices by blast 
 
   have "(target q (take i p)) = (visited_states q p) ! i"
     using \<open>i < j\<close> \<open>j < length (visited_states q p)\<close>
     by (metis less_trans take_last_index target.simps visited_states_take)
 
   then have "(target q (take i p)) = (visited_states q p) ! j"
     using \<open>(visited_states q p) ! i = (visited_states q p) ! j\<close> by auto
 
   have p1: "take (j-i) (drop i p) \<noteq> []"
     using \<open>i < j\<close> \<open>j < length (visited_states q p)\<close> by auto 
 
   have "target (target q (take i p)) (take (j-i) (drop i p)) = (target q (take j p))"
     using \<open>i < j\<close> by (metis add_diff_inverse_nat less_asym' path_append_target take_add)
   then have p2: "target (target q (take i p)) (take (j-i) (drop i p)) = (target q (take i p))"
     using \<open>(target q (take i p)) = (visited_states q p) ! i\<close>
     using \<open>(target q (take i p)) = (visited_states q p) ! j\<close>
     by (metis \<open>j < length (visited_states q p)\<close> take_last_index target.simps visited_states_take)
 
   have p3: "path M (target q (take i p)) (take (j-i) (drop i p))"
     by (metis append_take_drop_id assms(1) path_append_elim)
 
   show ?thesis using p1 p2 p3 that by blast
 qed
 
 
 
 lemma acyclic_single_deadlock_reachable :
   assumes "acyclic M"
   and     "\<And> q' . q' \<in> reachable_states M \<Longrightarrow> q' = qd \<or> \<not> deadlock_state M q'"
 shows "qd \<in> reachable_states M"
   using acyclic_deadlock_reachable[OF assms(1)]
   using assms(2) by auto 
 
 
 lemma acyclic_paths_to_single_deadlock :
   assumes "acyclic M"
   and     "\<And> q' . q' \<in> reachable_states M \<Longrightarrow> q' = qd \<or> \<not> deadlock_state M q'"
   and     "q \<in> reachable_states M"
 obtains p where "path M q p" and "target q p = qd"
 proof -
   have "q \<in> states M" using assms(3) reachable_state_is_state by metis
   have "acyclic (from_FSM M q)"
     using from_FSM_acyclic[OF assms(3,1)] by assumption
 
   have *: "(\<And>q'. q' \<in> reachable_states (FSM.from_FSM M q) 
                 \<Longrightarrow> q' = qd \<or> \<not> deadlock_state (FSM.from_FSM M q) q')"
     using assms(2) from_FSM_reachable_states[OF assms(3)] 
     unfolding deadlock_state.simps from_FSM_simps[OF \<open>q \<in> states M\<close>] by blast
 
   obtain p where "path (from_FSM M q) q p" and "target q p = qd"
     using acyclic_single_deadlock_reachable[OF \<open>acyclic (from_FSM M q)\<close> *]
     unfolding reachable_states_def from_FSM_simps[OF \<open>q \<in> states M\<close>]
     by blast 
 
   then show ?thesis
     using that by (metis \<open>q \<in> FSM.states M\<close> from_FSM_path) 
 qed
 
 
 
 subsection \<open>Elements as Lists\<close>
 
 fun states_as_list :: "('a :: linorder, 'b, 'c) fsm \<Rightarrow> 'a list" where
   "states_as_list M = sorted_list_of_set (states M)"
 
 lemma states_as_list_distinct : "distinct (states_as_list M)" by auto
 
 lemma states_as_list_set : "set (states_as_list M) = states M"
   by (simp add: fsm_states_finite)
 
 
 fun reachable_states_as_list :: "('a :: linorder, 'b, 'c) fsm \<Rightarrow> 'a list" where
   "reachable_states_as_list M = sorted_list_of_set (reachable_states M)"
 
 lemma reachable_states_as_list_distinct : "distinct (reachable_states_as_list M)" by auto
 
 lemma reachable_states_as_list_set : "set (reachable_states_as_list M) = reachable_states M"
   by (metis fsm_states_finite infinite_super reachable_state_is_state reachable_states_as_list.simps 
         set_sorted_list_of_set subsetI)  
 
 
 fun inputs_as_list :: "('a, 'b :: linorder, 'c) fsm \<Rightarrow> 'b list" where
   "inputs_as_list M = sorted_list_of_set (inputs M)"
 
 lemma inputs_as_list_set : "set (inputs_as_list M) = inputs M"
   by (simp add: fsm_inputs_finite)
 
 lemma inputs_as_list_distinct : "distinct (inputs_as_list M)" by auto
 
 fun transitions_as_list :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a,'b,'c) transition list" where
   "transitions_as_list M = sorted_list_of_set (transitions M)"
 
 lemma transitions_as_list_set : "set (transitions_as_list M) = transitions M"
   by (simp add: fsm_transitions_finite)
 
 fun outputs_as_list :: "('a,'b,'c :: linorder) fsm \<Rightarrow> 'c list" where
   "outputs_as_list M = sorted_list_of_set (outputs M)"
 
 lemma outputs_as_list_set : "set (outputs_as_list M) = outputs M"
   by (simp add: fsm_outputs_finite)
 
 fun ftransitions :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a,'b,'c) transition fset" where
   "ftransitions M = fset_of_list (transitions_as_list M)"
 
 fun fstates :: "('a :: linorder,'b,'c) fsm \<Rightarrow> 'a fset" where
   "fstates M = fset_of_list (states_as_list M)"
 
 fun finputs :: "('a,'b :: linorder,'c) fsm \<Rightarrow> 'b fset" where
   "finputs M = fset_of_list (inputs_as_list M)"
 
 fun foutputs :: "('a,'b,'c :: linorder) fsm \<Rightarrow> 'c fset" where
   "foutputs M = fset_of_list (outputs_as_list M)"
 
 lemma fstates_set : "fset (fstates M) = states M" 
   using fsm_states_finite[of M] by (simp add: fset_of_list.rep_eq) 
 
 lemma finputs_set : "fset (finputs M) = inputs M" 
   using fsm_inputs_finite[of M] by (simp add: fset_of_list.rep_eq) 
 
 lemma foutputs_set : "fset (foutputs M) = outputs M" 
   using fsm_outputs_finite[of M] by (simp add: fset_of_list.rep_eq) 
 
 lemma ftransitions_set: "fset (ftransitions M) = transitions M"
   by (metis (no_types) fset_of_list.rep_eq ftransitions.simps transitions_as_list_set)
 
 lemma ftransitions_source:
   "q |\<in>| (t_source |`| ftransitions M) \<Longrightarrow> q \<in> states M" 
   using ftransitions_set[of M] fsm_transition_source[of _ M]
   by (metis (no_types, opaque_lifting) fimageE)
 
 lemma ftransitions_target:
   "q |\<in>| (t_target |`| ftransitions M) \<Longrightarrow> q \<in> states M" 
   using ftransitions_set[of M] fsm_transition_target[of _ M]
   by (metis (no_types, lifting) fimageE)
 
 
 subsection \<open>Responses to Input Sequences\<close>
 
 fun language_for_input :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('b\<times>'c) list list" where
   "language_for_input M q [] = [[]]" |
   "language_for_input M q (x#xs) = 
       (let outs = outputs_as_list M
         in concat (map (\<lambda>y . case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs)) outs))"  
 
 lemma language_for_input_set :
   assumes "observable M"
   and     "q \<in> states M"
 shows "list.set (language_for_input M q xs) = {io . io \<in> LS M q \<and> map fst io = xs}"
   using assms(2) proof (induction xs arbitrary: q)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
 
   have "list.set (language_for_input M q (x#xs)) \<subseteq> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
   proof 
     fix io assume "io \<in> list.set (language_for_input M q (x#xs))"
     then obtain y where "y \<in> outputs M"
                     and "io \<in> list.set (case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs))"
       unfolding outputs_as_list_set[symmetric]
       by auto
     then obtain q' where "h_obs M q x y = Some q'" and "io \<in> list.set (map ((#) (x,y)) (language_for_input M q' xs))"
       by (cases "h_obs M q x y"; auto)
 
     then obtain io' where "io = (x,y)#io'"
                       and "io' \<in> list.set (language_for_input M q' xs)"
       by auto
 
     then have "io' \<in> LS M q'" and "map fst io' = xs"
       using Cons.IH[OF h_obs_state[OF \<open>h_obs M q x y = Some q'\<close>]]
       by blast+
     then have "(x,y)#io' \<in> LS M q"
       using \<open>h_obs M q x y = Some q'\<close>
       unfolding h_obs_language_iff[OF assms(1), of x y io' q] 
       by blast
     then show "io \<in> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
       unfolding \<open>io = (x,y)#io'\<close> 
       using \<open>map fst io' = xs\<close>
       by auto
   qed
   moreover have "{io . io \<in> LS M q \<and> map fst io = (x#xs)} \<subseteq> list.set (language_for_input M q (x#xs))"
   proof 
     have scheme : "\<And> x y f xs . y \<in> list.set (f x) \<Longrightarrow> x \<in> list.set xs \<Longrightarrow> y \<in> list.set (concat (map f xs))"
       by auto
 
     fix io assume "io \<in> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
     then have "io \<in> LS M q" and "map fst io = (x#xs)"
       by auto
     then obtain y io' where "io = (x,y)#io'"
       by fastforce
     then have "(x,y)#io' \<in> LS M q"
       using \<open>io \<in> LS M q\<close>
       by auto
     then obtain q' where "h_obs M q x y = Some q'" and "io' \<in> LS M q'"
       unfolding h_obs_language_iff[OF assms(1), of x y io' q] 
       by blast
     moreover have "io' \<in> list.set (language_for_input M q' xs)"
       using Cons.IH[OF h_obs_state[OF \<open>h_obs M q x y = Some q'\<close>]] \<open>io' \<in> LS M q'\<close> \<open>map fst io = (x#xs)\<close>
       unfolding \<open>io = (x,y)#io'\<close> by auto
     ultimately have "io \<in> list.set ((\<lambda> y .(case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs))) y)"
       unfolding \<open>io = (x,y)#io'\<close>
       by force 
     moreover have "y \<in> list.set (outputs_as_list M)"
       unfolding outputs_as_list_set
       using language_io(2)[OF \<open>(x,y)#io' \<in> LS M q\<close>] by auto
     ultimately show "io \<in> list.set (language_for_input M q (x#xs))"
       unfolding language_for_input.simps Let_def
       using scheme[of io "(\<lambda> y .(case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs)))" y]
       by blast
   qed
   ultimately show ?case
     by blast
 qed
 
 
 subsection \<open>Filtering Transitions\<close>
 
 lift_definition filter_transitions :: 
   "('a,'b,'c) fsm \<Rightarrow> (('a,'b,'c) transition \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.filter_transitions 
 proof -
   fix M  :: "('a,'b,'c) fsm_impl"
   fix P  :: "('a,'b,'c) transition \<Rightarrow> bool"
   assume "well_formed_fsm M"
   then show "well_formed_fsm (FSM_Impl.filter_transitions M P)" 
     unfolding FSM_Impl.filter_transitions.simps by force
 qed
 
 
 lemma filter_transitions_simps[simp] :
   "initial (filter_transitions M P) = initial M"
   "states (filter_transitions M P) = states M"
   "inputs (filter_transitions M P) = inputs M"
   "outputs (filter_transitions M P) = outputs M"
   "transitions (filter_transitions M P) = {t \<in> transitions M . P t}"
   by (transfer;auto)+
 
 
 lemma filter_transitions_submachine :
   "is_submachine (filter_transitions M P) M" 
   unfolding filter_transitions_simps by fastforce
 
 
 lemma filter_transitions_path :
   assumes "path (filter_transitions M P) q p"
   shows "path M q p"
   using path_begin_state[OF assms] 
         transition_subset_path[of "filter_transitions M P" M, OF _ assms]
   unfolding filter_transitions_simps by blast
 
 lemma filter_transitions_reachable_states :
   assumes "q \<in> reachable_states (filter_transitions M P)"
   shows "q \<in> reachable_states M"
   using assms unfolding reachable_states_def filter_transitions_simps 
   using filter_transitions_path[of M P "initial M"]
   by blast
 
 
 subsection \<open>Filtering States\<close>
 
 lift_definition filter_states :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.filter_states 
 proof -
   fix M  :: "('a,'b,'c) fsm_impl"
   fix P  :: "'a \<Rightarrow> bool"
   assume *: "well_formed_fsm M"
 
   then show "well_formed_fsm (FSM_Impl.filter_states M P)" 
     by (cases "P (FSM_Impl.initial M)"; auto)
 qed
 
 lemma filter_states_simps[simp] :
   assumes "P (initial M)"
 shows "initial (filter_states M P) = initial M"
       "states (filter_states M P) = Set.filter P (states M)"
       "inputs (filter_states M P) = inputs M"
       "outputs (filter_states M P) = outputs M"
       "transitions (filter_states M P) = {t \<in> transitions M . P (t_source t) \<and> P (t_target t)}"
   using assms by (transfer;auto)+
 
 
 lemma filter_states_submachine :
   assumes "P (initial M)"
   shows "is_submachine (filter_states M P) M" 
   using filter_states_simps[of P M, OF assms] by fastforce
 
 
 
 fun restrict_to_reachable_states :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm" where
   "restrict_to_reachable_states M = filter_states M (\<lambda> q . q \<in> reachable_states M)"
 
 
 lemma restrict_to_reachable_states_simps[simp] :
 shows "initial (restrict_to_reachable_states M) = initial M"
       "states (restrict_to_reachable_states M) = reachable_states M"
       "inputs (restrict_to_reachable_states M) = inputs M"
       "outputs (restrict_to_reachable_states M) = outputs M"
       "transitions (restrict_to_reachable_states M) 
           = {t \<in> transitions M . (t_source t) \<in> reachable_states M}"
 proof -
   show "initial (restrict_to_reachable_states M) = initial M"
        "states (restrict_to_reachable_states M) = reachable_states M"
        "inputs (restrict_to_reachable_states M) = inputs M"
        "outputs (restrict_to_reachable_states M) = outputs M"
       
     using filter_states_simps[of "(\<lambda> q . q \<in> reachable_states M)", OF reachable_states_initial] 
     using reachable_state_is_state[of _ M] by auto
 
   have "transitions (restrict_to_reachable_states M) 
           = {t \<in> transitions M. (t_source t) \<in> reachable_states M \<and> (t_target t) \<in> reachable_states M}"
     using filter_states_simps[of "(\<lambda> q . q \<in> reachable_states M)", OF reachable_states_initial] 
     by auto
   then show "transitions (restrict_to_reachable_states M) 
               = {t \<in> transitions M . (t_source t) \<in> reachable_states M}"
     using reachable_states_next[of _ M] by auto
 qed
 
 
 lemma restrict_to_reachable_states_path :
   assumes "q \<in> reachable_states M"
   shows "path M q p = path (restrict_to_reachable_states M) q p"
 proof 
   show "path M q p \<Longrightarrow> path (restrict_to_reachable_states M) q p"
   proof -
     assume "path M q p"
     then show "path (restrict_to_reachable_states M) q p" 
     using assms proof (induction p arbitrary: q rule: list.induct)
       case Nil
       then show ?case
         using restrict_to_reachable_states_simps(2) by fastforce 
     next
       case (Cons t' p')
       then have "path M (t_target t') p'" by auto
       moreover have "t_target t' \<in> reachable_states M" using Cons.prems
         by (metis path_cons_elim reachable_states_next) 
       ultimately show ?case using Cons.IH
         by (metis (no_types, lifting) Cons.prems(1) Cons.prems(2) mem_Collect_eq path.simps 
               path_cons_elim restrict_to_reachable_states_simps(5))        
     qed
   qed
 
   show "path (restrict_to_reachable_states M) q p \<Longrightarrow> path M q p"
     by (metis (no_types, lifting) assms mem_Collect_eq reachable_state_is_state 
           restrict_to_reachable_states_simps(5) subsetI transition_subset_path)
 qed
 
 lemma restrict_to_reachable_states_language :
   "L (restrict_to_reachable_states M) = L M"
   unfolding LS.simps
   unfolding restrict_to_reachable_states_simps
   unfolding restrict_to_reachable_states_path[OF reachable_states_initial, of M]
   by blast
 
 lemma restrict_to_reachable_states_observable :
   assumes "observable M"
 shows "observable (restrict_to_reachable_states M)"
   using assms unfolding observable.simps
   unfolding restrict_to_reachable_states_simps
   by blast
 
 lemma restrict_to_reachable_states_minimal :
   assumes "minimal M"
   shows "minimal (restrict_to_reachable_states M)"
 proof -
   have "\<And> q1 q2 . q1 \<in> reachable_states M \<Longrightarrow>
                    q2 \<in> reachable_states M \<Longrightarrow>
                    q1 \<noteq> q2 \<Longrightarrow> 
                    LS (restrict_to_reachable_states M) q1 \<noteq> LS (restrict_to_reachable_states M) q2" 
   proof -
     fix q1 q2 assume "q1 \<in> reachable_states M" and "q2 \<in> reachable_states M" and "q1 \<noteq> q2"
     then have "q1 \<in> states M" and "q2 \<in> states M"
       by (simp add: reachable_state_is_state)+
     then have "LS M q1 \<noteq> LS M q2"
       using \<open>q1 \<noteq> q2\<close> assms by auto
     then show "LS (restrict_to_reachable_states M) q1 \<noteq> LS (restrict_to_reachable_states M) q2"
       unfolding LS.simps
       unfolding restrict_to_reachable_states_path[OF \<open>q1 \<in> reachable_states M\<close>]
       unfolding restrict_to_reachable_states_path[OF \<open>q2 \<in> reachable_states M\<close>] .
   qed
   then show ?thesis
     unfolding minimal.simps restrict_to_reachable_states_simps
     by blast
 qed
 
 lemma restrict_to_reachable_states_reachable_states :
   "reachable_states (restrict_to_reachable_states M) = states (restrict_to_reachable_states M)"
 proof 
   show "reachable_states (restrict_to_reachable_states M) \<subseteq> states (restrict_to_reachable_states M)"
     by (simp add: reachable_state_is_state subsetI) 
   show "states (restrict_to_reachable_states M) \<subseteq> reachable_states (restrict_to_reachable_states M)"
   proof 
     fix q assume "q \<in> states (restrict_to_reachable_states M)"
     then have "q \<in> reachable_states M"
       unfolding restrict_to_reachable_states_simps .
     then show "q \<in> reachable_states (restrict_to_reachable_states M)"
       unfolding reachable_states_def 
       unfolding restrict_to_reachable_states_simps
       unfolding restrict_to_reachable_states_path[OF reachable_states_initial, symmetric] .
   qed
 qed
 
 
 subsection \<open>Adding Transitions\<close>
 
 lift_definition create_unconnected_fsm :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.create_unconnected_FSMI by (transfer; simp)
 
 lemma create_unconnected_fsm_simps :
   assumes "finite ns" and "finite ins" and "finite outs" and "q \<in> ns"
   shows "initial (create_unconnected_fsm q ns ins outs) = q"
         "states (create_unconnected_fsm q ns ins outs)   = ns"
         "inputs (create_unconnected_fsm q ns ins outs)  = ins"
         "outputs (create_unconnected_fsm q ns ins outs) = outs"
         "transitions (create_unconnected_fsm q ns ins outs) = {}"
   using assms by (transfer; auto)+
 
 lift_definition create_unconnected_fsm_from_lists :: "'a \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.create_unconnected_fsm_from_lists by (transfer; simp)
 
 lemma create_unconnected_fsm_from_lists_simps :
   assumes "q \<in> set ns"
   shows "initial (create_unconnected_fsm_from_lists q ns ins outs) = q"
         "states (create_unconnected_fsm_from_lists q ns ins outs)  = set ns"
         "inputs (create_unconnected_fsm_from_lists q ns ins outs)  = set ins"
         "outputs (create_unconnected_fsm_from_lists q ns ins outs) = set outs"
         "transitions (create_unconnected_fsm_from_lists q ns ins outs) = {}"
   using assms by (transfer; auto)+
 
 lift_definition create_unconnected_fsm_from_fsets :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> 'c fset \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.create_unconnected_fsm_from_fsets by (transfer; simp)
 
 lemma create_unconnected_fsm_from_fsets_simps :
   assumes "q |\<in>| ns"
   shows "initial (create_unconnected_fsm_from_fsets q ns ins outs) = q"
         "states (create_unconnected_fsm_from_fsets q ns ins outs)   = fset ns"
         "inputs (create_unconnected_fsm_from_fsets q ns ins outs)  = fset ins"
         "outputs (create_unconnected_fsm_from_fsets q ns ins outs) = fset outs"
         "transitions (create_unconnected_fsm_from_fsets q ns ins outs) = {}"
   using assms by (transfer; auto)+
 
 
 lift_definition add_transitions :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.add_transitions 
 proof -
   fix M  :: "('a,'b,'c) fsm_impl"
   fix ts :: "('a,'b,'c) transition set"
   assume *: "well_formed_fsm M"
 
   then show "well_formed_fsm (FSM_Impl.add_transitions M ts)" 
   proof (cases "\<forall> t \<in> ts . t_source t \<in> FSM_Impl.states M \<and> t_input t \<in> FSM_Impl.inputs M 
                             \<and> t_output t \<in> FSM_Impl.outputs M \<and> t_target t \<in> FSM_Impl.states M")
     case True
     then have "ts \<subseteq> FSM_Impl.states M \<times> FSM_Impl.inputs M \<times> FSM_Impl.outputs M \<times> FSM_Impl.states M" 
       by fastforce
     moreover have "finite (FSM_Impl.states M \<times> FSM_Impl.inputs M \<times> FSM_Impl.outputs M \<times> FSM_Impl.states M)" 
       using * by blast
     ultimately have "finite ts"
       using rev_finite_subset by auto 
     then show ?thesis using * by auto
   next
     case False
     then show ?thesis using * by auto
   qed
 qed
 
 
 lemma add_transitions_simps :
   assumes "\<And> t . t \<in> ts \<Longrightarrow> t_source t \<in> states M \<and> t_input t \<in> inputs M \<and> t_output t \<in> outputs M \<and> t_target t \<in> states M"
   shows "initial (add_transitions M ts) = initial M"
         "states (add_transitions M ts)  = states M"
         "inputs (add_transitions M ts)  = inputs M"
         "outputs (add_transitions M ts) = outputs M"
         "transitions (add_transitions M ts) = transitions M \<union> ts"
   using assms by (transfer; auto)+
 
 
 
 lift_definition create_fsm_from_sets :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm" 
   is FSM_Impl.create_fsm_from_sets
 proof -
   fix q :: 'a
   fix qs :: "'a set"
   fix ins :: "'b set"
   fix outs :: "'c set"
   fix ts :: "('a,'b,'c) transition set"
 
   show "well_formed_fsm (FSM_Impl.create_fsm_from_sets q qs ins outs ts)"
   proof (cases "q \<in> qs \<and> finite qs \<and> finite ins \<and> finite outs")
     case True
 
     let ?M = "(FSMI q qs ins outs {})"
 
     show ?thesis proof (cases "\<forall> t \<in> ts . t_source t \<in> FSM_Impl.states ?M \<and> t_input t \<in> FSM_Impl.inputs ?M 
                             \<and> t_output t \<in> FSM_Impl.outputs ?M \<and> t_target t \<in> FSM_Impl.states ?M")
       case True
       then have "ts \<subseteq> FSM_Impl.states ?M \<times> FSM_Impl.inputs ?M \<times> FSM_Impl.outputs ?M \<times> FSM_Impl.states ?M" 
         by fastforce
       moreover have "finite (FSM_Impl.states ?M \<times> FSM_Impl.inputs ?M \<times> FSM_Impl.outputs ?M \<times> FSM_Impl.states ?M)" 
         using \<open>q \<in> qs \<and> finite qs \<and> finite ins \<and> finite outs\<close> by force
       ultimately have "finite ts"
         using rev_finite_subset by auto 
       then show ?thesis by auto
     next
       case False
       then show ?thesis by auto
     qed
   next
     case False
     then show ?thesis by auto
   qed
 qed
 
 lemma create_fsm_from_sets_simps :
   assumes "q \<in> qs" and "finite qs" and "finite ins" and "finite outs"
   assumes "\<And> t . t \<in> ts \<Longrightarrow> t_source t \<in> qs \<and> t_input t \<in> ins \<and> t_output t \<in> outs \<and> t_target t \<in> qs"
   shows "initial (create_fsm_from_sets q qs ins outs ts) = q"
         "states (create_fsm_from_sets q qs ins outs ts)  = qs"
         "inputs (create_fsm_from_sets q qs ins outs ts)  = ins"
         "outputs (create_fsm_from_sets q qs ins outs ts) = outs"
         "transitions (create_fsm_from_sets q qs ins outs ts) = ts"
   using assms by (transfer; auto)+
 
 lemma create_fsm_from_self : 
   "m = create_fsm_from_sets (initial m) (states m) (inputs m) (outputs m) (transitions m)"
 proof -
   have *: "\<And> t . t \<in> transitions m \<Longrightarrow> t_source t \<in> states m \<and> t_input t \<in> inputs m \<and> t_output t \<in> outputs m \<and> t_target t \<in> states m"
     by auto
   show ?thesis
     using create_fsm_from_sets_simps[OF fsm_initial fsm_states_finite fsm_inputs_finite fsm_outputs_finite *, of "transitions m"]
     apply transfer
     by force
 qed
 
 lemma create_fsm_from_sets_surj : 
   assumes "finite (UNIV :: 'a set)" 
   and     "finite (UNIV :: 'b set)" 
   and     "finite (UNIV :: 'c set)"
 shows "surj (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)" 
 proof
   show "range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T) \<subseteq> UNIV"
     by simp
   show "UNIV \<subseteq> range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)"    
   proof 
     fix m assume "m \<in> (UNIV :: ('a,'b,'c) fsm set)"
     then have "m = create_fsm_from_sets (initial m) (states m) (inputs m) (outputs m) (transitions m)"
       using create_fsm_from_self by blast
     then have "m = (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T) (initial m,states m,inputs m,outputs m,transitions m)"
       by auto
     then show "m \<in> range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)"
       by blast
   qed
 qed
       
 
 
 subsection \<open>Distinguishability\<close>
 
 definition distinguishes :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
   "distinguishes M q1 q2 io = (io \<in> LS M q1 \<union> LS M q2 \<and> io \<notin> LS M q1 \<inter> LS M q2)"
 
 definition minimally_distinguishes :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
   "minimally_distinguishes M q1 q2 io = (distinguishes M q1 q2 io
                                           \<and> (\<forall> io' . distinguishes M q1 q2 io' \<longrightarrow> length io \<le> length io'))"
 
 lemma minimally_distinguishes_ex :
   assumes "q1 \<in> states M"
       and "q2 \<in> states M"
       and "LS M q1 \<noteq> LS M q2"
 obtains v where "minimally_distinguishes M q1 q2 v"
 proof -
   let ?vs = "{v . distinguishes M q1 q2 v}"
   define vMin where vMin: "vMin = arg_min length (\<lambda>v . v \<in> ?vs)"
   
   obtain v' where "distinguishes M q1 q2 v'"
     using assms unfolding distinguishes_def by blast
   then have "vMin \<in> ?vs \<and> (\<forall> v'' . distinguishes M q1 q2 v'' \<longrightarrow> length vMin \<le> length v'')"
     unfolding vMin using arg_min_nat_lemma[of "\<lambda>v . distinguishes M q1 q2 v" v' length]
     by simp
   then show ?thesis 
     using that[of vMin] unfolding minimally_distinguishes_def by blast
 qed
 
 lemma distinguish_prepend :
   assumes "observable M"
       and "distinguishes M (FSM.after M q1 io) (FSM.after M q2 io) w"
       and "q1 \<in> states M"
       and "q2 \<in> states M"
       and "io \<in> LS M q1"
       and "io \<in> LS M q2"
 shows "distinguishes M q1 q2 (io@w)"
 proof -
   have "(io@w \<in> LS M q1) = (w \<in> LS M (after M q1 io))"
     using assms(1,3,5)
     by (metis after_language_iff)
   moreover have "(io@w \<in> LS M q2) = (w \<in> LS M (after M q2 io))"
     using assms(1,4,6)
     by (metis after_language_iff)
   ultimately show ?thesis
     using assms(2) unfolding distinguishes_def by blast
 qed 
 
 lemma distinguish_prepend_initial :
   assumes "observable M"
       and "distinguishes M (after_initial M (io1@io)) (after_initial M (io2@io)) w"
       and "io1@io \<in> L M"
       and "io2@io \<in> L M"
 shows "distinguishes M (after_initial M io1) (after_initial M io2) (io@w)"
 proof -
 have f1: "\<forall>ps psa f a. (ps::('b \<times> 'c) list) @ psa \<notin> LS f (a::'a) \<or> ps \<in> LS f a"
   by (meson language_prefix)
   then have f2: "io1 \<in> L M"
     by (meson assms(3))
   have f3: "io2 \<in> L M"
     using f1 by (metis assms(4))
   have "io1 \<in> L M"
     using f1 by (metis assms(3))
   then show ?thesis
     by (metis after_is_state after_language_iff after_split assms(1) assms(2) assms(3) assms(4) distinguish_prepend f3)
 qed
 
 lemma minimally_distinguishes_no_prefix :
   assumes "observable M"
   and     "u@w \<in> L M"
   and     "v@w \<in> L M"
   and     "minimally_distinguishes M (after_initial M u) (after_initial M v) (w@w'@w'')"
   and     "w' \<noteq> []"
 shows "\<not>distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w''"
 proof 
   assume "distinguishes M (after_initial M (u @ w)) (after_initial M (v @ w)) w''"
   then have "distinguishes M (after_initial M u) (after_initial M v) (w@w'')"
     using assms(1-3) distinguish_prepend_initial by blast
   moreover have "length (w@w'') < length (w@w'@w'')"
     using assms(5) by auto
   ultimately show False
     using assms(4) unfolding minimally_distinguishes_def
     using leD by blast 
 qed
 
 
 lemma minimally_distinguishes_after_append :
   assumes "observable M"
   and     "minimal M"
   and     "q1 \<in> states M"
   and     "q2 \<in> states M"
   and     "minimally_distinguishes M q1 q2 (w@w')"
   and     "w' \<noteq> []"
 shows "minimally_distinguishes M (after M q1 w) (after M q2 w) w'"
 proof -
   have "\<not> distinguishes M q1 q2 w"
     using assms(5,6)
     by (metis add.right_neutral add_le_cancel_left length_append length_greater_0_conv linorder_not_le minimally_distinguishes_def)
   then have "w \<in> LS M q1 = (w \<in> LS M q2)"
     unfolding distinguishes_def
     by blast 
   moreover have "(w@w') \<in> LS M q1 \<union> LS M q2"
     using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
     by blast
   ultimately have "w \<in> LS M q1" and "w \<in> LS M q2"
     by (meson Un_iff language_prefix)+
 
   have "(w@w') \<in> LS M q1 = (w' \<in> LS M (after M q1 w))"
     by (meson \<open>w \<in> LS M q1\<close> after_language_iff assms(1))
   moreover have "(w@w') \<in> LS M q2 = (w' \<in> LS M (after M q2 w))"
     by (meson \<open>w \<in> LS M q2\<close> after_language_iff assms(1))
   ultimately have "distinguishes M (after M q1 w) (after M q2 w) w'"
     using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
     by blast
   moreover have "\<And> w'' . distinguishes M (after M q1 w) (after M q2 w) w'' \<Longrightarrow> length w' \<le> length w''"
   proof -
     fix w'' assume "distinguishes M (after M q1 w) (after M q2 w) w''"
     then have "distinguishes M q1 q2 (w@w'')"
       by (metis \<open>w \<in> LS M q1\<close> \<open>w \<in> LS M q2\<close> assms(1) assms(3) assms(4) distinguish_prepend)
     then have "length (w@w') \<le> length (w@w'')"
       using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
       by blast
     then show "length w' \<le> length w''"
       by auto
   qed
   ultimately show ?thesis 
     unfolding minimally_distinguishes_def distinguishes_def 
     by blast
 qed
 
 
 
 lemma minimally_distinguishes_after_append_initial :
   assumes "observable M"
   and     "minimal M"
   and     "u \<in> L M"
   and     "v \<in> L M"
   and     "minimally_distinguishes M (after_initial M u) (after_initial M v) (w@w')"
   and     "w' \<noteq> []"
 shows "minimally_distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'"
 proof -
 
   have "\<not> distinguishes M (after_initial M u) (after_initial M v) w"
     using assms(5,6)
     by (metis add.right_neutral add_le_cancel_left length_append length_greater_0_conv linorder_not_le minimally_distinguishes_def)    
   then have "w \<in> LS M (after_initial M u) = (w \<in> LS M (after_initial M v))"
     unfolding distinguishes_def
     by blast 
   moreover have "(w@w') \<in> LS M (after_initial M u) \<union> LS M (after_initial M v)"
     using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
     by blast
   ultimately have "w \<in> LS M (after_initial M u)" and "w \<in> LS M (after_initial M v)"
     by (meson Un_iff language_prefix)+
 
   have "(w@w') \<in> LS M (after_initial M u) = (w' \<in> LS M (after_initial M (u@w)))"
     by (meson \<open>w \<in> LS M (after_initial M u)\<close> after_language_append_iff after_language_iff assms(1) assms(3))
   moreover have "(w@w') \<in> LS M (after_initial M v) = (w' \<in> LS M (after_initial M (v@w)))"
     by (meson \<open>w \<in> LS M (after_initial M v)\<close> after_language_append_iff after_language_iff assms(1) assms(4))
   ultimately have "distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'"
     using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
     by blast
   moreover have "\<And> w'' . distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'' \<Longrightarrow> length w' \<le> length w''"
   proof -
     fix w'' assume "distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w''"
     then have "distinguishes M (after_initial M u) (after_initial M v) (w@w'')"
       by (meson \<open>w \<in> LS M (after_initial M u)\<close> \<open>w \<in> LS M (after_initial M v)\<close> after_language_iff assms(1) assms(3) assms(4) distinguish_prepend_initial)
     then have "length (w@w') \<le> length (w@w'')"
       using assms(5) unfolding minimally_distinguishes_def distinguishes_def 
       by blast
     then show "length w' \<le> length w''"
       by auto
   qed
   ultimately show ?thesis 
     unfolding minimally_distinguishes_def distinguishes_def 
     by blast
 qed
 
 
 
 lemma minimally_distinguishes_proper_prefixes_card :
   assumes "observable M"
   and     "minimal M"
   and     "q1 \<in> states M"
   and     "q2 \<in> states M"
   and     "minimally_distinguishes M q1 q2 w"
   and     "S \<subseteq> states M"
 shows "card {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<le> card S - 1"
 (is "?P S")
 proof -
 
   define k where "k = card S"
   then show ?thesis
     using assms(6) 
   proof (induction k arbitrary: S rule: less_induct)
     case (less k)
 
     then have "finite S"
       by (metis fsm_states_finite rev_finite_subset)
     
     show ?case proof (cases k)
       case 0
       then have "S = {}"
         using less.prems \<open>finite S\<close> by auto
       then show ?thesis
         by fastforce     
     next
       case (Suc k')
 
       show ?thesis proof (cases "{w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} = {}")
         case True
         then show ?thesis
           by (metis bot.extremum dual_order.eq_iff obtain_subset_with_card_n) 
       next
         case False
                                     
         define wk where wk: "wk = arg_max length (\<lambda>wk . wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S})"
 
         obtain wk' where *:"wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
           using False by blast
         have "finite {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
           by (metis (no_types) Collect_mem_eq List.finite_set finite_Collect_conjI)
         then have "wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
              and  "\<And> wk' . wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<Longrightarrow> length wk' \<le> length wk"
           using False unfolding wk
           using arg_max_nat_lemma[of "(\<lambda>wk . wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S})", OF *]
           by (meson finite_maxlen)+
 
         then have "wk \<in> set (prefixes w)" and "wk \<noteq> w" and "after M q1 wk \<in> S" and "after M q2 wk \<in> S"
           by blast+
 
         obtain wk_suffix where "w = wk@wk_suffix" and "wk_suffix \<noteq> []"
           using \<open>wk \<in> set (prefixes w)\<close>
           using prefixes_set_ob \<open>wk \<noteq> w\<close> 
           by blast 
 
         have "distinguishes M (after M q1 []) (after M q2 []) w"
           using \<open>minimally_distinguishes M q1 q2 w\<close>
           by (metis after.simps(1) minimally_distinguishes_def)      
 
         have "minimally_distinguishes M (after M q1 wk) (after M q2 wk) wk_suffix"
           using \<open>minimally_distinguishes M q1 q2 w\<close> \<open>wk_suffix \<noteq> []\<close>
           unfolding \<open>w = wk@wk_suffix\<close>
           using minimally_distinguishes_after_append[OF assms(1,2,3,4), of wk wk_suffix]
           by blast
         then have "distinguishes M (after M q1 wk) (after M q2 wk) wk_suffix"
           unfolding minimally_distinguishes_def 
           by auto
         then have "wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))"
           unfolding distinguishes_def by blast
 
 
         define S1 where S1: "S1 = Set.filter (\<lambda>q . wk_suffix \<in> LS M q) S"
         define S2 where S2: "S2 = Set.filter (\<lambda>q . wk_suffix \<notin> LS M q) S"
 
         
         have "S = S1 \<union> S2"
           unfolding S1 S2 by auto
         moreover have "S1 \<inter> S2 = {}" 
           unfolding S1 S2 by auto
         ultimately have "card S = card S1 + card S2"
           using \<open>finite S\<close> card_Un_disjoint by blast
 
         have "S1 \<subseteq> states M" and "S2 \<subseteq> states M"
           using \<open>S = S1 \<union> S2\<close> less.prems(2) by blast+
 
         have "S1 \<noteq> {}" and "S2 \<noteq> {}"
           using \<open>wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))\<close> \<open>after M q1 wk \<in> S\<close> \<open>after M q2 wk \<in> S\<close>
           unfolding S1 S2
           by (metis empty_iff member_filter)+
         then have "card S1 > 0" and "card S2 > 0"
           using \<open>S = S1 \<union> S2\<close> \<open>finite S\<close>
           by (meson card_0_eq finite_Un neq0_conv)+
         then have "card S1 < k" and "card S2 < k"
           using \<open>card S = card S1 + card S2\<close> unfolding less.prems
           by auto
 
         define W where W: "W = (\<lambda> S1 S2 . {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S1 \<and> after M q2 w' \<in> S2})"
         then have "\<And> S' S'' . W S' S'' \<subseteq> set (prefixes w)"
           by auto
         then have W_finite: "\<And> S' S'' . finite (W S' S'')"
           using List.finite_set[of "prefixes w"]
           by (meson finite_subset) 
 
 
         have "\<And> w' . w' \<in> W S S \<Longrightarrow> w' \<noteq> wk \<Longrightarrow> after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)"
         proof -
           fix w' assume *:"w' \<in> W S S" and "w' \<noteq> wk"
           then have "w' \<in> set (prefixes w)" and "w' \<noteq> w" and "after M q1 w' \<in> S" and "after M q2 w' \<in> S"
             unfolding W
             by blast+ 
 
           then have "w' \<in> LS M q1"
             by (metis IntE UnCI UnE append_self_conv assms(5) distinguishes_def language_prefix leD length_append length_greater_0_conv less_add_same_cancel1 minimally_distinguishes_def prefixes_set_ob) 
           have "w' \<in> LS M q2"
             by (metis IntE UnCI \<open>w' \<in> LS M q1\<close> \<open>w' \<in> set (prefixes w)\<close> \<open>w' \<noteq> w\<close> append_Nil2 assms(5) distinguishes_def leD length_append length_greater_0_conv less_add_same_cancel1 minimally_distinguishes_def prefixes_set_ob) 
 
           have "length w' < length wk"
             using \<open>w' \<noteq> wk\<close> *
                   \<open>\<And> wk' . wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<Longrightarrow> length wk' \<le> length wk\<close>
             unfolding W
             by (metis (no_types, lifting) \<open>w = wk @ wk_suffix\<close> \<open>w' \<in> set (prefixes w)\<close> append_eq_append_conv le_neq_implies_less prefixes_set_ob) 
             
             
           show "after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)"
           proof (rule ccontr)
             assume "(after M q1 w' \<in> S1) \<noteq> (after M q2 w' \<in> S1)"
             then have "(after M q1 w' \<in> S1 \<and> (after M q2 w' \<in> S2)) \<or> (after M q1 w' \<in> S2 \<and> (after M q2 w' \<in> S1))"
               using \<open>after M q1 w' \<in> S\<close> \<open>after M q2 w' \<in> S\<close>
               unfolding \<open>S = S1 \<union> S2\<close>
               by blast
             then have "wk_suffix \<in> LS M (after M q1 w') = (wk_suffix \<notin> LS M (after M q2 w'))"
               unfolding S1 S2
               by (metis member_filter)
             then have "distinguishes M (after M q1 w') (after M q2 w') wk_suffix"
               unfolding distinguishes_def by blast
             then have "distinguishes M q1 q2 (w'@wk_suffix)"
               using distinguish_prepend[OF assms(1) _ \<open>q1 \<in> states M\<close> \<open>q2 \<in> states M\<close> \<open>w' \<in> LS M q1\<close> \<open>w' \<in> LS M q2\<close>]
               by blast
             moreover have "length (w'@wk_suffix) < length (wk@wk_suffix)"
               using \<open>length w' < length wk\<close>
               by auto
             ultimately show False
               using \<open>minimally_distinguishes M q1 q2 w\<close> 
               unfolding \<open>w = wk@wk_suffix\<close> minimally_distinguishes_def 
               by auto
           qed
         qed
 
 
 
         have "\<And> x . x \<in> W S1 S2 \<union> W S2 S1 \<Longrightarrow> x = wk"
         proof - 
           fix x assume "x \<in> W S1 S2 \<union> W S2 S1"
           then have "x \<in> W S S"
             unfolding W \<open>S = S1 \<union> S2\<close> by blast
           show "x = wk"
             using \<open>x \<in> W S1 S2 \<union> W S2 S1\<close>
             using \<open>\<And> w' . w' \<in> W S S \<Longrightarrow> w' \<noteq> wk \<Longrightarrow> after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)\<close>[OF \<open>x \<in> W S S\<close>]
             unfolding W
             using \<open>S1 \<inter> S2 = {}\<close>
             by blast 
         qed
         moreover have "wk \<in> W S1 S2 \<union> W S2 S1"
           unfolding W 
           using \<open>wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}\<close>
                 \<open>wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))\<close>
           by (metis (no_types, lifting) S1 Un_iff \<open>S = S1 \<union> S2\<close> mem_Collect_eq member_filter)
         ultimately have "W S1 S2 \<union> W S2 S1 = {wk}"
           by blast
 
 
         have "W S S = (W S1 S1 \<union> W S2 S2 \<union> (W S1 S2 \<union> W S2 S1))"
           unfolding W \<open>S = S1 \<union> S2\<close> by blast
         moreover have "W S1 S1 \<inter> W S2 S2 = {}"
           using \<open>S1 \<inter> S2 = {}\<close> unfolding W
           by blast
         moreover have "W S1 S1 \<inter> (W S1 S2 \<union> W S2 S1) = {}"
           unfolding W
           using \<open>S1 \<inter> S2 = {}\<close>
           by blast
         moreover have "W S2 S2 \<inter> (W S1 S2 \<union> W S2 S1) = {}"
           unfolding W
           using \<open>S1 \<inter> S2 = {}\<close>
           by blast
         moreover have "finite (W S1 S1)" and "finite (W S2 S2)" and "finite {wk}"
           using W_finite by auto
         ultimately have "card (W S S) = card (W S1 S1) + card (W S2 S2) + 1"
           unfolding \<open>W S1 S2 \<union> W S2 S1 = {wk}\<close>
           by (metis card_Un_disjoint finite_UnI inf_sup_distrib2 is_singletonI is_singleton_altdef sup_idem)
         moreover have "card (W S1 S1) \<le> card S1 - 1"
           using less.IH[OF \<open>card S1 < k\<close> _ \<open>S1 \<subseteq> states M\<close>]
           unfolding W by blast
         moreover have "card (W S2 S2) \<le> card S2 - 1"
           using less.IH[OF \<open>card S2 < k\<close> _ \<open>S2 \<subseteq> states M\<close>]
           unfolding W by blast
         ultimately have "card (W S S) \<le> card S - 1"
           using \<open>card S = card S1 + card S2\<close>
           using \<open>card S1 < k\<close> \<open>card S2 < k\<close> less.prems(1) by linarith
         then show ?thesis
           unfolding W .
       qed
     qed
   qed
 qed
 
 lemma minimally_distinguishes_proper_prefix_in_language :
   assumes "minimally_distinguishes M q1 q2 io"
   and     "io' \<in> set (prefixes io)"
   and     "io' \<noteq> io"
 shows "io' \<in> LS M q1 \<inter> LS M q2"
 proof -
   have "io \<in> LS M q1 \<or> io \<in> LS M q2"
     using assms(1) unfolding minimally_distinguishes_def distinguishes_def by blast
   then have "io' \<in> LS M q1 \<or> io' \<in> LS M q2"
     by (metis assms(2) prefixes_set_ob language_prefix) 
 
   have "length io' < length io"
     using assms(2,3) unfolding prefixes_set by auto
   then have "io' \<in> LS M q1 \<longleftrightarrow> io' \<in> LS M q2"
     using assms(1) unfolding minimally_distinguishes_def distinguishes_def
     by (metis Int_iff Un_Int_eq(1) Un_Int_eq(2) leD)
   then show ?thesis
     using \<open>io' \<in> LS M q1 \<or> io' \<in> LS M q2\<close>
     by blast
 qed
 
 lemma distinguishes_not_Nil:
   assumes "distinguishes M q1 q2 io"
   and     "q1 \<in> states M"
   and     "q2 \<in> states M"
 shows "io \<noteq> []"
   using assms unfolding distinguishes_def by auto
 
 fun does_distinguish :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> bool" where
   "does_distinguish M q1 q2 io = (is_in_language M q1 io \<noteq> is_in_language M q2 io)"
 
 lemma does_distinguish_correctness :
   assumes "observable M"
   and     "q1 \<in> states M"
   and     "q2 \<in> states M"
 shows "does_distinguish M q1 q2 io = distinguishes M q1 q2 io"
   unfolding does_distinguish.simps
             is_in_language_iff[OF assms(1,2)] 
             is_in_language_iff[OF assms(1,3)]
             distinguishes_def
   by blast
 
 lemma h_obs_distinguishes :
   assumes "observable M"
   and     "h_obs M q1 x y = Some q1'"
   and     "h_obs M q2 x y = None"
 shows "distinguishes M q1 q2 [(x,y)]"
   using assms(2,3) LS_single_transition[of x y M] unfolding distinguishes_def h_obs_Some[OF assms(1)] h_obs_None[OF assms(1)]
   by (metis Int_iff UnI1 \<open>\<And>y x q. (h_obs M q x y = None) = (\<nexists>q'. (q, x, y, q') \<in> FSM.transitions M)\<close> assms(1) assms(2) fst_conv h_obs_language_iff option.distinct(1) snd_conv) 
 
 lemma distinguishes_sym :
   assumes "distinguishes M q1 q2 io" 
   shows "distinguishes M q2 q1 io"
   using assms unfolding distinguishes_def by blast
 
 lemma distinguishes_after_prepend :
   assumes "observable M"
   and     "h_obs M q1 x y \<noteq> None"
   and     "h_obs M q2 x y \<noteq> None"
   and     "distinguishes M (FSM.after M q1 [(x,y)]) (FSM.after M q2 [(x,y)]) \<gamma>"
 shows "distinguishes M q1 q2 ((x,y)#\<gamma>)"
 proof -
   have "[(x,y)] \<in> LS M q1"
     using assms(2) h_obs_language_single_transition_iff[OF assms(1)] by auto
 
   have "[(x,y)] \<in> LS M q2"
     using assms(3) h_obs_language_single_transition_iff[OF assms(1)] by auto  
   
   show ?thesis
     using after_language_iff[OF assms(1) \<open>[(x,y)] \<in> LS M q1\<close>, of \<gamma>] 
     using after_language_iff[OF assms(1) \<open>[(x,y)] \<in> LS M q2\<close>, of \<gamma>] 
     using assms(4)
     unfolding distinguishes_def
     by simp
 qed
 
 lemma distinguishes_after_initial_prepend :
   assumes "observable M"
   and     "io1 \<in> L M"
   and     "io2 \<in> L M"
   and     "h_obs M (after_initial M io1) x y \<noteq> None"
   and     "h_obs M (after_initial M io2) x y \<noteq> None"
   and     "distinguishes M (after_initial M (io1@[(x,y)])) (after_initial M (io2@[(x,y)])) \<gamma>"
 shows "distinguishes M (after_initial M io1) (after_initial M io2) ((x,y)#\<gamma>)"
   by (metis after_split assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) distinguishes_after_prepend h_obs_language_append)
 
 
 subsection \<open>Extending FSMs by single elements\<close>
 
 lemma fsm_from_list_simps[simp] :
   "initial (fsm_from_list q ts) = (case ts of [] \<Rightarrow> q | (t#ts) \<Rightarrow> t_source t)"
   "states (fsm_from_list q ts) = (case ts of [] \<Rightarrow> {q} | (t#ts') \<Rightarrow> ((image t_source (set ts)) \<union> (image t_target (set ts))))"
   "inputs (fsm_from_list q ts) = image t_input (set ts)"
   "outputs (fsm_from_list q ts) = image t_output (set ts)"
   "transitions (fsm_from_list q ts) = set ts"
   by (cases ts; transfer; simp)+
 
 lift_definition add_transition :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_transition
   by simp 
 
 lemma add_transition_simps[simp]:
   assumes "t_source t \<in> states M" and "t_input t \<in> inputs M" and "t_output t \<in> outputs M" and "t_target t \<in> states M"
   shows
   "initial (add_transition M t) = initial M"  
   "inputs (add_transition M t) = inputs M"
   "outputs (add_transition M t) = outputs M"
   "transitions (add_transition M t) = insert t (transitions M)"
   "states (add_transition M t) = states M" using assms by (transfer; simp)+
 
 
 lift_definition add_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_state
   by simp
 
 lemma add_state_simps[simp]:
   "initial (add_state M q) = initial M"  
   "inputs (add_state M q) = inputs M"
   "outputs (add_state M q) = outputs M"
   "transitions (add_state M q) = transitions M"
   "states (add_state M q) = insert q (states M)" by (transfer; simp)+
 
 lift_definition add_input :: "('a,'b,'c) fsm \<Rightarrow> 'b \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_input
   by simp
 
 lemma add_input_simps[simp]:
   "initial (add_input M x) = initial M"  
   "inputs (add_input M x) = insert x (inputs M)"
   "outputs (add_input M x) = outputs M"
   "transitions (add_input M x) = transitions M"
   "states (add_input M x) = states M" by (transfer; simp)+
 
 lift_definition add_output :: "('a,'b,'c) fsm \<Rightarrow> 'c \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_output
   by simp
 
 lemma add_output_simps[simp]:
   "initial (add_output M y) = initial M"  
   "inputs (add_output M y) = inputs M"
   "outputs (add_output M y) = insert y (outputs M)"
   "transitions (add_output M y) = transitions M"
   "states (add_output M y) = states M" by (transfer; simp)+
 
 lift_definition add_transition_with_components :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_transition_with_components
   by simp 
 
 lemma add_transition_with_components_simps[simp]:
   "initial (add_transition_with_components M t) = initial M"  
   "inputs (add_transition_with_components M t) = insert (t_input t) (inputs M)"
   "outputs (add_transition_with_components M t) = insert (t_output t) (outputs M)"
   "transitions (add_transition_with_components M t) = insert t (transitions M)"
   "states (add_transition_with_components M t) = insert (t_target t) (insert (t_source t) (states M))"
   by (transfer; simp)+
 
 subsection \<open>Renaming Elements\<close>
 
 lift_definition rename_states :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('d,'b,'c) fsm" is FSM_Impl.rename_states
   by simp 
 
 lemma rename_states_simps[simp]:
   "initial (rename_states M f) = f (initial M)"  
   "states (rename_states M f) = f ` (states M)"  
   "inputs (rename_states M f) = inputs M"
   "outputs (rename_states M f) = outputs M"
   "transitions (rename_states M f) = (\<lambda>t . (f (t_source t), t_input t, t_output t, f (t_target t))) ` transitions M"
   by (transfer; simp)+
 
 
 lemma rename_states_isomorphism_language_state :
   assumes "bij_betw f (states M) (f ` states M)" 
   and     "q \<in> states M"
 shows "LS (rename_states M f) (f q) = LS M q"
 proof -
 
   have *: "bij_betw f (FSM.states M) (FSM.states (FSM.rename_states M f))"
     using assms rename_states_simps by auto
 
   have **: "f (initial M) = initial (rename_states M f)"
     using rename_states_simps by auto
 
   have ***: "(\<And>q x y q'.
     q \<in> states M \<Longrightarrow>
     q' \<in> states M \<Longrightarrow> ((q, x, y, q') \<in> transitions M) = ((f q, x, y, f q') \<in> transitions (rename_states M f)))"
   proof 
     fix q x y q' assume "q \<in> states M" and "q' \<in> states M"
 
     show "(q, x, y, q') \<in> transitions M \<Longrightarrow> (f q, x, y, f q') \<in> transitions (rename_states M f)"
       unfolding assms rename_states_simps by force
 
     show "(f q, x, y, f q') \<in> transitions (rename_states M f) \<Longrightarrow> (q, x, y, q') \<in> transitions M"
     proof -
       assume "(f q, x, y, f q') \<in> transitions (rename_states M f)"
       then obtain t where "(f q, x, y, f q') = (f (t_source t), t_input t, t_output t, f (t_target t))"
                       and "t \<in> transitions M"
         unfolding assms rename_states_simps 
         by blast
       then have "t_source t \<in> states M" and "t_target t \<in> states M" and "f (t_source t) = f q" and "f (t_target t) = f q'" and "t_input t = x" and "t_output t = y"
         by auto
 
       have "f q \<in> states (rename_states M f)" and "f q' \<in> states (rename_states M f)"
         using \<open>(f q, x, y, f q') \<in> transitions (rename_states M f)\<close>
         by auto
 
       have "t_source t = q"
         using \<open>f (t_source t) = f q\<close> \<open>q \<in> states M\<close> \<open>t_source t \<in> states M\<close> 
         using assms unfolding bij_betw_def inj_on_def 
         by blast
       moreover have "t_target t = q'"
         using \<open>f (t_target t) = f q'\<close> \<open>q' \<in> states M\<close> \<open>t_target t \<in> states M\<close> 
         using assms unfolding bij_betw_def inj_on_def 
         by blast
       ultimately show "(q, x, y, q') \<in> transitions M"
         using \<open>t_input t = x\<close> \<open>t_output t = y\<close> \<open>t \<in> transitions M\<close>
         by auto
     qed
   qed
 
   show ?thesis
     using language_equivalence_from_isomorphism[OF * ** *** assms(2)]
     by blast
 qed
 
 
 lemma rename_states_isomorphism_language :
   assumes "bij_betw f (states M) (f ` states M)" 
   shows "L (rename_states M f) = L M"
   using rename_states_isomorphism_language_state[OF assms fsm_initial]
   unfolding rename_states_simps .
 
 lemma rename_states_observable :
   assumes "bij_betw f (states M) (f ` states M)"
   and     "observable M"
 shows "observable (rename_states M f)"  
 proof -
   have "\<And> q1 x y q1' q1'' . (q1,x,y,q1') \<in> transitions (rename_states M f) \<Longrightarrow> (q1,x,y,q1'') \<in> transitions (rename_states M f) \<Longrightarrow> q1' = q1''"
   proof -
     fix q1 x y q1' q1'' 
     assume "(q1,x,y,q1') \<in> transitions (rename_states M f)" and "(q1,x,y,q1'') \<in> transitions (rename_states M f)"
     then obtain t' t'' where "t' \<in> transitions M"
                          and "t'' \<in> transitions M"
                          and "(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1,x,y,q1')"
                          and "(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1,x,y,q1'')"
       unfolding rename_states_simps
       by force
 
     then have "f (t_source t') = f (t_source t'')"
       by auto
     moreover have "t_source t' \<in> states M" and "t_source t'' \<in> states M"
       using \<open>t' \<in> transitions M\<close> \<open>t'' \<in> transitions M\<close>
       by auto
     ultimately have "t_source t' = t_source t''"
       using assms(1)
       unfolding bij_betw_def inj_on_def by blast
     then have "t_target t' = t_target t''"
       using assms(2) unfolding observable.simps
       by (metis Pair_inject \<open>(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1, x, y, q1'')\<close> \<open>(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1, x, y, q1')\<close> \<open>t' \<in> FSM.transitions M\<close> \<open>t'' \<in> FSM.transitions M\<close>) 
     then show "q1' = q1''"
       using \<open>(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1, x, y, q1'')\<close> \<open>(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1, x, y, q1')\<close> by auto
   qed
   then show ?thesis
     unfolding observable_alt_def by blast
 qed
 
 
 lemma rename_states_minimal :
   assumes "bij_betw f (states M) (f ` states M)"
   and     "minimal M"
 shows "minimal (rename_states M f)"
 proof -
   have "\<And> q q' . q \<in> f ` FSM.states M \<Longrightarrow> q' \<in> f ` FSM.states M \<Longrightarrow> q \<noteq> q' \<Longrightarrow> LS (rename_states M f) q \<noteq> LS (rename_states M f) q'"
   proof -
     fix q q' assume "q \<in> f ` FSM.states M" and "q' \<in> f ` FSM.states M" and "q \<noteq> q'"
 
     then obtain fq fq' where "fq \<in> states M" and "fq' \<in> states M" and "q = f fq" and "q' = f fq'"
       by auto
     then have "fq \<noteq> fq'" 
       using \<open>q \<noteq> q'\<close> by auto 
     then have "LS M fq \<noteq> LS M fq'"
       by (meson \<open>fq \<in> FSM.states M\<close> \<open>fq' \<in> FSM.states M\<close> assms(2) minimal.elims(2))
     then show "LS (rename_states M f) q \<noteq> LS (rename_states M f) q'"
       using rename_states_isomorphism_language_state[OF assms(1)]
       by (simp add: \<open>fq \<in> FSM.states M\<close> \<open>fq' \<in> FSM.states M\<close> \<open>q = f fq\<close> \<open>q' = f fq'\<close>)
   qed
   then show ?thesis 
     by auto
 qed
 
 
 fun index_states :: "('a::linorder,'b,'c) fsm \<Rightarrow> (nat,'b,'c) fsm" where
   "index_states M = rename_states M (assign_indices (states M))"
 
 lemma assign_indices_bij_betw: "bij_betw (assign_indices (FSM.states M)) (FSM.states M) (assign_indices (FSM.states M) ` FSM.states M)"
   using assign_indices_bij[OF fsm_states_finite[of M]]
   by (simp add: bij_betw_def) 
 
 
 lemma index_states_language :
   "L (index_states M) = L M"
   using rename_states_isomorphism_language[of "assign_indices (states M)" M, OF assign_indices_bij_betw]
   by auto
 
 lemma index_states_observable :
   assumes "observable M"
   shows "observable (index_states M)"
   using rename_states_observable[of "assign_indices (states M)", OF assign_indices_bij_betw assms]
   unfolding index_states.simps .
 
 lemma index_states_minimal :
   assumes "minimal M"
   shows "minimal (index_states M)" 
   using rename_states_minimal[of "assign_indices (states M)", OF assign_indices_bij_betw assms]
   unfolding index_states.simps .
 
 
 
 fun index_states_integer :: "('a::linorder,'b,'c) fsm \<Rightarrow> (integer,'b,'c) fsm" where
   "index_states_integer M = rename_states M (integer_of_nat \<circ> assign_indices (states M))"
 
 lemma assign_indices_integer_bij_betw: "bij_betw (integer_of_nat \<circ> assign_indices (states M)) (FSM.states M) ((integer_of_nat \<circ> assign_indices (states M)) ` FSM.states M)"
 proof -
   have *: "inj_on (assign_indices (FSM.states M)) (FSM.states M)" 
     using assign_indices_bij[OF fsm_states_finite[of M]]
     unfolding bij_betw_def
     by auto
   then have "inj_on (integer_of_nat \<circ> assign_indices (states M)) (FSM.states M)"
     unfolding inj_on_def
     by (metis comp_apply nat_of_integer_integer_of_nat)
   then show ?thesis
     unfolding bij_betw_def
     by auto
 qed
 
 
 lemma index_states_integer_language :
   "L (index_states_integer M) = L M"
   using rename_states_isomorphism_language[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw]
   by auto
 
 lemma index_states_integer_observable :
   assumes "observable M"
   shows "observable (index_states_integer M)"
   using rename_states_observable[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw assms]
   unfolding index_states_integer.simps .
 
 lemma index_states_integer_minimal :
   assumes "minimal M"
   shows "minimal (index_states_integer M)" 
   using rename_states_minimal[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw assms]
   unfolding index_states_integer.simps .
 
 subsection \<open>Canonical Separators\<close>
 
 lift_definition canonical_separator' :: "('a,'b,'c) fsm \<Rightarrow> (('a \<times> 'a),'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (('a \<times> 'a) + 'a,'b,'c) fsm" is FSM_Impl.canonical_separator'
 proof -
   fix A :: "('a,'b,'c) fsm_impl"
   fix B :: "('a \<times> 'a,'b,'c) fsm_impl"
   fix q1 :: 'a
   fix q2 :: 'a
   assume "well_formed_fsm A" and "well_formed_fsm B"
 
   then have p1a: "fsm_impl.initial A \<in> fsm_impl.states A"
         and p2a: "finite (fsm_impl.states A)"
         and p3a: "finite (fsm_impl.inputs A)"
         and p4a: "finite (fsm_impl.outputs A)"
         and p5a: "finite (fsm_impl.transitions A)"
         and p6a: "(\<forall>t\<in>fsm_impl.transitions A.
             t_source t \<in> fsm_impl.states A \<and>
             t_input t \<in> fsm_impl.inputs A \<and> t_target t \<in> fsm_impl.states A \<and>
                                              t_output t \<in> fsm_impl.outputs A)"
         and p1b: "fsm_impl.initial B \<in> fsm_impl.states B"
         and p2b: "finite (fsm_impl.states B)"
         and p3b: "finite (fsm_impl.inputs B)"
         and p4b: "finite (fsm_impl.outputs B)"
         and p5b: "finite (fsm_impl.transitions B)"
         and p6b: "(\<forall>t\<in>fsm_impl.transitions B.
             t_source t \<in> fsm_impl.states B \<and>
             t_input t \<in> fsm_impl.inputs B \<and> t_target t \<in> fsm_impl.states B \<and>
                                              t_output t \<in> fsm_impl.outputs B)"
     by simp+
 
   let ?P = "FSM_Impl.canonical_separator' A B q1 q2"
 
   show "well_formed_fsm ?P" proof (cases "fsm_impl.initial B = (q1,q2)")
     case False
     then show ?thesis by auto
   next
     case True
 
     let ?f = "(\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
   
     have "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx"
     proof -
       fix qx
       show "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx"
         unfolding set_as_map_def by (cases "\<exists>z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A"; auto)
     qed
     moreover have "\<And> qx . (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A}) qx"
     proof -
       fix qx 
       show "(\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A}) qx"
         by force
     qed
     ultimately have *:" ?f = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A})" 
       by blast
       
     let ?shifted_transitions' = "shifted_transitions (fsm_impl.transitions B)"
     let ?distinguishing_transitions_lr = "distinguishing_transitions ?f q1 q2 (fsm_impl.states B) (fsm_impl.inputs B)"
     let ?ts = "?shifted_transitions' \<union> ?distinguishing_transitions_lr"
   
     have "FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}"
     and  "FSM_Impl.transitions ?P = ?ts"
       unfolding FSM_Impl.canonical_separator'.simps Let_def True by simp+
 
     have p2: "finite (fsm_impl.states ?P)"
       unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> using p2b by blast
   
     have "fsm_impl.initial ?P = Inl (q1,q2)" by auto
     then have p1: "fsm_impl.initial ?P \<in> fsm_impl.states ?P" 
       using p1a p1b unfolding canonical_separator'.simps True by auto
     have p3: "finite (fsm_impl.inputs ?P)"
       using p3a p3b by auto
     have p4: "finite (fsm_impl.outputs ?P)"
       using p4a p4b by auto
 
     have "finite (fsm_impl.states B \<times> fsm_impl.inputs B)"
       using p2b p3b by blast
     moreover have **: "\<And> x q1 . finite ({y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A})"
     proof - 
       fix x q1
       have "{y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A} = {t_output t | t . t \<in> fsm_impl.transitions A \<and> t_source t = q1 \<and> t_input t = x}"
         by auto
       then have "{y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A} \<subseteq> image t_output (fsm_impl.transitions A)"
         unfolding fst_conv snd_conv by blast
       moreover have "finite (image t_output (fsm_impl.transitions A))"
         using p5a by auto
       ultimately show "finite ({y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A})"
         by (simp add: finite_subset)
     qed
     ultimately have "finite ?distinguishing_transitions_lr"
       unfolding * distinguishing_transitions_def by force
     moreover have "finite ?shifted_transitions'"
       unfolding shifted_transitions_def using p5b by auto
     ultimately have "finite ?ts" by blast
     then have p5: "finite (fsm_impl.transitions ?P)"
       by simp
      
     have "fsm_impl.inputs ?P = fsm_impl.inputs A \<union> fsm_impl.inputs B"
       using True by auto
     have "fsm_impl.outputs ?P = fsm_impl.outputs A \<union> fsm_impl.outputs B"
       using True by auto
   
     have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
       unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> shifted_transitions_def 
       using p6b by force
     moreover have "\<And> t . t \<in> ?distinguishing_transitions_lr \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
       unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> distinguishing_transitions_def * by force
     ultimately have "\<And> t . t \<in> ?ts \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
       by blast
     moreover have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
     proof -
       have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs B \<and> t_output t \<in> fsm_impl.outputs B"
         unfolding shifted_transitions_def using p6b by auto
       then show "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
         unfolding \<open>fsm_impl.inputs ?P = fsm_impl.inputs A \<union> fsm_impl.inputs B\<close>
                   \<open>fsm_impl.outputs ?P = fsm_impl.outputs A \<union> fsm_impl.outputs B\<close> by blast
     qed
     moreover have "\<And> t . t \<in> ?distinguishing_transitions_lr \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
       unfolding * distinguishing_transitions_def using p6a p6b True by auto
     ultimately have p6: "(\<forall>t\<in>fsm_impl.transitions ?P.
               t_source t \<in> fsm_impl.states ?P \<and>
               t_input t \<in> fsm_impl.inputs ?P \<and> t_target t \<in> fsm_impl.states ?P \<and>
                                                t_output t \<in> fsm_impl.outputs ?P)"
       unfolding \<open>FSM_Impl.transitions ?P = ?ts\<close> by blast
   
     show "well_formed_fsm ?P"
       using p1 p2 p3 p4 p5 p6 by linarith
   qed
 qed 
 
 
 lemma canonical_separator'_simps :
   assumes "initial P = (q1,q2)"
   shows "initial (canonical_separator' M P q1 q2) = Inl (q1,q2)"
         "states (canonical_separator' M P q1 q2) = (image Inl (states P)) \<union> {Inr q1, Inr q2}"
         "inputs (canonical_separator' M P q1 q2) = inputs M \<union> inputs P"
         "outputs (canonical_separator' M P q1 q2) = outputs M \<union> outputs P"
         "transitions (canonical_separator' M P q1 q2) 
           = shifted_transitions (transitions P) 
               \<union> distinguishing_transitions (h_out M) q1 q2 (states P) (inputs P)"
   using assms unfolding h_out_code by (transfer; auto)+
 
 lemma canonical_separator'_simps_without_assm :
         "initial (canonical_separator' M P q1 q2) = Inl (q1,q2)"
         "states (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then (image Inl (states P)) \<union> {Inr q1, Inr q2} else {Inl (q1,q2)})"
         "inputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then inputs M \<union> inputs P else {})"
         "outputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then outputs M \<union> outputs P else {})"
         "transitions (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then shifted_transitions (transitions P) \<union> distinguishing_transitions (h_out M) q1 q2 (states P) (inputs P) else {})"
   unfolding h_out_code by (transfer; simp add: Let_def)+
 
 end
\ No newline at end of file
diff --git a/thys/FSM_Tests/Util.thy b/thys/FSM_Tests/Util.thy
--- a/thys/FSM_Tests/Util.thy
+++ b/thys/FSM_Tests/Util.thy
@@ -1,3835 +1,3816 @@
 section \<open>Utility Definitions and Properties\<close>
 
 text \<open>This file contains various definitions and lemmata not closely related to finite state
       machines or testing.\<close>
 
 
 theory Util
   imports Main "HOL-Library.FSet" "HOL-Library.Sublist" "HOL-Library.Mapping"
 begin
 
 subsection \<open>Converting Sets to Maps\<close>
 
 text \<open>This subsection introduces a function @{text "set_as_map"} that transforms a set of 
       @{text "('a \<times> 'b)"} tuples to a map mapping each first value @{text "x"} of the contained tuples
       to all second values @{text "y"} such that @{text "(x,y)"} is contained in the set.\<close>
 
 definition set_as_map :: "('a \<times> 'c) set \<Rightarrow> ('a \<Rightarrow> 'c set option)" where
   "set_as_map s = (\<lambda> x . if (\<exists> z . (x,z) \<in> s) then Some {z . (x,z) \<in> s} else None)"
 
 
 lemma set_as_map_code[code] : 
   "set_as_map (set xs) = (foldl (\<lambda> m (x,z) . case m x of
                                                 None \<Rightarrow> m (x \<mapsto> {z}) |
                                                 Some zs \<Rightarrow> m (x \<mapsto>  (insert z zs)))
                                 Map.empty
                                 xs)"
 proof - 
   let ?f = "\<lambda> xs . (foldl (\<lambda> m (x,z) . case m x of
                                           None \<Rightarrow> m (x \<mapsto> {z}) |
                                           Some zs \<Rightarrow> m (x \<mapsto>  (insert z zs)))
                           Map.empty
                           xs)"
   have "(?f xs) = (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None)"
   proof (induction xs rule: rev_induct)
     case Nil
     then show ?case by auto
   next
     case (snoc xz xs)
     then obtain x z where "xz = (x,z)"
       by force 
 
     have *: "(?f (xs@[(x,z)])) = (case (?f xs) x of
                                 None \<Rightarrow> (?f xs) (x \<mapsto> {z}) |
                                 Some zs \<Rightarrow> (?f xs) (x \<mapsto> (insert z zs)))"
       by auto
 
     then show ?case proof (cases "(?f xs) x")
       case None
       then have **: "(?f (xs@[(x,z)])) = (?f xs) (x \<mapsto> {z})" using * by auto
 
       have scheme: "\<And> m k v . (m(k \<mapsto> v)) = (\<lambda>k' . if k' = k then Some v else m k')"
         by auto
 
       have m1: "(?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some {z} else (?f xs) x')"
         unfolding ** 
         unfolding scheme by force
 
       have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = None"
         using None snoc by auto
       then have "\<not>(\<exists> z . (x,z) \<in> set xs)"
         by (metis (mono_tags, lifting) option.distinct(1))
       then have "(\<exists> z . (x,z) \<in> set (xs@[(x,z)]))" and "{z' . (x,z') \<in> set (xs@[(x,z)])} = {z}"
         by auto
       then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) 
                                 then Some {z' . (x',z') \<in> set (xs@[(x,z)])} 
                                 else None)
                    = (\<lambda> x' . if x' = x 
                                 then Some {z} else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) 
                                                             then Some {z . (x,z) \<in> set xs} 
                                                             else None) x')"
         by force
 
       show ?thesis using m1 m2 snoc
         using \<open>xz = (x, z)\<close> by presburger
     next
       case (Some zs)
       then have **: "(?f (xs@[(x,z)])) = (?f xs) (x \<mapsto> (insert z zs))" using * by auto
       have scheme: "\<And> m k v . (m(k \<mapsto> v)) = (\<lambda>k' . if k' = k then Some v else m k')"
         by auto
 
       have m1: "(?f (xs@[(x,z)])) = (\<lambda> x' . if x' = x then Some (insert z zs) else (?f xs) x')"
         unfolding ** 
         unfolding scheme by force
 
       have "(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x = Some zs"
         using Some snoc by auto
       then have "(\<exists> z . (x,z) \<in> set xs)"
         unfolding case_prod_conv using  option.distinct(2) by metis
       then have "(\<exists> z . (x,z) \<in> set (xs@[(x,z)]))" by simp
 
       have "{z' . (x,z') \<in> set (xs@[(x,z)])} = insert z zs"
       proof -
         have "Some {z . (x,z) \<in> set xs} = Some zs"
           using \<open>(\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) then Some {z . (x,z) \<in> set xs} else None) x 
                   = Some zs\<close>
           unfolding case_prod_conv using  option.distinct(2) by metis
         then have "{z . (x,z) \<in> set xs} = zs" by auto
         then show ?thesis by auto
       qed
 
       have "\<And> a  . (\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) 
                               then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                    = (\<lambda> x' . if x' = x 
                               then Some (insert z zs) 
                               else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) 
                                             then Some {z . (x,z) \<in> set xs} else None) x') a" 
       proof -
         fix a show "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) 
                               then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None) a
                    = (\<lambda> x' . if x' = x 
                               then Some (insert z zs) 
                               else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) 
                                             then Some {z . (x,z) \<in> set xs} else None) x') a"
         using \<open>{z' . (x,z') \<in> set (xs@[(x,z)])} = insert z zs\<close> \<open>(\<exists> z . (x,z) \<in> set (xs@[(x,z)]))\<close>
         by (cases "a = x"; auto)
       qed
 
       then have m2: "(\<lambda> x' . if (\<exists> z' . (x',z') \<in> set (xs@[(x,z)])) 
                                 then Some {z' . (x',z') \<in> set (xs@[(x,z)])} else None)
                    = (\<lambda> x' . if x' = x 
                                 then Some (insert z zs) 
                                 else (\<lambda> x . if (\<exists> z . (x,z) \<in> set xs) 
                                               then Some {z . (x,z) \<in> set xs} else None) x')"
         by auto
 
 
       show ?thesis using m1 m2 snoc
         using \<open>xz = (x, z)\<close> by presburger
     qed
   qed
 
   then show ?thesis
     unfolding set_as_map_def by simp
 qed
 
 
 abbreviation "member_option x ms \<equiv> (case ms of None \<Rightarrow> False | Some xs \<Rightarrow> x \<in> xs)"
 notation member_option ("(_\<in>\<^sub>o_)" [1000] 1000)
 
 abbreviation(input) "lookup_with_default f d \<equiv> (\<lambda> x . case f x of None \<Rightarrow> d | Some xs \<Rightarrow> xs)"
 abbreviation(input) "m2f f \<equiv> lookup_with_default f {}" 
 
 abbreviation(input) "lookup_with_default_by f g d \<equiv> (\<lambda> x . case f x of None \<Rightarrow> g d | Some xs \<Rightarrow> g xs)"
 abbreviation(input) "m2f_by g f \<equiv> lookup_with_default_by f g {}" 
 
 lemma m2f_by_from_m2f :
   "(m2f_by g f xs) = g (m2f f xs)"
   by (simp add: option.case_eq_if) 
 
 
 lemma set_as_map_containment :
   assumes "(x,y) \<in> zs"
   shows "y \<in> (m2f (set_as_map zs)) x"
   using assms unfolding set_as_map_def
   by auto 
 
 lemma set_as_map_elem :
   assumes "y \<in> m2f (set_as_map xs) x" 
 shows "(x,y) \<in> xs" 
 using assms unfolding set_as_map_def
 proof -
   assume a1: "y \<in> (case if \<exists>z. (x, z) \<in> xs then Some {z. (x, z) \<in> xs} else None of None \<Rightarrow> {} | Some xs \<Rightarrow> xs)"
   then have "\<exists>a. (x, a) \<in> xs"
     using all_not_in_conv by fastforce
   then show ?thesis
     using a1 by simp
 qed 
 
 
 subsection \<open>Utility Lemmata for existing functions on lists\<close>
 
 subsubsection \<open>Utility Lemmata for @{text "find"}\<close>
 
 lemma find_result_props : 
   assumes "find P xs = Some x" 
   shows "x \<in> set xs" and "P x"
 proof -
   show "x \<in> set xs" using assms by (metis find_Some_iff nth_mem)
   show "P x" using assms by (metis find_Some_iff)
 qed
 
 lemma find_set : 
   assumes "find P xs = Some x"
   shows "x \<in> set xs"
 using assms proof(induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case
     by (metis find.simps(2) list.set_intros(1) list.set_intros(2) option.inject) 
 qed
 
 lemma find_condition : 
   assumes "find P xs = Some x"
   shows "P x"
 using assms proof(induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case
     by (metis find.simps(2) option.inject)     
 qed
 
 lemma find_from : 
   assumes "\<exists> x \<in> set xs . P x"
   shows "find P xs \<noteq> None"
   by (metis assms find_None_iff)
 
 
 lemma find_sort_containment :
   assumes "find P (sort xs) = Some x"
 shows "x \<in> set xs"
   using assms find_set by force
 
 
 lemma find_sort_index :
   assumes "find P xs = Some x"
   shows "\<exists> i < length xs . xs ! i = x \<and> (\<forall> j < i . \<not> P (xs ! j))"
 using assms proof (induction xs arbitrary: x)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   show ?case proof (cases "P a")
     case True
     then show ?thesis 
       using Cons.prems unfolding find.simps by auto
   next
     case False
     then have "find P (a#xs) = find P xs"
       unfolding find.simps by auto
     then have "find P xs = Some x"
       using Cons.prems by auto
     then show ?thesis 
       using Cons.IH False
       by (metis Cons.prems find_Some_iff)  
   qed
 qed
 
 
 lemma find_sort_least :
   assumes "find P (sort xs) = Some x"
   shows "\<forall> x' \<in> set xs . x \<le> x' \<or> \<not> P x'"
   and   "x = (LEAST x' \<in> set xs . P x')"
 proof -
   obtain i where "i < length (sort xs)" 
            and   "(sort xs) ! i = x" 
            and   "(\<forall> j < i . \<not> P ((sort xs) ! j))"
     using find_sort_index[OF assms] by blast
   
   have "\<And> j . j > i \<Longrightarrow> j < length xs \<Longrightarrow> (sort xs) ! i \<le> (sort xs) ! j"
     by (simp add: sorted_nth_mono)
   then have "\<And> j . j < length xs \<Longrightarrow> (sort xs) ! i \<le> (sort xs) ! j \<or> \<not> P ((sort xs) ! j)"
     using \<open>(\<forall> j < i . \<not> P ((sort xs) ! j))\<close>
     by (metis not_less_iff_gr_or_eq order_refl) 
   then show "\<forall> x' \<in> set xs . x \<le> x' \<or> \<not> P x'"
     by (metis \<open>sort xs ! i = x\<close> in_set_conv_nth length_sort set_sort)
   then show "x = (LEAST x' \<in> set xs . P x')"
     using find_set[OF assms] find_condition[OF assms]
     by (metis (mono_tags, lifting) Least_equality set_sort) 
 qed
 
 
 
 subsubsection \<open>Utility Lemmata for @{text "filter"}\<close>
 
 lemma filter_take_length :
   "length (filter P (take i xs)) \<le> length (filter P xs)"
   by (metis append_take_drop_id filter_append le0 le_add_same_cancel1 length_append)
 
 
 lemma filter_double :
   assumes "x \<in> set (filter P1 xs)"
   and     "P2 x"
 shows "x \<in> set (filter P2 (filter P1 xs))"
   by (metis (no_types) assms(1) assms(2) filter_set member_filter)
 
 lemma filter_list_set :
   assumes "x \<in> set xs"
   and     "P x"
 shows "x \<in> set (filter P xs)"
   by (simp add: assms(1) assms(2))
 
 lemma filter_list_set_not_contained :
   assumes "x \<in> set xs"
   and     "\<not> P x"
 shows "x \<notin> set (filter P xs)"
   by (simp add: assms(1) assms(2))
 
 lemma filter_map_elem : "t \<in> set (map g (filter f xs)) \<Longrightarrow> \<exists> x \<in> set xs . f x \<and> t = g x" 
   by auto
 
 
 
 subsubsection \<open>Utility Lemmata for @{text "concat"}\<close>
 
 lemma concat_map_elem :
   assumes "y \<in> set (concat (map f xs))"
   obtains x where "x \<in> set xs"
               and "y \<in> set (f x)"
 using assms proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then show ?case 
   proof (cases "y \<in> set (f a)")
     case True
     then show ?thesis 
       using Cons.prems(1) by auto
   next
     case False
     then have "y \<in> set (concat (map f xs))"
       using Cons by auto
     have "\<exists> x . x \<in> set xs \<and> y \<in> set (f x)"  
     proof (rule ccontr)
       assume "\<not>(\<exists>x. x \<in> set xs \<and> y \<in> set (f x))"
       then have "\<not>(y \<in> set (concat (map f xs)))"
         by auto
       then show False 
         using \<open>y \<in> set (concat (map f xs))\<close> by auto
     qed
     then show ?thesis
       using Cons.prems(1) by auto     
   qed
 qed
 
 lemma set_concat_map_sublist :
   assumes "x \<in> set (concat (map f xs))"
   and     "set xs \<subseteq> set xs'"
 shows "x \<in> set (concat (map f xs'))"
 using assms by (induction xs) (auto)
 
 lemma set_concat_map_elem :
   assumes "x \<in> set (concat (map f xs))"
   shows "\<exists> x' \<in> set xs . x \<in> set (f x')"
 using assms by auto
 
 lemma concat_replicate_length : "length (concat (replicate n xs)) = n * (length xs)"
   by (induction n; simp)
 
 
 
 
 subsection \<open>Enumerating Lists\<close>
 
 fun lists_of_length :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list list" where
   "lists_of_length T 0 = [[]]" |
   "lists_of_length T (Suc n) = concat (map (\<lambda> xs . map (\<lambda> x . x#xs) T ) (lists_of_length T n))" 
 
 lemma lists_of_length_containment :
   assumes "set xs \<subseteq> set T"
   and     "length xs = n"
 shows "xs \<in> set (lists_of_length T n)"
 using assms proof (induction xs arbitrary: n)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   then obtain k where "n = Suc k" 
     by auto
   then have "xs \<in> set (lists_of_length T k)" 
     using Cons by auto
   moreover have "a \<in> set T" 
     using Cons by auto
   ultimately show ?case 
     using \<open>n = Suc k\<close> by auto
 qed
 
 
 lemma lists_of_length_length :
   assumes "xs \<in> set (lists_of_length T n)"
   shows "length xs = n"
 proof -
   have "\<forall> xs \<in> set (lists_of_length T n) . length xs = n"
     by (induction n; simp)
   then show ?thesis using assms by blast
 qed
 
 lemma lists_of_length_elems :
   assumes "xs \<in> set (lists_of_length T n)"
   shows "set xs \<subseteq> set T"
 proof -
   have "\<forall> xs \<in> set (lists_of_length T n) . set xs \<subseteq> set T"
     by (induction n; simp)
   then show ?thesis using assms by blast
 qed
   
 lemma lists_of_length_list_set : 
   "set (lists_of_length xs k) = {xs' . length xs' = k \<and> set xs' \<subseteq> set xs}"
   using lists_of_length_containment[of _ xs k] 
         lists_of_length_length[of _ xs k] 
         lists_of_length_elems[of _ xs k] 
   by blast
     
 
 
 subsubsection \<open>Enumerating List Subsets\<close>
 
 fun generate_selector_lists :: "nat \<Rightarrow> bool list list" where
   "generate_selector_lists k = lists_of_length [False,True] k"
   
 
 lemma generate_selector_lists_set : 
   "set (generate_selector_lists k) = {(bs :: bool list) . length bs = k}"
   using lists_of_length_list_set by auto 
 
 lemma selector_list_index_set:
   assumes "length ms = length bs"
   shows "set (map fst (filter snd (zip ms bs))) = { ms ! i | i . i < length bs \<and> bs ! i}"
 using assms proof (induction bs arbitrary: ms rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc b bs)
   let ?ms = "butlast ms"
   let ?m = "last ms"
 
   have "length ?ms = length bs" using snoc.prems by auto
 
   have "map fst (filter snd (zip ms (bs @ [b]))) 
           = (map fst (filter snd (zip ?ms bs))) @ (map fst (filter snd (zip [?m] [b])))"
     by (metis \<open>length (butlast ms) = length bs\<close> append_eq_conv_conj filter_append length_0_conv 
         map_append snoc.prems snoc_eq_iff_butlast zip_append2)
   then have *: "set (map fst (filter snd (zip ms (bs @ [b])))) 
               = set (map fst (filter snd (zip ?ms bs))) \<union> set (map fst (filter snd (zip [?m] [b])))"
     by simp
     
 
   have "{ms ! i |i. i < length (bs @ [b]) \<and> (bs @ [b]) ! i} 
         = {ms ! i |i. i \<le> (length bs) \<and> (bs @ [b]) ! i}"
     by auto
   moreover have "{ms ! i |i. i \<le> (length bs) \<and> (bs @ [b]) ! i} 
                   = {ms ! i |i. i < length bs \<and> (bs @ [b]) ! i} 
                     \<union> {ms ! i |i. i = length bs \<and> (bs @ [b]) ! i}"
     by fastforce
   moreover have "{ms ! i |i. i < length bs \<and> (bs @ [b]) ! i} = {?ms ! i |i. i < length bs \<and> bs ! i}"
     using \<open>length ?ms = length bs\<close> by (metis butlast_snoc nth_butlast)  
   ultimately have **: "{ms ! i |i. i < length (bs @ [b]) \<and> (bs @ [b]) ! i} 
                       = {?ms ! i |i. i < length bs \<and> bs ! i} 
                         \<union> {ms ! i |i. i = length bs \<and> (bs @ [b]) ! i}"
     by simp
   
 
   have "set (map fst (filter snd (zip [?m] [b]))) = {ms ! i |i. i = length bs \<and> (bs @ [b]) ! i}"
   proof (cases b)
     case True
     then have "set (map fst (filter snd (zip [?m] [b]))) = {?m}" by fastforce
     moreover have "{ms ! i |i. i = length bs \<and> (bs @ [b]) ! i} = {?m}" 
     proof -
       have "(bs @ [b]) ! length bs"
         by (simp add: True) 
       moreover have "ms ! length bs = ?m"
         by (metis last_conv_nth length_0_conv length_butlast snoc.prems snoc_eq_iff_butlast) 
       ultimately show ?thesis by fastforce
     qed
     ultimately show ?thesis by auto
   next
     case False
     then show ?thesis by auto
   qed
 
   then have "set (map fst (filter snd (zip (butlast ms) bs))) 
                 \<union> set (map fst (filter snd (zip [?m] [b])))
              = {butlast ms ! i |i. i < length bs \<and> bs ! i} 
                 \<union> {ms ! i |i. i = length bs \<and> (bs @ [b]) ! i}"
     using snoc.IH[OF \<open>length ?ms = length bs\<close>] by blast
 
   then show ?case using * **
     by simp 
 qed
 
 lemma selector_list_ex :
   assumes "set xs \<subseteq> set ms"
   shows "\<exists> bs . length bs = length ms \<and> set xs = set (map fst (filter snd (zip ms bs)))"
 using assms proof (induction xs rule: rev_induct)
   case Nil
   let ?bs = "replicate (length ms) False"
   have "set [] = set (map fst (filter snd (zip ms ?bs)))"
     by (metis filter_False in_set_zip length_replicate list.simps(8) nth_replicate)
   moreover have "length ?bs = length ms" by auto
   ultimately show ?case by blast
 next
   case (snoc a xs)
   then have "set xs \<subseteq> set ms" and "a \<in> set ms" by auto
   then obtain bs where "length bs = length ms" and "set xs = set (map fst (filter snd (zip ms bs)))" 
     using snoc.IH by auto
 
   from \<open>a \<in> set ms\<close> obtain i where "i < length ms" and "ms ! i = a"
     by (meson in_set_conv_nth) 
 
   let ?bs = "list_update bs i True"
   have "length ms = length ?bs" using \<open>length bs = length ms\<close> by auto
   have "length ?bs = length bs" by auto
 
   have "set (map fst (filter snd (zip ms ?bs))) = {ms ! i |i. i < length ?bs \<and> ?bs ! i}"
     using selector_list_index_set[OF \<open>length ms = length ?bs\<close>] by assumption
 
   have "\<And> j . j < length ?bs \<Longrightarrow> j \<noteq> i \<Longrightarrow> ?bs ! j = bs ! j"
     by auto
   then have "{ms ! j |j. j < length bs \<and> j \<noteq> i \<and> bs ! j} 
               = {ms ! j |j. j < length ?bs \<and> j \<noteq> i \<and> ?bs ! j}"
     using \<open>length ?bs = length bs\<close> by fastforce
   
   
   
   have "{ms ! j |j. j < length ?bs \<and> j = i \<and> ?bs ! j} = {a}"
     using \<open>length bs = length ms\<close> \<open>i < length ms\<close> \<open>ms ! i = a\<close> by auto
   then have "{ms ! i |i. i < length ?bs \<and> ?bs ! i} 
               = insert a {ms ! j |j. j < length ?bs \<and> j \<noteq> i \<and> ?bs ! j}"
     by fastforce
   
 
   have "{ms ! j |j. j < length bs \<and> j = i \<and> bs ! j} \<subseteq> {ms ! j |j. j < length ?bs \<and> j = i \<and> ?bs ! j}"
     by (simp add: Collect_mono)
   then have "{ms ! j |j. j < length bs \<and> j = i \<and> bs ! j} \<subseteq> {a}"
     using \<open>{ms ! j |j. j < length ?bs \<and> j = i \<and> ?bs ! j} = {a}\<close> 
     by auto
   moreover have "{ms ! j |j. j < length bs \<and> bs ! j} 
                 = {ms ! j |j. j < length bs \<and> j = i \<and> bs ! j} 
                     \<union> {ms ! j |j. j < length bs \<and> j \<noteq> i \<and> bs ! j}"
     by fastforce
 
   ultimately have "{ms ! i |i. i < length ?bs \<and> ?bs ! i} 
                     = insert a {ms ! i |i. i < length bs \<and> bs ! i}"
     using \<open>{ms ! j |j. j < length bs \<and> j \<noteq> i \<and> bs ! j} 
             = {ms ! j |j. j < length ?bs \<and> j \<noteq> i \<and> ?bs ! j}\<close>
     using \<open>{ms ! ia |ia. ia < length (bs[i := True]) 
                       \<and> bs[i := True] ! ia} 
                           = insert a {ms ! j |j. j < length (bs[i := True]) 
                               \<and> j \<noteq> i \<and> bs[i := True] ! j}\<close> 
     by auto 
 
   moreover have "set (map fst (filter snd (zip ms bs))) = {ms ! i |i. i < length bs \<and> bs ! i}"
     using selector_list_index_set[of ms bs] \<open>length bs = length ms\<close> by auto
 
   ultimately have "set (a#xs) = set (map fst (filter snd (zip ms ?bs)))"
     using \<open>set (map fst (filter snd (zip ms ?bs))) = {ms ! i |i. i < length ?bs \<and> ?bs ! i}\<close> 
           \<open>set xs = set (map fst (filter snd (zip ms bs)))\<close> 
     by auto
   then show ?case
     using \<open>length ms = length ?bs\<close>
     by (metis Un_commute insert_def list.set(1) list.simps(15) set_append singleton_conv) 
 qed
 
 
 subsubsection \<open>Enumerating Choices from Lists of Lists\<close>
 
 
 fun generate_choices :: "('a \<times> ('b list)) list \<Rightarrow> ('a \<times> 'b option) list list" where
   "generate_choices [] = [[]]" |
   "generate_choices (xys#xyss) = 
     concat (map (\<lambda> xy' . map (\<lambda> xys' . xy' # xys') (generate_choices xyss)) 
                 ((fst xys, None) # (map (\<lambda> y . (fst xys, Some y)) (snd xys))))"
 
 
 lemma concat_map_hd_tl_elem: 
   assumes "hd cs \<in> set P1"
   and     "tl cs \<in> set P2"
   and     "length cs > 0"
 shows "cs \<in> set (concat (map (\<lambda> xy' . map (\<lambda> xys' . xy' # xys') P2) P1))"
 proof -
   have "hd cs # tl cs = cs" using assms(3) by auto
   moreover have "hd cs # tl cs \<in> set (concat (map (\<lambda> xy' . map (\<lambda> xys' . xy' # xys') P2) P1))" 
     using assms(1,2) by auto
   ultimately show ?thesis 
     by auto
 qed
 
 
 lemma generate_choices_hd_tl : 
   "cs \<in> set (generate_choices (xys#xyss)) 
     = (length cs = length (xys#xyss) 
       \<and> fst (hd cs) = fst xys 
       \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))) 
       \<and> (tl cs \<in> set (generate_choices xyss)))"
 proof (induction xyss arbitrary: cs xys)
   case Nil
   have "(cs \<in> set (generate_choices [xys])) 
           = (cs \<in> set ([(fst xys, None)] # map (\<lambda>y. [(fst xys, Some y)]) (snd xys)))" 
     unfolding generate_choices.simps by auto
   moreover have "(cs \<in> set ([(fst xys, None)] # map (\<lambda>y. [(fst xys, Some y)]) (snd xys))) 
                \<Longrightarrow> (length cs = length [xys] \<and>
                    fst (hd cs) = fst xys \<and>
                    (snd (hd cs) = None \<or> snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)) \<and>
                    tl cs \<in> set (generate_choices []))"
     by auto
   moreover have "(length cs = length [xys] \<and>
                    fst (hd cs) = fst xys \<and>
                    (snd (hd cs) = None \<or> snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)) \<and>
                    tl cs \<in> set (generate_choices [])) 
                 \<Longrightarrow> (cs \<in> set ([(fst xys, None)] # map (\<lambda>y. [(fst xys, Some y)]) (snd xys)))"
     unfolding generate_choices.simps(1)
   proof -
     assume a1: "length cs = length [xys] 
                 \<and> fst (hd cs) = fst xys 
                 \<and> (snd (hd cs) = None \<or> snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)) 
                 \<and> tl cs \<in> set [[]]"
     have f2: "\<forall>ps. ps = [] \<or> ps = (hd ps::'a \<times> 'b option) # tl ps"
       by (meson list.exhaust_sel)
     have f3: "cs \<noteq> []"
       using a1 by fastforce
     have "snd (hd cs) = None \<longrightarrow> (fst xys, None) = hd cs"
       using a1 by (metis prod.exhaust_sel)
     moreover
     { assume "hd cs # tl cs \<noteq> [(fst xys, Some (the (snd (hd cs))))]"
       then have "snd (hd cs) = None"
         using a1 by (metis (no_types) length_0_conv length_tl list.sel(3) 
                       option.collapse prod.exhaust_sel) }
     ultimately have "cs \<in> insert [(fst xys, None)] ((\<lambda>b. [(fst xys, Some b)]) ` set (snd xys))"
       using f3 f2 a1 by fastforce
     then show ?thesis
       by simp
   qed 
   ultimately show ?case by blast
 next
   case (Cons a xyss)
 
   have "length cs = length (xys#a#xyss) 
         \<Longrightarrow> fst (hd cs) = fst xys 
         \<Longrightarrow> (snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys))) 
         \<Longrightarrow> (tl cs \<in> set (generate_choices (a#xyss))) 
         \<Longrightarrow> cs \<in> set (generate_choices (xys#a#xyss))"
   proof -
     assume "length cs = length (xys#a#xyss)" 
        and "fst (hd cs) = fst xys" 
        and "(snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))" 
        and "(tl cs \<in> set (generate_choices (a#xyss)))"
     then have "length cs > 0" by auto
 
     have "(hd cs) \<in> set ((fst xys, None) # (map (\<lambda> y . (fst xys, Some y)) (snd xys)))"
       using \<open>fst (hd cs) = fst xys\<close> 
             \<open>(snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))\<close>
       by (metis (no_types, lifting) image_eqI list.set_intros(1) list.set_intros(2) 
             option.collapse prod.collapse set_map)  
     
     show "cs \<in> set (generate_choices ((xys#(a#xyss))))"
       using generate_choices.simps(2)[of xys "a#xyss"] 
             concat_map_hd_tl_elem[OF \<open>(hd cs) \<in> set ((fst xys, None) # (map (\<lambda> y . (fst xys, Some y)) (snd xys)))\<close> 
                                      \<open>(tl cs \<in> set (generate_choices (a#xyss)))\<close> 
                                      \<open>length cs > 0\<close>] 
       by auto
   qed
 
   moreover have "cs \<in> set (generate_choices (xys#a#xyss)) 
                 \<Longrightarrow> length cs = length (xys#a#xyss) 
                     \<and> fst (hd cs) = fst xys 
                     \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None 
                     \<and> the (snd (hd cs)) \<in> set (snd xys)))) 
                     \<and> (tl cs \<in> set (generate_choices (a#xyss)))"
   proof -
     assume "cs \<in> set (generate_choices (xys#a#xyss))"
     then have p3: "tl cs \<in> set (generate_choices (a#xyss))"
       using generate_choices.simps(2)[of xys "a#xyss"] by fastforce
     then have "length (tl cs) = length (a # xyss)" using Cons.IH[of "tl cs" "a"] by simp
     then have p1: "length cs = length (xys#a#xyss)" by auto
 
     have p2 : "fst (hd cs) = fst xys \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None 
                                 \<and> the (snd (hd cs)) \<in> set (snd xys))))"
       using \<open>cs \<in> set (generate_choices (xys#a#xyss))\<close> generate_choices.simps(2)[of xys "a#xyss"] 
       by fastforce
     
     show ?thesis using p1 p2 p3 by simp
   qed
 
   ultimately show ?case by blast
 qed 
 
 lemma list_append_idx_prop : 
   "(\<forall> i . (i < length xs \<longrightarrow> P (xs ! i))) 
     = (\<forall> j . ((j < length (ys@xs) \<and> j \<ge> length ys) \<longrightarrow> P ((ys@xs) ! j)))"
 proof -
   have "\<And> j . \<forall>i<length xs. P (xs ! i) \<Longrightarrow> j < length (ys @ xs) 
               \<Longrightarrow> length ys \<le> j \<longrightarrow> P ((ys @ xs) ! j)"
     by (simp add: nth_append)
   moreover have "\<And> i . (\<forall> j . ((j < length (ys@xs) \<and> j \<ge> length ys) \<longrightarrow> P ((ys@xs) ! j))) 
                   \<Longrightarrow> i < length xs \<Longrightarrow> P (xs ! i)"
   proof -
     fix i assume "(\<forall> j . ((j < length (ys@xs) \<and> j \<ge> length ys) \<longrightarrow> P ((ys@xs) ! j)))" 
              and "i < length xs"
     then have "P ((ys@xs) ! (length ys + i))"
       by (metis add_strict_left_mono le_add1 length_append)
     moreover have "P (xs ! i) = P ((ys@xs) ! (length ys + i))"
       by simp
     ultimately show "P (xs ! i)" by blast
   qed
   ultimately show ?thesis by blast
 qed
 
 lemma list_append_idx_prop2 : 
   assumes "length xs' = length xs"
       and "length ys' = length ys"
   shows "(\<forall> i . (i < length xs \<longrightarrow> P (xs ! i) (xs' ! i))) 
           = (\<forall> j . ((j < length (ys@xs) \<and> j \<ge> length ys) \<longrightarrow> P ((ys@xs) ! j) ((ys'@xs') ! j)))"
 proof -
   have "\<forall>i<length xs. P (xs ! i) (xs' ! i) \<Longrightarrow>
     \<forall>j. j < length (ys @ xs) \<and> length ys \<le> j \<longrightarrow> P ((ys @ xs) ! j) ((ys' @ xs') ! j)"
     using assms
   proof -
     assume a1: "\<forall>i<length xs. P (xs ! i) (xs' ! i)"
     { fix nn :: nat
       have ff1: "\<forall>n na. (na::nat) + n - n = na"
         by simp
       have ff2: "\<forall>n na. (na::nat) \<le> n + na"
         by auto
       then have ff3: "\<forall>as n. (ys' @ as) ! n = as ! (n - length ys) \<or> \<not> length ys \<le> n"
         using ff1 by (metis (no_types) add.commute assms(2) eq_diff_iff nth_append_length_plus)
       have ff4: "\<forall>n bs bsa. ((bsa @ bs) ! n::'b) = bs ! (n - length bsa) \<or> \<not> length bsa \<le> n"
         using ff2 ff1 by (metis (no_types) add.commute eq_diff_iff nth_append_length_plus)
       have "\<forall>n na nb. ((n::nat) + nb \<le> na \<or> \<not> n \<le> na - nb) \<or> \<not> nb \<le> na"
         using ff2 ff1 by (metis le_diff_iff)
       then have "(\<not> nn < length (ys @ xs) \<or> \<not> length ys \<le> nn) 
                   \<or> P ((ys @ xs) ! nn) ((ys' @ xs') ! nn)"
         using ff4 ff3 a1 by (metis add.commute length_append not_le) }
     then show ?thesis
       by blast
   qed
 
   moreover have "(\<forall>j. j < length (ys @ xs) \<and> length ys \<le> j \<longrightarrow> P ((ys @ xs) ! j) ((ys' @ xs') ! j)) 
                   \<Longrightarrow> \<forall>i<length xs. P (xs ! i) (xs' ! i)"
     using assms
     by (metis le_add1 length_append nat_add_left_cancel_less nth_append_length_plus) 
 
   ultimately show ?thesis by blast
 qed
 
 lemma generate_choices_idx : 
   "cs \<in> set (generate_choices xyss) 
     = (length cs = length xyss 
         \<and> (\<forall> i < length cs . (fst (cs ! i)) = (fst (xyss ! i)) 
         \<and> ((snd (cs ! i)) = None 
             \<or> ((snd (cs ! i)) \<noteq> None \<and> the (snd (cs ! i)) \<in> set (snd (xyss ! i))))))"
 proof (induction xyss arbitrary: cs)
   case Nil
   then show ?case by auto
 next
   case (Cons xys xyss)
 
   have "cs \<in> set (generate_choices (xys#xyss)) 
         = (length cs = length (xys#xyss) 
             \<and> fst (hd cs) = fst xys 
             \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))) 
             \<and> (tl cs \<in> set (generate_choices xyss)))"
     using generate_choices_hd_tl by metis
 
   then have "cs \<in> set (generate_choices (xys#xyss)) 
     = (length cs = length (xys#xyss) 
       \<and> fst (hd cs) = fst xys 
       \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))) 
       \<and> (length (tl cs) = length xyss \<and>
         (\<forall>i<length (tl cs).
           fst (tl cs ! i) = fst (xyss ! i) \<and>
           (snd (tl cs ! i) = None 
             \<or> snd (tl cs ! i) \<noteq> None \<and> the (snd (tl cs ! i)) \<in> set (snd (xyss ! i))))))"
     using Cons.IH[of "tl cs"] by blast
   then have *: "cs \<in> set (generate_choices (xys#xyss)) 
     = (length cs = length (xys#xyss) 
       \<and> fst (hd cs) = fst xys 
       \<and> ((snd (hd cs) = None \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys)))) 
       \<and> (\<forall>i<length (tl cs).
           fst (tl cs ! i) = fst (xyss ! i) \<and>
           (snd (tl cs ! i) = None 
             \<or> snd (tl cs ! i) \<noteq> None \<and> the (snd (tl cs ! i)) \<in> set (snd (xyss ! i)))))"
     by auto
 
 
   have "cs \<in> set (generate_choices (xys#xyss)) \<Longrightarrow> (length cs = length (xys # xyss) \<and>
                     (\<forall>i<length cs.
                         fst (cs ! i) = fst ((xys # xyss) ! i) \<and>
                         (snd (cs ! i) = None \<or>
                         snd (cs ! i) \<noteq> None \<and> the (snd (cs ! i)) \<in> set (snd ((xys # xyss) ! i)))))"
   proof -
     assume "cs \<in> set (generate_choices (xys#xyss))"
     then have p1: "length cs = length (xys#xyss)"
           and p2: "fst (hd cs) = fst xys "
           and p3: "((snd (hd cs) = None 
                     \<or> (snd (hd cs) \<noteq> None \<and> the (snd (hd cs)) \<in> set (snd xys))))"
           and p4: "(\<forall>i<length (tl cs).
                   fst (tl cs ! i) = fst (xyss ! i) \<and>
                   (snd (tl cs ! i) = None 
                     \<or> snd (tl cs ! i) \<noteq> None \<and> the (snd (tl cs ! i)) \<in> set (snd (xyss ! i))))"
       using * by blast+
     then have "length xyss = length (tl cs)" and "length (xys # xyss) = length ([hd cs] @ tl cs)"
       by auto
     
     have "[hd cs]@(tl cs) = cs"
       by (metis (no_types) p1 append.left_neutral append_Cons length_greater_0_conv 
             list.collapse list.simps(3)) 
     then have p4b: "(\<forall>i<length cs. i > 0 \<longrightarrow>
                     (fst (cs ! i) = fst ((xys#xyss) ! i) \<and>
                       (snd (cs ! i) = None 
                         \<or> snd (cs ! i) \<noteq> None \<and> the (snd (cs ! i)) \<in> set (snd ((xys#xyss) ! i)))))"
       using p4 list_append_idx_prop2[of xyss "tl cs" "xys#xyss" "[hd cs]@(tl cs)" 
                                         "\<lambda> x y . fst x = fst y 
                                                   \<and> (snd x = None 
                                                       \<or> snd x \<noteq> None \<and> the (snd x) \<in> set (snd y))", 
                                      OF \<open>length xyss = length (tl cs)\<close> 
                                         \<open>length (xys # xyss) = length ([hd cs] @ tl cs)\<close>]
       by (metis (no_types, lifting) One_nat_def Suc_pred 
             \<open>length (xys # xyss) = length ([hd cs] @ tl cs)\<close> \<open>length xyss = length (tl cs)\<close> 
             length_Cons list.size(3) not_less_eq nth_Cons_pos nth_append) 
 
     have p4a :"(fst (cs ! 0) = fst ((xys#xyss) ! 0) \<and> (snd (cs ! 0) = None 
                 \<or> snd (cs ! 0) \<noteq> None \<and> the (snd (cs ! 0)) \<in> set (snd ((xys#xyss) ! 0))))"
       using p1 p2 p3 by (metis hd_conv_nth length_greater_0_conv list.simps(3) nth_Cons_0)
 
     show ?thesis using p1 p4a p4b by fastforce
   qed
 
 
   moreover have "(length cs = length (xys # xyss) \<and>
                     (\<forall>i<length cs.
                         fst (cs ! i) = fst ((xys # xyss) ! i) \<and>
                         (snd (cs ! i) = None \<or>
                         snd (cs ! i) \<noteq> None \<and> the (snd (cs ! i)) \<in> set (snd ((xys # xyss) ! i))))) 
                   \<Longrightarrow> cs \<in> set (generate_choices (xys#xyss))"
     using * 
     by (metis (no_types, lifting) Nitpick.size_list_simp(2) Suc_mono hd_conv_nth 
         length_greater_0_conv length_tl list.sel(3) list.simps(3) nth_Cons_0 nth_tl) 
 
   ultimately show ?case by blast
 qed
 
 
 subsection \<open>Finding the Index of the First Element of a List Satisfying a Property\<close>
 
 
 fun find_index :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat option" where
   "find_index f []  = None" |
   "find_index f (x#xs) = (if f x 
     then Some 0 
     else (case find_index f xs of Some k \<Rightarrow> Some (Suc k) | None \<Rightarrow> None))" 
 
 lemma find_index_index :
   assumes "find_index f xs = Some k"
   shows "k < length xs" and "f (xs ! k)" and "\<And> j . j < k \<Longrightarrow> \<not> f (xs ! j)"
 proof -
   have "(k < length xs) \<and> (f (xs ! k)) \<and> (\<forall> j < k . \<not> (f (xs ! j)))"
     using assms proof (induction xs arbitrary: k)
     case Nil
     then show ?case by auto
   next
     case (Cons x xs)
     
     show ?case proof (cases "f x")
       case True
       then show ?thesis using Cons.prems by auto
     next
       case False
       then have "find_index f (x#xs) 
                   = (case find_index f xs of Some k \<Rightarrow> Some (Suc k) | None \<Rightarrow> None)"
         by auto
       then have "(case find_index f xs of Some k \<Rightarrow> Some (Suc k) | None \<Rightarrow> None) = Some k"
         using Cons.prems by auto
       then obtain k' where "find_index f xs = Some k'" and "k = Suc k'"
         by (metis option.case_eq_if option.collapse option.distinct(1) option.sel)
         
       have "k < length (x # xs) \<and> f ((x # xs) ! k)" 
         using Cons.IH[OF \<open>find_index f xs = Some k'\<close>] \<open>k = Suc k'\<close> 
         by auto
       moreover have "(\<forall>j<k. \<not> f ((x # xs) ! j))"
         using Cons.IH[OF \<open>find_index f xs = Some k'\<close>] \<open>k = Suc k'\<close> False less_Suc_eq_0_disj 
         by auto 
       ultimately show ?thesis by presburger
     qed
   qed
   then show "k < length xs" and "f (xs ! k)" and "\<And> j . j < k \<Longrightarrow> \<not> f (xs ! j)" by simp+
 qed
 
 lemma find_index_exhaustive : 
   assumes "\<exists> x \<in> set xs . f x"
   shows "find_index f xs \<noteq> None"
   using assms proof (induction xs)
 case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then show ?case by (cases "f x"; auto)
 qed
 
 
 
 subsection \<open>List Distinctness from Sorting\<close>
 
 lemma non_distinct_repetition_indices :
   assumes "\<not> distinct xs"
   shows "\<exists> i j . i < j \<and> j < length xs \<and> xs ! i = xs ! j"
   by (metis assms distinct_conv_nth le_neq_implies_less not_le)
 
 lemma non_distinct_repetition_indices_rev :
   assumes "i < j" and "j < length xs" and "xs ! i = xs ! j"
   shows "\<not> distinct xs"
   using assms nth_eq_iff_index_eq by fastforce 
 
 lemma ordered_list_distinct :
   fixes xs :: "('a::preorder) list"
   assumes "\<And> i . Suc i < length xs \<Longrightarrow> (xs ! i) < (xs ! (Suc i))"
   shows "distinct xs"
 proof -
   have "\<And> i j . i < j \<Longrightarrow> j < length xs \<Longrightarrow> (xs ! i) < (xs ! j)"
   proof -
     fix i j assume "i < j" and "j < length xs"
     then show "xs ! i < xs ! j"
       using assms proof (induction xs arbitrary: i j rule: rev_induct)
       case Nil
       then show ?case by auto
     next
       case (snoc a xs)
       show ?case proof (cases "j < length xs")
         case True
         show ?thesis using snoc.IH[OF snoc.prems(1) True] snoc.prems(3)
         proof -
           have f1: "i < length xs"
             using True less_trans snoc.prems(1) by blast
           have f2: "\<forall>is isa n. if n < length is then (is @ isa) ! n 
                     = (is ! n::integer) else (is @ isa) ! n = isa ! (n - length is)"
             by (meson nth_append)
           then have f3: "(xs @ [a]) ! i = xs ! i"
             using f1
             by (simp add: nth_append)
           have "xs ! i < xs ! j"
             using f2
             by (metis Suc_lessD \<open>(\<And>i. Suc i < length xs \<Longrightarrow> xs ! i < xs ! Suc i) \<Longrightarrow> xs ! i < xs ! j\<close> 
                   butlast_snoc length_append_singleton less_SucI nth_butlast snoc.prems(3)) 
           then show ?thesis
             using f3 f2 True
             by (simp add: nth_append) 
         qed
       next
         case False
         then have "(xs @ [a]) ! j = a"
           using snoc.prems(2)
           by (metis length_append_singleton less_SucE nth_append_length)  
         
         consider "j = 1" | "j > 1"
           using \<open>i < j\<close>
           by linarith 
         then show ?thesis proof cases
           case 1
           then have "i = 0" and "j = Suc i" using \<open>i < j\<close> by linarith+ 
           then show ?thesis 
             using snoc.prems(3)
             using snoc.prems(2) by blast 
         next
           case 2
           then consider "i < j - 1" | "i = j - 1" using \<open>i < j\<close> by linarith+
           then show ?thesis proof cases
             case 1
             
             have "(\<And>i. Suc i < length xs \<Longrightarrow> xs ! i < xs ! Suc i) \<Longrightarrow> xs ! i < xs ! (j - 1)"
               using snoc.IH[OF 1] snoc.prems(2) 2 by simp 
             then have le1: "(xs @ [a]) ! i < (xs @ [a]) ! (j -1)"
               using snoc.prems(2)
               by (metis "2" False One_nat_def Suc_diff_Suc Suc_lessD diff_zero snoc.prems(3)
                     length_append_singleton less_SucE not_less_eq nth_append snoc.prems(1))
             moreover have le2: "(xs @ [a]) ! (j -1) < (xs @ [a]) ! j"
               using snoc.prems(2,3) 2 less_trans
               by (metis (full_types) One_nat_def Suc_diff_Suc diff_zero less_numeral_extra(1))  
             ultimately show ?thesis 
               using less_trans by blast
           next
             case 2
             then have "j = Suc i" using \<open>1 < j\<close> by linarith
             then show ?thesis 
               using snoc.prems(3)
               using snoc.prems(2) by blast
           qed
         qed
       qed
     qed 
   qed
 
   then show ?thesis
     by (metis less_asym non_distinct_repetition_indices)
 qed
 
 
 
 lemma ordered_list_distinct_rev :
   fixes xs :: "('a::preorder) list"
   assumes "\<And> i . Suc i < length xs \<Longrightarrow> (xs ! i) > (xs ! (Suc i))"
   shows "distinct xs"
 proof -
   have "\<And> i . Suc i < length (rev xs) \<Longrightarrow> ((rev xs) ! i) < ((rev xs) ! (Suc i))"
     using assms
   proof -
     fix i :: nat
     assume a1: "Suc i < length (rev xs)"
     obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
       "\<forall>x0 x1. (\<exists>v2. x1 = Suc v2 \<and> v2 < x0) = (x1 = Suc (nn x0 x1) \<and> nn x0 x1 < x0)"
       by moura
     then have f2: "\<forall>n na. (\<not> n < Suc na \<or> n = 0 \<or> n = Suc (nn na n) \<and> nn na n < na) 
                     \<and> (n < Suc na \<or> n \<noteq> 0 \<and> (\<forall>nb. n \<noteq> Suc nb \<or> \<not> nb < na))"
       by (meson less_Suc_eq_0_disj)
     have f3: "Suc (length xs - Suc (Suc i)) = length (rev xs) - Suc i"
       using a1 by (simp add: Suc_diff_Suc)
     have "i < length (rev xs)"
       using a1 by (meson Suc_lessD)
     then have "i < length xs"
       by simp
     then show "rev xs ! i < rev xs ! Suc i"
       using f3 f2 a1 by (metis (no_types) assms diff_less length_rev not_less_iff_gr_or_eq rev_nth)
   qed 
   then have "distinct (rev xs)" 
     using ordered_list_distinct[of "rev xs"] by blast
   then show ?thesis by auto
 qed
 
 
 
 subsection \<open>Calculating Prefixes and Suffixes\<close>
 
 fun suffixes :: "'a list \<Rightarrow> 'a list list" where
   "suffixes [] = [[]]" |
   "suffixes (x#xs) = (suffixes xs) @ [x#xs]"
 
 lemma suffixes_set : 
   "set (suffixes xs) = {zs . \<exists> ys . ys@zs = xs}"
 proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then have *: "set (suffixes (x#xs)) = {zs . \<exists> ys . ys@zs = xs} \<union> {x#xs}"
     by auto
   
   have "{zs . \<exists> ys . ys@zs = xs} = {zs . \<exists> ys . x#ys@zs = x#xs}"
     by force
   then have "{zs . \<exists> ys . ys@zs = xs} = {zs . \<exists> ys . ys@zs = x#xs \<and> ys \<noteq> []}"
     by (metis Cons_eq_append_conv list.distinct(1))
   moreover have "{x#xs} = {zs . \<exists> ys . ys@zs = x#xs \<and> ys = []}"
     by force
     
   ultimately show ?case using * by force
 qed
 
 
 
 
 
 lemma prefixes_set : "set (prefixes xs) = {xs' . \<exists> xs'' . xs'@xs'' = xs}"
 proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   moreover have "prefixes (x#xs) = [] # map ((#) x) (prefixes xs)"
     by auto
   ultimately have *: "set (prefixes (x#xs)) = insert [] (((#) x) ` {xs'. \<exists>xs''. xs' @ xs'' = xs})"
     by auto
   also have "\<dots> = {xs' . \<exists> xs'' . xs'@xs'' = (x#xs)}" 
   proof 
     show "insert [] ((#) x ` {xs'. \<exists>xs''. xs' @ xs'' = xs}) \<subseteq> {xs'. \<exists>xs''. xs' @ xs'' = x # xs}" 
       by auto
     show "{xs'. \<exists>xs''. xs' @ xs'' = x # xs} \<subseteq> insert [] ((#) x ` {xs'. \<exists>xs''. xs' @ xs'' = xs})"
     proof 
       fix y assume "y \<in> {xs'. \<exists>xs''. xs' @ xs'' = x # xs}"
       then obtain y' where "y@y' = x # xs"
         by blast
       then show "y \<in> insert [] ((#) x ` {xs'. \<exists>xs''. xs' @ xs'' = xs})"
         by (cases y; auto)
     qed
   qed
   finally show ?case .
 qed
 
 
 
 fun is_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "is_prefix [] _ = True" |
   "is_prefix (x#xs) [] = False" |
   "is_prefix (x#xs) (y#ys) = (x = y \<and> is_prefix xs ys)" 
 
 lemma is_prefix_prefix : "is_prefix xs ys = (\<exists> xs' . ys = xs@xs')"
 proof (induction xs arbitrary: ys)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   show ?case proof (cases "is_prefix (x#xs) ys")
     case True
     then show ?thesis using Cons.IH
       by (metis append_Cons is_prefix.simps(2) is_prefix.simps(3) neq_Nil_conv) 
   next
     case False
     then show ?thesis
       using Cons.IH by auto 
   qed
 qed
 
 
 fun add_prefixes :: "'a list list \<Rightarrow> 'a list list" where
   "add_prefixes xs = concat (map prefixes xs)"
 
 
 lemma add_prefixes_set : "set (add_prefixes xs) = {xs' . \<exists> xs'' . xs'@xs'' \<in> set xs}"
 proof -
   have "set (add_prefixes xs) = {xs' . \<exists> x \<in> set xs . xs' \<in> set (prefixes x)}"
     unfolding add_prefixes.simps by auto
   also have "\<dots> = {xs' . \<exists> xs'' . xs'@xs'' \<in> set xs}"
   proof (induction xs)
     case Nil
     then show ?case using prefixes_set by auto
   next
     case (Cons a xs)
     then show ?case 
     proof -
       have "\<And> xs' . xs' \<in> {xs'. \<exists>x\<in>set (a # xs). xs' \<in> set (prefixes x)} 
               \<longleftrightarrow> xs' \<in> {xs'. \<exists>xs''. xs' @ xs'' \<in> set (a # xs)}"
       proof -
         fix xs' 
         show "xs' \<in> {xs'. \<exists>x\<in>set (a # xs). xs' \<in> set (prefixes x)} 
               \<longleftrightarrow> xs' \<in> {xs'. \<exists>xs''. xs' @ xs'' \<in> set (a # xs)}"
           unfolding prefixes_set by force
       qed
       then show ?thesis by blast
     qed
   qed
   finally show ?thesis by blast
 qed
 
 
 lemma prefixes_set_ob :
   assumes "xs \<in> set (prefixes xss)"
   obtains xs' where "xss = xs@xs'"
   using assms unfolding prefixes_set
   by auto 
 
 lemma prefixes_finite : "finite { x \<in> set (prefixes xs) . P x}"
   by (metis Collect_mem_eq List.finite_set finite_Collect_conjI)
   
 
 lemma prefixes_set_Cons_insert: "set (prefixes (w' @ [xy])) = Set.insert (w'@[xy]) (set (prefixes (w')))"
   unfolding prefixes_set 
 proof (induction w' arbitrary: xy rule: rev_induct)
   case Nil
   then show ?case 
     by (auto; simp add: append_eq_Cons_conv) 
   next
     case (snoc x xs)
     then show ?case 
       by (auto; metis (no_types, opaque_lifting) butlast.simps(2) butlast_append butlast_snoc)
   qed
 
 lemma prefixes_set_subset:
   "set (prefixes xs) \<subseteq> set (prefixes (xs@ys))"
   unfolding prefixes_set by auto
 
 lemma prefixes_prefix_subset :
   assumes "xs \<in> set (prefixes ys)"
   shows "set (prefixes xs) \<subseteq> set (prefixes ys)"
   using assms unfolding prefixes_set by auto
 
 lemma prefixes_butlast_is_prefix :
   "butlast xs \<in> set (prefixes xs)"
   unfolding prefixes_set
   by (metis (mono_tags, lifting) append_butlast_last_id butlast.simps(1) mem_Collect_eq self_append_conv2) 
 
 lemma prefixes_take_iff :
   "xs \<in> set (prefixes ys) \<longleftrightarrow> take (length xs) ys = xs"
 proof 
   show "xs \<in> set (prefixes ys) \<Longrightarrow> take (length xs) ys = xs"
     unfolding prefixes_set
     by (simp add: append_eq_conv_conj) 
 
   show "take (length xs) ys = xs \<Longrightarrow> xs \<in> set (prefixes ys)"
     unfolding prefixes_set
     by (metis (mono_tags, lifting) append_take_drop_id mem_Collect_eq)
 qed
 
 lemma prefixes_set_Nil : "[] \<in> list.set (prefixes xs)"
   by (metis append.left_neutral list.set_intros(1) prefixes.simps(1) prefixes_set_subset subset_iff) 
 
 lemma prefixes_prefixes :
   assumes "ys \<in> list.set (prefixes xs)"
           "zs \<in> list.set (prefixes xs)"
   shows "ys \<in> list.set (prefixes zs) \<or> zs \<in> list.set (prefixes ys)"
 proof (rule ccontr)
   let ?ys = "take (length ys) zs"
   let ?zs = "take (length zs) ys"
   
   assume "\<not> (ys \<in> list.set (prefixes zs) \<or> zs \<in> list.set (prefixes ys))"
   then have "?ys \<noteq> ys" and "?zs \<noteq> zs"
     using prefixes_take_iff by blast+
   moreover have "?ys = ys \<or> ?zs = zs"
     using assms
     by (metis linear min.commute prefixes_take_iff take_all_iff take_take)
   ultimately show False
     by simp
 qed
 
 
 subsubsection \<open>Pairs of Distinct Prefixes\<close>
 
 fun prefix_pairs :: "'a list \<Rightarrow> ('a list \<times> 'a list) list" 
   where "prefix_pairs [] = []" |
         "prefix_pairs xs = prefix_pairs (butlast xs) @ (map (\<lambda> ys. (ys,xs)) (butlast (prefixes xs)))"
 
 
 lemma prefixes_butlast :
   "set (butlast (prefixes xs)) = {ys . \<exists> zs . ys@zs = xs \<and> zs \<noteq> []}"
 proof (induction "length xs" arbitrary: xs)
   case 0
   then show ?case by auto
 next
   case (Suc k)
 
   then obtain x xs' where "xs = x#xs'" and "k = length xs' "
     by (metis length_Suc_conv)
 
   then have "prefixes xs = [] # map ((#) x) (prefixes xs')"
     by auto
   then have "butlast (prefixes xs) = [] # map ((#) x) (butlast (prefixes xs'))"
     by (simp add: map_butlast)
   then have "set (butlast (prefixes xs)) = insert [] (((#) x) ` {ys . \<exists> zs . ys@zs = xs' \<and> zs \<noteq> []})"
     using Suc.hyps(1)[OF \<open>k = length xs'\<close>]
     by auto
   also have "\<dots> = {ys . \<exists> zs . ys@zs = (x#xs') \<and> zs \<noteq> []}"
   proof 
     show "insert [] ((#) x ` {ys. \<exists>zs. ys @ zs = xs' \<and> zs \<noteq> []}) \<subseteq> {ys. \<exists>zs. ys @ zs = x # xs' \<and> zs \<noteq> []}" 
       by auto
     show "{ys. \<exists>zs. ys @ zs = x # xs' \<and> zs \<noteq> []} \<subseteq> insert [] ((#) x ` {ys. \<exists>zs. ys @ zs = xs' \<and> zs \<noteq> []})"
     proof 
       fix ys assume "ys \<in> {ys. \<exists>zs. ys @ zs = x # xs' \<and> zs \<noteq> []}"
       then show "ys \<in> insert [] ((#) x ` {ys. \<exists>zs. ys @ zs = xs' \<and> zs \<noteq> []})"
         by (cases ys; auto)
     qed
   qed
   finally show ?case 
     unfolding \<open>xs = x#xs'\<close> .
 qed
 
 
 lemma prefix_pairs_set :
   "set (prefix_pairs xs) = {(zs,ys) | zs ys . \<exists> xs1 xs2 . zs@xs1 = ys \<and> ys@xs2 = xs \<and> xs1 \<noteq> []}"  
 proof (induction xs rule: rev_induct)
   case Nil
   then show ?case by auto 
 next
   case (snoc x xs)
   have "prefix_pairs (xs @ [x]) = prefix_pairs (butlast (xs @ [x])) @ (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x]))))"
     by (cases "(xs @ [x])"; auto)
   then have *: "prefix_pairs (xs @ [x]) = prefix_pairs xs @ (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x]))))"
     by auto
 
   have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs \<and> xs1 \<noteq> []}"
     using snoc.IH by assumption
   then have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 @ [x] = xs@[x] \<and> xs1 \<noteq> []}"
     by auto
   also have "... = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @[x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> []}" 
   proof -
     let ?P1 = "\<lambda> zs ys . (\<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 @ [x] = xs@[x] \<and> xs1 \<noteq> [])"
     let ?P2 = "\<lambda> zs ys . (\<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @[x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> [])"
 
     have "\<And> ys zs . ?P2 zs ys \<Longrightarrow> ?P1 zs ys"
       by (metis append_assoc butlast_append butlast_snoc)
     then have "\<And> ys zs . ?P1 ys zs = ?P2 ys zs"
       by blast
     then show ?thesis by force           
   qed
   finally have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @ [x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> []}"
     by assumption
 
   moreover have "set (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x])))) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @ [x] \<and> xs1 \<noteq> [] \<and> xs2 = []}"
     using prefixes_butlast[of "xs@[x]"] by force
 
   ultimately show ?case using * by force
 qed
 
 lemma prefix_pairs_set_alt :
   "set (prefix_pairs xs) = {(xs1,xs1@xs2) | xs1 xs2 . xs2 \<noteq> [] \<and> (\<exists> xs3 . xs1@xs2@xs3 = xs)}"
   unfolding prefix_pairs_set by auto
 
 lemma prefixes_Cons :
   assumes "(x#xs) \<in> set (prefixes (y#ys))"
   shows "x = y" and "xs \<in> set (prefixes ys)"
 proof -
   show "x = y"
     by (metis Cons_eq_appendI assms nth_Cons_0 prefixes_set_ob) 
   
   show "xs \<in> set (prefixes ys)"
   proof -
     obtain xs' xs'' where "(x#xs) = xs'" and "(y#ys) = xs'@xs''"
       by (meson assms prefixes_set_ob)
     then have "xs' = x#tl xs'"
       by auto
     then have "xs = tl xs'"
       using \<open>(x#xs) = xs'\<close> by auto
     moreover have "ys = (tl xs')@xs''"
       using \<open>(y#ys) = xs'@xs''\<close> \<open>xs' = x#tl xs'\<close>
       by (metis append_Cons list.inject) 
     ultimately show ?thesis 
       unfolding prefixes_set by blast
   qed
 qed
 
 lemma prefixes_prepend :
   assumes "xs' \<in> set (prefixes xs)"
   shows "ys@xs' \<in> set (prefixes (ys@xs))"
 proof -
   obtain xs'' where "xs = xs'@xs''"
     using assms
     using prefixes_set_ob by auto
   then have "(ys@xs) = (ys@xs')@xs''"
     by auto
   then show ?thesis
     unfolding prefixes_set by auto
 qed
 
 
 lemma prefixes_prefix_suffix_ob :
   assumes "a \<in> set (prefixes (b@c))"
   and     "a \<notin> set (prefixes b)"
 obtains c' c'' where "c = c'@c''"
                  and "a = b@c'"
                  and "c' \<noteq> []"
 proof -
   have "\<exists> c' c'' . c = c'@c'' \<and> a = b@c' \<and> c' \<noteq> []"
     using assms 
   proof (induction b arbitrary: a)
     case Nil
     then show ?case 
       unfolding prefixes_set
       by fastforce 
   next
     case (Cons x xs)
     show ?case proof (cases a)
       case Nil
       then show ?thesis
         by (metis Cons.prems(2) list.size(3) prefixes_take_iff take_eq_Nil) 
     next
       case (Cons a' as)
       then have "a' # as \<in> set (prefixes (x #(xs@c)))"
         using Cons.prems(1) by auto
   
       have "a' = x" and "as \<in> set (prefixes (xs@c))"
         using prefixes_Cons[OF \<open>a' # as \<in> set (prefixes (x #(xs@c)))\<close>] 
         by auto
       moreover have "as \<notin> set (prefixes xs)"
         using \<open>a \<notin> set (prefixes (x # xs))\<close> unfolding Cons \<open>a' = x\<close> prefixes_set by auto
   
       ultimately obtain c' c'' where "c = c'@c''"
                                  and "as = xs@c'"
                                  and "c' \<noteq> []"
         using Cons.IH by blast
       then have "c = c'@c''" and "a = (x#xs)@c'" and "c' \<noteq> []"
         unfolding Cons \<open>a' = x\<close> by auto
       then show ?thesis
         using that by blast
     qed
   qed
   then show ?thesis using that by blast
 qed
 
 fun list_ordered_pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "list_ordered_pairs [] = []" |
   "list_ordered_pairs (x#xs) = (map (Pair x) xs) @ (list_ordered_pairs xs)"
 
 lemma list_ordered_pairs_set_containment :
   assumes "x \<in> list.set xs"
   and     "y \<in> list.set xs"
   and     "x \<noteq> y"
 shows "(x,y) \<in> list.set (list_ordered_pairs xs) \<or> (y,x) \<in> list.set (list_ordered_pairs xs)"
   using assms by (induction xs; auto)
 
 subsection \<open>Calculating Distinct Non-Reflexive Pairs over List Elements\<close> 
 
 fun non_sym_dist_pairs' :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "non_sym_dist_pairs' [] = []" |
   "non_sym_dist_pairs' (x#xs) = (map (\<lambda> y. (x,y)) xs) @ non_sym_dist_pairs' xs"
 
 fun non_sym_dist_pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "non_sym_dist_pairs xs = non_sym_dist_pairs' (remdups xs)"
 
 
 lemma non_sym_dist_pairs_subset : "set (non_sym_dist_pairs xs) \<subseteq> (set xs) \<times> (set xs)"
   by (induction xs; auto)
 
 lemma non_sym_dist_pairs'_elems_distinct:
   assumes "distinct xs"
   and     "(x,y) \<in> set (non_sym_dist_pairs' xs)"
 shows "x \<in> set xs" 
 and   "y \<in> set xs"
 and   "x \<noteq> y"
 proof -
   show "x \<in> set xs" and "y \<in> set xs"
     using non_sym_dist_pairs_subset assms(2) by (induction xs; auto)+
   show "x \<noteq> y"
     using assms by (induction xs; auto)
 qed
 
 lemma non_sym_dist_pairs_elems_distinct:
   assumes "(x,y) \<in> set (non_sym_dist_pairs xs)"
 shows "x \<in> set xs" 
 and   "y \<in> set xs"
 and   "x \<noteq> y"
   using non_sym_dist_pairs'_elems_distinct assms
   unfolding non_sym_dist_pairs.simps by fastforce+
 
 
 lemma non_sym_dist_pairs_elems :
   assumes "x \<in> set xs"
   and     "y \<in> set xs"
   and     "x \<noteq> y"
 shows "(x,y) \<in> set (non_sym_dist_pairs xs) \<or> (y,x) \<in> set (non_sym_dist_pairs xs)"
   using assms by (induction xs; auto)
 
 
 
 lemma non_sym_dist_pairs'_elems_non_refl :
   assumes "distinct xs"
   and     "(x,y) \<in> set (non_sym_dist_pairs' xs)"
 shows "(y,x) \<notin> set (non_sym_dist_pairs' xs)"
   using assms  
 proof (induction xs arbitrary: x y)
   case Nil
   then show ?case by auto
 next
   case (Cons z zs)
   then have "distinct zs" by auto
 
   have "x \<noteq> y"
     using non_sym_dist_pairs'_elems_distinct[OF Cons.prems] by simp
 
   consider (a) "(x,y) \<in> set (map (Pair z) zs)" |
            (b) "(x,y) \<in> set (non_sym_dist_pairs' zs)"
     using \<open>(x,y) \<in> set (non_sym_dist_pairs' (z#zs))\<close> unfolding non_sym_dist_pairs'.simps by auto
   then show ?case proof cases
     case a
     then have "x = z" by auto
     then have "(y,x) \<notin> set (map (Pair z) zs)"
       using \<open>x \<noteq> y\<close> by auto
     moreover have "x \<notin> set zs"
       using \<open>x = z\<close> \<open>distinct (z#zs)\<close> by auto
     ultimately show ?thesis 
       using \<open>distinct zs\<close> non_sym_dist_pairs'_elems_distinct(2) by fastforce
   next
     case b
     then have "x \<noteq> z" and "y \<noteq> z"
       using Cons.prems unfolding non_sym_dist_pairs'.simps 
       by (meson distinct.simps(2) non_sym_dist_pairs'_elems_distinct(1,2))+
     
     then show ?thesis 
       using Cons.IH[OF \<open>distinct zs\<close> b] by auto
   qed
 qed
 
 
 lemma non_sym_dist_pairs_elems_non_refl :
   assumes "(x,y) \<in> set (non_sym_dist_pairs xs)"
   shows "(y,x) \<notin> set (non_sym_dist_pairs xs)"
   using assms by (simp add: non_sym_dist_pairs'_elems_non_refl)
 
 
 lemma non_sym_dist_pairs_set_iff :
   "(x,y) \<in> set (non_sym_dist_pairs xs) 
     \<longleftrightarrow> (x \<noteq> y \<and> x \<in> set xs \<and> y \<in> set xs \<and> (y,x) \<notin> set (non_sym_dist_pairs xs))"
   using non_sym_dist_pairs_elems_non_refl[of x y xs] 
         non_sym_dist_pairs_elems[of x xs y] 
         non_sym_dist_pairs_elems_distinct[of x y xs] by blast 
 
 
 
 subsection \<open>Finite Linear Order From List Positions\<close>
 
 fun linear_order_from_list_position' :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "linear_order_from_list_position' [] = []" |
   "linear_order_from_list_position' (x#xs) 
       = (x,x) # (map (\<lambda> y . (x,y)) xs) @ (linear_order_from_list_position' xs)"
 
 fun linear_order_from_list_position :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "linear_order_from_list_position xs = linear_order_from_list_position' (remdups xs)"
 
 
 
 lemma linear_order_from_list_position_set :
   "set (linear_order_from_list_position xs) 
     = (set (map (\<lambda> x . (x,x)) xs)) \<union> set (non_sym_dist_pairs xs)"
   by (induction xs; auto)
 
 lemma linear_order_from_list_position_total: 
   "total_on (set xs) (set (linear_order_from_list_position xs))"
   unfolding linear_order_from_list_position_set
   using non_sym_dist_pairs_elems[of _ xs]
   by (meson UnI2 total_onI)
 
 lemma linear_order_from_list_position_refl: 
   "refl_on (set xs) (set (linear_order_from_list_position xs))"  
 proof 
   show "set (linear_order_from_list_position xs) \<subseteq> set xs \<times> set xs"
     unfolding linear_order_from_list_position_set
     using non_sym_dist_pairs_subset[of xs] by auto
   show "\<And>x. x \<in> set xs \<Longrightarrow> (x, x) \<in> set (linear_order_from_list_position xs)"
     unfolding linear_order_from_list_position_set
     using non_sym_dist_pairs_subset[of xs] by auto
 qed
 
 lemma linear_order_from_list_position_antisym: 
   "antisym (set (linear_order_from_list_position xs))"
 proof 
   fix x y assume "(x, y) \<in> set (linear_order_from_list_position xs)" 
           and    "(y, x) \<in> set (linear_order_from_list_position xs)"
   then have "(x, y) \<in> set (map (\<lambda>x. (x, x)) xs) \<union> set (non_sym_dist_pairs xs)"
        and  "(y, x) \<in> set (map (\<lambda>x. (x, x)) xs) \<union> set (non_sym_dist_pairs xs)"
     unfolding linear_order_from_list_position_set by blast+
   then consider (a) "(x, y) \<in> set (map (\<lambda>x. (x, x)) xs)" |
                 (b) "(x, y) \<in> set (non_sym_dist_pairs xs)"
     by blast
   then show "x = y"
   proof cases
     case a
     then show ?thesis by auto
   next
     case b
     then have "x \<noteq> y" and "(y,x) \<notin> set (non_sym_dist_pairs xs)"
       using non_sym_dist_pairs_set_iff[of x y xs] by simp+
     then have "(y, x) \<notin> set (map (\<lambda>x. (x, x)) xs) \<union> set (non_sym_dist_pairs xs)"
       by auto
     then show ?thesis 
      using \<open>(y, x) \<in> set (map (\<lambda>x. (x, x)) xs) \<union> set (non_sym_dist_pairs xs)\<close> by blast
   qed
 qed
 
 
 lemma non_sym_dist_pairs'_indices : 
   "distinct xs \<Longrightarrow> (x,y) \<in> set (non_sym_dist_pairs' xs) 
    \<Longrightarrow> (\<exists> i j . xs ! i = x \<and> xs ! j = y \<and> i < j \<and> i < length xs \<and> j < length xs)"
 proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
   show ?case proof (cases "a = x")
     case True
     then have "(a#xs) ! 0 = x" and "0 < length (a#xs)"
       by auto
     
     have "y \<in> set xs"
       using non_sym_dist_pairs'_elems_distinct(2,3)[OF Cons.prems(1,2)] True by auto
     then obtain j where "xs ! j = y" and "j < length xs"
       by (meson in_set_conv_nth)
     then have "(a#xs) ! (Suc j) = y" and "Suc j < length (a#xs)"
       by auto
 
     then show ?thesis 
       using \<open>(a#xs) ! 0 = x\<close> \<open>0 < length (a#xs)\<close> by blast
   next
     case False
     then have "(x,y) \<in> set (non_sym_dist_pairs' xs)"
       using Cons.prems(2) by auto
     then show ?thesis 
       using Cons.IH Cons.prems(1)
       by (metis Suc_mono distinct.simps(2) length_Cons nth_Cons_Suc)
   qed
 qed
 
 
 
 lemma non_sym_dist_pairs'_trans: "distinct xs \<Longrightarrow> trans (set (non_sym_dist_pairs' xs))"
 proof 
   fix x y z assume "distinct xs" 
             and    "(x, y) \<in> set (non_sym_dist_pairs' xs)" 
             and    "(y, z) \<in> set (non_sym_dist_pairs' xs)"
 
   obtain nx ny where "xs ! nx = x" and "xs ! ny = y" and "nx < ny" 
                  and "nx < length xs" and "ny < length xs"
     using non_sym_dist_pairs'_indices[OF \<open>distinct xs\<close> \<open>(x, y) \<in> set (non_sym_dist_pairs' xs)\<close>] 
     by blast
 
   obtain ny' nz where "xs ! ny' = y" and "xs ! nz = z" and "ny'< nz" 
                   and "ny' < length xs" and "nz < length xs"
     using non_sym_dist_pairs'_indices[OF \<open>distinct xs\<close> \<open>(y, z) \<in> set (non_sym_dist_pairs' xs)\<close>] 
     by blast
 
   have "ny' = ny"
     using \<open>distinct xs\<close> \<open>xs ! ny = y\<close> \<open>xs ! ny' = y\<close> \<open>ny < length xs\<close> \<open>ny' < length xs\<close> 
           nth_eq_iff_index_eq 
     by metis
   then have "nx < nz"
     using \<open>nx < ny\<close> \<open>ny' < nz\<close> by auto
 
   then have "nx \<noteq> nz" by simp
   then have "x \<noteq> z"
     using \<open>distinct xs\<close> \<open>xs ! nx = x\<close> \<open>xs ! nz = z\<close> \<open>nx < length xs\<close> \<open>nz < length xs\<close> 
           nth_eq_iff_index_eq 
     by metis
 
   have "remdups xs = xs"
     using \<open>distinct xs\<close> by auto
 
   have "\<not>(z, x) \<in> set (non_sym_dist_pairs' xs)"
   proof 
     assume "(z, x) \<in> set (non_sym_dist_pairs' xs)"
     then obtain nz' nx' where "xs ! nx' = x" and "xs ! nz' = z" and "nz'< nx'" 
                           and "nx' < length xs" and "nz' < length xs"
       using non_sym_dist_pairs'_indices[OF \<open>distinct xs\<close>, of z x] by metis
 
     have "nx' = nx"
       using \<open>distinct xs\<close> \<open>xs ! nx = x\<close> \<open>xs ! nx' = x\<close> \<open>nx < length xs\<close> \<open>nx' < length xs\<close> 
             nth_eq_iff_index_eq 
       by metis
     moreover have "nz' = nz"
       using \<open>distinct xs\<close> \<open>xs ! nz = z\<close> \<open>xs ! nz' = z\<close> \<open>nz < length xs\<close> \<open>nz' < length xs\<close> 
             nth_eq_iff_index_eq 
       by metis
     ultimately have "nz < nx"
       using \<open>nz'< nx'\<close> by auto
     then show "False"
       using \<open>nx < nz\<close> by simp    
   qed
   then show "(x, z) \<in> set (non_sym_dist_pairs' xs)" 
     using non_sym_dist_pairs'_elems_distinct(1)[OF \<open>distinct xs\<close> \<open>(x, y) \<in> set (non_sym_dist_pairs' xs)\<close>]
           non_sym_dist_pairs'_elems_distinct(2)[OF \<open>distinct xs\<close> \<open>(y, z) \<in> set (non_sym_dist_pairs' xs)\<close>]
           \<open>x \<noteq> z\<close>
           non_sym_dist_pairs_elems[of x xs z]
     unfolding non_sym_dist_pairs.simps \<open>remdups xs = xs\<close> 
     by blast
 qed
 
 
 lemma non_sym_dist_pairs_trans: "trans (set (non_sym_dist_pairs xs))"
   using non_sym_dist_pairs'_trans[of "remdups xs", OF distinct_remdups] 
   unfolding non_sym_dist_pairs.simps 
   by assumption
 
 
 
 lemma linear_order_from_list_position_trans: "trans (set (linear_order_from_list_position xs))"
 proof 
   fix x y z assume "(x, y) \<in> set (linear_order_from_list_position xs)" 
                and "(y, z) \<in> set (linear_order_from_list_position xs)"
   then consider (a) "(x, y) \<in> set (map (\<lambda>x. (x, x)) xs) \<and> (y, z) \<in> set (map (\<lambda>x. (x, x)) xs)" |
                 (b) "(x, y) \<in> set (map (\<lambda>x. (x, x)) xs) \<and> (y, z) \<in> set (non_sym_dist_pairs xs)" |
                 (c) "(x, y) \<in> set (non_sym_dist_pairs xs) \<and> (y, z) \<in> set (map (\<lambda>x. (x, x)) xs)" |
                 (d) "(x, y) \<in> set (non_sym_dist_pairs xs) \<and> (y, z) \<in> set (non_sym_dist_pairs xs)"
     unfolding linear_order_from_list_position_set by blast+
   then show "(x, z) \<in> set (linear_order_from_list_position xs)"
   proof cases
     case a
     then show ?thesis unfolding linear_order_from_list_position_set by auto
   next
     case b
     then show ?thesis unfolding linear_order_from_list_position_set by auto
   next
     case c
     then show ?thesis unfolding linear_order_from_list_position_set by auto
   next
     case d
     then show ?thesis unfolding linear_order_from_list_position_set 
                       using non_sym_dist_pairs_trans 
                       by (metis UnI2 transE)
   qed
 qed
 
 
 
 subsection \<open>Find And Remove in a Single Pass\<close>
 
 fun find_remove' :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ('a \<times> 'a list) option" where
   "find_remove' P [] _ = None" |
   "find_remove' P (x#xs) prev = (if P x
       then Some (x,prev@xs) 
       else find_remove' P xs (prev@[x]))"
 
 fun find_remove :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a \<times> 'a list) option" where
   "find_remove P xs = find_remove' P xs []"
 
 lemma find_remove'_set : 
   assumes "find_remove' P xs prev = Some (x,xs')"
 shows "P x"
 and   "x \<in> set xs"
 and   "xs' = prev@(remove1 x xs)"
 proof -
   have "P x \<and> x \<in> set xs \<and> xs' = prev@(remove1 x xs)"
     using assms proof (induction xs arbitrary: prev xs')
     case Nil
     then show ?case by auto
   next
     case (Cons x xs)
     show ?case proof (cases "P x")
       case True
       then show ?thesis using Cons by auto
     next
       case False
       then show ?thesis using Cons by fastforce 
     qed
   qed
   then show "P x"
       and   "x \<in> set xs"
       and   "xs' = prev@(remove1 x xs)"
     by blast+
 qed
 
 lemma find_remove'_set_rev :
   assumes "x \<in> set xs"
   and     "P x"
 shows "find_remove' P xs prev \<noteq> None" 
 using assms(1) proof(induction xs arbitrary: prev)
   case Nil
   then show ?case by auto
 next
   case (Cons x' xs)
   show ?case proof (cases "P x")
     case True
     then show ?thesis using Cons by auto
   next
     case False
     then show ?thesis using Cons
       using assms(2) by auto 
   qed
 qed
 
 
 lemma find_remove_None_iff :
   "find_remove P xs = None \<longleftrightarrow> \<not> (\<exists>x . x \<in> set xs \<and> P x)"
   unfolding find_remove.simps 
   using find_remove'_set(1,2) 
         find_remove'_set_rev
   by (metis old.prod.exhaust option.exhaust)
 
 lemma find_remove_set : 
   assumes "find_remove P xs = Some (x,xs')"
 shows "P x"
 and   "x \<in> set xs"
 and   "xs' = (remove1 x xs)"
   using assms find_remove'_set[of P xs "[]" x xs'] by auto
 
 
 
 
 fun find_remove_2' :: "('a\<Rightarrow>'b\<Rightarrow>bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a list \<Rightarrow> ('a \<times> 'b \<times> 'a list) option" 
   where
   "find_remove_2' P [] _ _ = None" |
   "find_remove_2' P (x#xs) ys prev = (case find (\<lambda>y . P x y) ys of
       Some y \<Rightarrow> Some (x,y,prev@xs) |
       None   \<Rightarrow> find_remove_2' P xs ys (prev@[x]))"
 
 fun find_remove_2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b \<times> 'a list) option" where
   "find_remove_2 P xs ys = find_remove_2' P xs ys []"
 
 
 lemma find_remove_2'_set : 
   assumes "find_remove_2' P xs ys prev = Some (x,y,xs')"
 shows "P x y"
 and   "x \<in> set xs"
 and   "y \<in> set ys"
 and   "distinct (prev@xs) \<Longrightarrow> set xs' = (set prev \<union> set xs) - {x}"
 and   "distinct (prev@xs) \<Longrightarrow> distinct xs'"
 and   "xs' = prev@(remove1 x xs)"
 and   "find (P x) ys = Some y"
 proof -
   have "P x y 
         \<and> x \<in> set xs 
         \<and> y \<in> set ys 
         \<and> (distinct (prev@xs) \<longrightarrow> set xs' = (set prev \<union> set xs) - {x}) 
         \<and> (distinct (prev@xs) \<longrightarrow> distinct xs') 
         \<and> (xs' = prev@(remove1 x xs)) 
         \<and> find (P x) ys = Some y"
     using assms 
   proof (induction xs arbitrary: prev xs' x y)
     case Nil
     then show ?case by auto 
   next
     case (Cons x' xs)
     then show ?case proof (cases "find (\<lambda>y . P x' y) ys")
       case None
       then have "find_remove_2' P (x' # xs) ys prev = find_remove_2' P xs ys (prev@[x'])"
         using Cons.prems(1) by auto
       hence *: "find_remove_2' P xs ys (prev@[x']) = Some (x, y, xs')"
         using Cons.prems(1) by simp
       
       have "x' \<noteq> x"
         by (metis "*" Cons.IH None find_from)
       moreover have "distinct (prev @ x' # xs) \<longrightarrow> distinct ((x' # prev) @ xs)"
         by auto
       ultimately show ?thesis using Cons.IH[OF *]
         by auto
     next
       case (Some y')
       then have "find_remove_2' P (x' # xs) ys prev = Some (x',y',prev@xs)"
         by auto
       then show ?thesis using Some
         using Cons.prems(1) find_condition find_set by fastforce 
     qed
   qed
   then show "P x y"
       and   "x \<in> set xs"
       and   "y \<in> set ys"
       and   "distinct (prev @ xs) \<Longrightarrow> set xs' = (set prev \<union> set xs) - {x}"
       and   "distinct (prev@xs) \<Longrightarrow> distinct xs'"
       and   "xs' = prev@(remove1 x xs)"
       and   "find (P x) ys = Some y"
     by blast+
 qed
 
 
 
 lemma find_remove_2'_strengthening : 
   assumes "find_remove_2' P xs ys prev = Some (x,y,xs')"
   and     "P' x y"
   and     "\<And> x' y' . P' x' y' \<Longrightarrow> P x' y'"
 shows "find_remove_2' P' xs ys prev = Some (x,y,xs')"
   using assms proof (induction xs arbitrary: prev)
   case Nil
   then show ?case by auto
 next
   case (Cons x' xs)
   then show ?case proof (cases "find (\<lambda>y . P x' y) ys")
     case None
     then show ?thesis using Cons
       by (metis (mono_tags, lifting) find_None_iff find_remove_2'.simps(2) option.simps(4))  
   next
     case (Some a)
     then have "x' = x" and "a = y"
       using Cons.prems(1) unfolding find_remove_2'.simps by auto
     then have "find (\<lambda>y . P x y) ys = Some y"
       using find_remove_2'_set[OF Cons.prems(1)] by auto
     then have "find (\<lambda>y . P' x y) ys = Some y"
       using Cons.prems(3) proof (induction ys)
       case Nil
       then show ?case by auto
     next
       case (Cons y' ys)
       then show ?case
         by (metis assms(2) find.simps(2) option.inject) 
     qed
       
     then show ?thesis  
       using find_remove_2'_set(6)[OF Cons.prems(1)]
       unfolding \<open>x' = x\<close> find_remove_2'.simps by auto      
   qed
 qed
 
 lemma find_remove_2_strengthening : 
   assumes "find_remove_2 P xs ys = Some (x,y,xs')"
   and     "P' x y"
   and     "\<And> x' y' . P' x' y' \<Longrightarrow> P x' y'"
 shows "find_remove_2 P' xs ys = Some (x,y,xs')"
   using assms find_remove_2'_strengthening
   by (metis find_remove_2.simps) 
 
 
 
 lemma find_remove_2'_prev_independence :
   assumes "find_remove_2' P xs ys prev = Some (x,y,xs')"
   shows "\<exists> xs'' . find_remove_2' P xs ys prev' = Some (x,y,xs'')" 
   using assms proof (induction xs arbitrary: prev prev' xs')
   case Nil
   then show ?case by auto
 next
   case (Cons x' xs)
   show ?case proof (cases "find (\<lambda>y . P x' y) ys")
     case None
     then show ?thesis
       using Cons.IH Cons.prems by auto
       
   next
     case (Some a)
     then show ?thesis using Cons.prems unfolding find_remove_2'.simps
       by simp 
   qed
 qed
 
 
 lemma find_remove_2'_filter :
   assumes "find_remove_2' P (filter P' xs) ys prev = Some (x,y,xs')"
   and     "\<And> x y . \<not> P' x \<Longrightarrow> \<not> P x y"
 shows "\<exists> xs'' . find_remove_2' P xs ys prev = Some (x,y,xs'')"
   using assms(1) proof (induction xs arbitrary: prev prev xs')
   case Nil
   then show ?case by auto
 next
   case (Cons x' xs)
   then show ?case proof (cases "P' x'")
     case True
     then have *:"find_remove_2' P (filter P' (x' # xs)) ys prev 
                 = find_remove_2' P (x' # filter P' xs) ys prev" 
       by auto
       
     show ?thesis proof (cases "find (\<lambda>y . P x' y) ys")
       case None
       then show ?thesis
         by (metis Cons.IH Cons.prems  find_remove_2'.simps(2) option.simps(4) *)
     next
       case (Some a) 
       then have "x' = x" and "a = y"
         using Cons.prems
         unfolding * find_remove_2'.simps by auto
         
       show ?thesis 
         using Some 
         unfolding \<open>x' = x\<close> \<open>a = y\<close> find_remove_2'.simps
         by simp
     qed
   next
     case False
     then have "find_remove_2' P (filter P' xs) ys prev = Some (x,y,xs')"
       using Cons.prems by auto
 
     from False assms(2) have "find (\<lambda>y . P x' y) ys = None"
       by (simp add: find_None_iff)
     then have "find_remove_2' P (x'#xs) ys prev = find_remove_2' P xs ys (prev@[x'])"
       by auto
     
     show ?thesis 
       using Cons.IH[OF \<open>find_remove_2' P (filter P' xs) ys prev = Some (x,y,xs')\<close>] 
       unfolding \<open>find_remove_2' P (x'#xs) ys prev = find_remove_2' P xs ys (prev@[x'])\<close>
       using find_remove_2'_prev_independence by metis
   qed
 qed
 
 
 lemma find_remove_2_filter :
   assumes "find_remove_2 P (filter P' xs) ys = Some (x,y,xs')"
   and     "\<And> x y . \<not> P' x \<Longrightarrow> \<not> P x y"
 shows "\<exists> xs'' . find_remove_2 P xs ys = Some (x,y,xs'')"
   using assms by (simp add: find_remove_2'_filter)  
 
 
 lemma find_remove_2'_index : 
   assumes "find_remove_2' P xs ys prev = Some (x,y,xs')"
   obtains i i' where "i < length xs" 
                      "xs ! i = x"
                      "\<And> j . j < i \<Longrightarrow> find (\<lambda>y . P (xs ! j) y) ys = None"
                      "i' < length ys"
                      "ys ! i' = y"
                      "\<And> j . j < i' \<Longrightarrow> \<not> P (xs ! i) (ys ! j)"
 proof -
   have "\<exists> i i' . i < length xs 
                   \<and> xs ! i = x 
                   \<and> (\<forall> j < i . find (\<lambda>y . P (xs ! j) y) ys = None) 
                   \<and> i' < length ys \<and> ys ! i' = y 
                   \<and> (\<forall> j < i' . \<not> P (xs ! i) (ys ! j))"
     using assms 
   proof (induction xs arbitrary: prev xs' x y)
     case Nil
     then show ?case by auto 
   next
     case (Cons x' xs)
     then show ?case proof (cases "find (\<lambda>y . P x' y) ys")
       case None
       then have "find_remove_2' P (x' # xs) ys prev = find_remove_2' P xs ys (prev@[x'])"
         using Cons.prems(1) by auto
       hence *: "find_remove_2' P xs ys (prev@[x']) = Some (x, y, xs')"
         using Cons.prems(1) by simp
       
       have "x' \<noteq> x"
         using find_remove_2'_set(1,3)[OF *] None unfolding find_None_iff
         by blast
 
       obtain i i' where "i < length xs" and "xs ! i = x" 
                     and "(\<forall> j < i . find (\<lambda>y . P (xs ! j) y) ys = None)" and "i' < length ys" 
                     and "ys ! i' = y" and "(\<forall> j < i' . \<not> P (xs ! i) (ys ! j))"
         using Cons.IH[OF *] by blast
 
       have "Suc i < length (x'#xs)"
         using \<open>i < length xs\<close> by auto
       moreover have "(x'#xs) ! Suc i = x"
         using \<open>xs ! i = x\<close> by auto
       moreover have "(\<forall> j < Suc i . find (\<lambda>y . P ((x'#xs) ! j) y) ys = None)"
       proof -
         have "\<And> j . j > 0 \<Longrightarrow> j < Suc i \<Longrightarrow> find (\<lambda>y . P ((x'#xs) ! j) y) ys = None"
           using \<open>(\<forall> j < i . find (\<lambda>y . P (xs ! j) y) ys = None)\<close> by auto 
         then show ?thesis using None
           by (metis neq0_conv nth_Cons_0) 
       qed
       moreover have "(\<forall> j < i' . \<not> P ((x'#xs) ! Suc i) (ys ! j))"
         using \<open>(\<forall> j < i' . \<not> P (xs ! i) (ys ! j))\<close>
         by simp 
       
       ultimately show ?thesis 
         using that \<open>i' < length ys\<close> \<open>ys ! i' = y\<close> by blast
     next
       case (Some y')
       then have "x' = x" and "y' = y"
         using Cons.prems by force+
       
       have "0 < length (x'#xs) \<and> (x'#xs) ! 0 = x' 
             \<and> (\<forall> j < 0 . find (\<lambda>y . P ((x'#xs) ! j) y) ys = None)" 
         by auto
       moreover obtain i' where "i' < length ys" and "ys ! i' = y'" 
                            and "(\<forall> j < i' . \<not> P ((x'#xs) ! 0) (ys ! j))" 
         using find_sort_index[OF Some] by auto
       ultimately show ?thesis 
         unfolding \<open>x' = x\<close> \<open>y' = y\<close> by blast
     qed
   qed
   then show ?thesis using that by blast
 qed
 
 lemma find_remove_2_index : 
   assumes "find_remove_2 P xs ys = Some (x,y,xs')"
   obtains i i' where "i < length xs" 
                      "xs ! i = x"
                      "\<And> j . j < i \<Longrightarrow> find (\<lambda>y . P (xs ! j) y) ys = None"
                      "i' < length ys"
                      "ys ! i' = y"
                      "\<And> j . j < i' \<Longrightarrow> \<not> P (xs ! i) (ys ! j)"
   using assms find_remove_2'_index[of P xs ys "[]" x y xs'] by auto
 
 
 lemma find_remove_2'_set_rev :
   assumes "x \<in> set xs"
   and     "y \<in> set ys"
   and     "P x y"
 shows "find_remove_2' P xs ys prev \<noteq> None" 
 using assms(1) proof(induction xs arbitrary: prev)
   case Nil
   then show ?case by auto
 next
   case (Cons x' xs)
   then show ?case proof (cases "find (\<lambda>y . P x' y) ys")
     case None
     then have "x \<noteq> x'" 
       using assms(2,3) by (metis find_None_iff) 
     then have "x \<in> set xs"
       using Cons.prems by auto
     then show ?thesis 
       using Cons.IH unfolding find_remove_2'.simps None by auto
   next
     case (Some a)
     then show ?thesis by auto
   qed
 qed
 
 
 lemma find_remove_2'_diff_prev_None :
   "(find_remove_2' P xs ys prev = None \<Longrightarrow> find_remove_2' P xs ys prev' = None)" 
 proof (induction xs arbitrary: prev prev')
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   show ?case proof (cases "find (\<lambda>y . P x y) ys")
     case None
     then have "find_remove_2' P (x#xs) ys prev = find_remove_2' P xs ys (prev@[x])" 
          and  "find_remove_2' P (x#xs) ys prev' = find_remove_2' P xs ys (prev'@[x])"
       by auto
     then show ?thesis using Cons by auto 
   next
     case (Some a)
     then show ?thesis using Cons by auto
   qed
 qed
 
 lemma find_remove_2'_diff_prev_Some :
   "(find_remove_2' P xs ys prev = Some (x,y,xs') 
     \<Longrightarrow> \<exists> xs'' . find_remove_2' P xs ys prev' = Some (x,y,xs''))" 
 proof (induction xs arbitrary: prev prev')
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   show ?case proof (cases "find (\<lambda>y . P x y) ys")
     case None
     then have "find_remove_2' P (x#xs) ys prev = find_remove_2' P xs ys (prev@[x])" 
          and  "find_remove_2' P (x#xs) ys prev' = find_remove_2' P xs ys (prev'@[x])"
       by auto
     then show ?thesis using Cons by auto 
   next
     case (Some a)
     then show ?thesis using Cons by auto
   qed
 qed
 
 
 lemma find_remove_2_None_iff :
   "find_remove_2 P xs ys = None \<longleftrightarrow> \<not> (\<exists>x y . x \<in> set xs \<and> y \<in> set ys \<and> P x y)"
   unfolding find_remove_2.simps 
   using find_remove_2'_set(1-3) find_remove_2'_set_rev
   by (metis old.prod.exhaust option.exhaust)
 
 lemma find_remove_2_set : 
   assumes "find_remove_2 P xs ys = Some (x,y,xs')"
 shows "P x y"
 and   "x \<in> set xs"
 and   "y \<in> set ys"
 and   "distinct xs \<Longrightarrow> set xs' = (set xs) - {x}"
 and   "distinct xs \<Longrightarrow> distinct xs'"
 and   "xs' = (remove1 x xs)"
   using assms find_remove_2'_set[of P xs ys "[]" x y xs'] 
   unfolding find_remove_2.simps by auto
 
 lemma find_remove_2_removeAll :
   assumes "find_remove_2 P xs ys = Some (x,y,xs')"
   and     "distinct xs"
 shows "xs' = removeAll x xs"
   using find_remove_2_set(6)[OF assms(1)]
   by (simp add: assms(2) distinct_remove1_removeAll) 
 
 lemma find_remove_2_length :
   assumes "find_remove_2 P xs ys = Some (x,y,xs')"
   shows "length xs' = length xs - 1"
   using find_remove_2_set(2,6)[OF assms]
   by (simp add: length_remove1) 
 
 
 
 fun separate_by :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
   "separate_by P xs = (filter P xs, filter (\<lambda> x . \<not> P x) xs)"
 
 lemma separate_by_code[code] :
   "separate_by P xs = foldr (\<lambda>x (prevPass,prevFail) . if P x then (x#prevPass,prevFail) else (prevPass,x#prevFail)) xs ([],[])"
 proof (induction xs)
   case Nil
   then show ?case by auto
 next
   case (Cons a xs)
 
   let ?f = "(\<lambda>x (prevPass,prevFail) . if P x then (x#prevPass,prevFail) else (prevPass,x#prevFail))"
 
   have "(filter P xs, filter (\<lambda> x . \<not> P x) xs) = foldr ?f xs ([],[])"
     using Cons.IH by auto
   moreover have "separate_by P (a#xs) = ?f a (filter P xs, filter (\<lambda> x . \<not> P x) xs)"
     by auto
   ultimately show ?case 
     by (cases "P a"; auto)
 qed
 
 fun find_remove_2_all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> (('a \<times> 'b) list \<times> 'a list)" where
   "find_remove_2_all P xs ys =
     (map (\<lambda> x . (x, the (find (\<lambda>y . P x y) ys))) (filter (\<lambda> x . find (\<lambda>y . P x y) ys \<noteq> None) xs)
     ,filter (\<lambda> x . find (\<lambda>y . P x y) ys = None) xs)"
 
 
 fun find_remove_2_all' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> (('a \<times> 'b) list \<times> 'a list)" where
   "find_remove_2_all' P xs ys = 
     (let (successesWithWitnesses,failures) = separate_by (\<lambda>(x,y) . y \<noteq> None) (map (\<lambda> x . (x,find (\<lambda>y . P x y) ys)) xs)
     in (map (\<lambda> (x,y) . (x, the y)) successesWithWitnesses, map fst failures))"
 
 lemma find_remove_2_all_code[code] :
   "find_remove_2_all P xs ys = find_remove_2_all' P xs ys"
 proof -
   let ?s1 = "map (\<lambda> x . (x, the (find (\<lambda>y . P x y) ys))) (filter (\<lambda> x . find (\<lambda>y . P x y) ys \<noteq> None) xs)"
   let ?f1 = "filter (\<lambda> x . find (\<lambda>y . P x y) ys = None) xs"
 
   let ?s2 = "map (\<lambda> (x,y) . (x, the y)) (filter (\<lambda>(x,y) . y \<noteq> None) (map (\<lambda> x . (x,find (\<lambda>y . P x y) ys)) xs))"
   let ?f2 = "map fst (filter (\<lambda>(x,y) . y = None) (map (\<lambda> x . (x,find (\<lambda>y . P x y) ys)) xs))"
 
   have "find_remove_2_all P xs ys = (?s1,?f1)" 
     by simp
   moreover have "find_remove_2_all' P xs ys = (?s2,?f2)" 
   proof -
     have "\<forall>p. (\<lambda>pa. \<not> (case pa of (a::'a, x::'b option) \<Rightarrow> p x)) = (\<lambda>(a, z). \<not> p z)"
       by force
     then show ?thesis
       unfolding find_remove_2_all'.simps Let_def separate_by.simps  
       by force
   qed
   moreover have "?s1 = ?s2" 
     by (induction xs; auto)
   moreover have "?f1 = ?f2" 
     by (induction xs; auto)
   ultimately show ?thesis 
     by simp
 qed
    
 
 
 
 
 
 
 subsection \<open>Set-Operations on Lists\<close>
 
 fun pow_list :: "'a list \<Rightarrow> 'a list list" where
   "pow_list [] = [[]]" |
   "pow_list (x#xs) = (let pxs = pow_list xs in pxs @ map (\<lambda> ys . x#ys) pxs)"
 
 
 lemma pow_list_set :
   "set (map set (pow_list xs)) = Pow (set xs)"
 proof (induction xs)
 case Nil
   then show ?case by auto
 next
   case (Cons x xs)
 
   moreover have "Pow (set (x # xs)) = Pow (set xs) \<union> (image (insert x) (Pow (set xs)))"
     by (simp add: Pow_insert)
     
   moreover have "set (map set (pow_list (x#xs))) 
                   = set (map set (pow_list xs)) \<union> (image (insert x) (set (map set (pow_list xs))))"
   proof -
     have "\<And> ys . ys \<in> set (map set (pow_list (x#xs))) 
             \<Longrightarrow> ys \<in> set (map set (pow_list xs)) \<union> (image (insert x) (set (map set (pow_list xs))))" 
     proof -
       fix ys assume "ys \<in> set (map set (pow_list (x#xs)))"
       then consider (a) "ys \<in> set (map set (pow_list xs))" |
                     (b) "ys \<in> set (map set (map ((#) x) (pow_list xs)))"
         unfolding pow_list.simps Let_def by auto
       then show "ys \<in> set (map set (pow_list xs)) \<union> (image (insert x) (set (map set (pow_list xs))))" 
         by (cases; auto)
     qed
     moreover have "\<And> ys . ys \<in> set (map set (pow_list xs)) 
                             \<union> (image (insert x) (set (map set (pow_list xs)))) 
                     \<Longrightarrow> ys \<in> set (map set (pow_list (x#xs)))"
     proof -
       fix ys assume "ys \<in> set (map set (pow_list xs)) 
                             \<union> (image (insert x) (set (map set (pow_list xs))))"
       then consider (a) "ys \<in> set (map set (pow_list xs))" |
                     (b) "ys \<in> (image (insert x) (set (map set (pow_list xs))))"
         by blast
       then show "ys \<in> set (map set (pow_list (x#xs)))" 
         unfolding pow_list.simps Let_def by (cases; auto)
     qed
     ultimately show ?thesis by blast
   qed
     
   ultimately show ?case
     by auto 
 qed
 
 
 fun inter_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "inter_list xs ys = filter (\<lambda> x . x \<in> set ys) xs"
 
 lemma inter_list_set : "set (inter_list xs ys) = (set xs) \<inter> (set ys)"
   by auto
 
 fun subset_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "subset_list xs ys = list_all (\<lambda> x . x \<in> set ys) xs"
 
 lemma subset_list_set : "subset_list xs ys = ((set xs) \<subseteq> (set ys))" 
   unfolding subset_list.simps
   by (simp add: Ball_set subset_code(1)) 
 
 
 subsubsection \<open>Removing Subsets in a List of Sets\<close>
 
 lemma remove1_length : "x \<in> set xs \<Longrightarrow> length (remove1 x xs) < length xs" 
   by (induction xs; auto)
 
 
 function remove_subsets :: "'a set list \<Rightarrow> 'a set list" where
   "remove_subsets [] = []" |
   "remove_subsets (x#xs) = (case find_remove (\<lambda> y . x \<subset> y) xs of
     Some (y',xs') \<Rightarrow> remove_subsets (y'# (filter (\<lambda> y . \<not>(y \<subseteq> x)) xs')) |
     None          \<Rightarrow> x # (remove_subsets (filter (\<lambda> y . \<not>(y \<subseteq> x)) xs)))"
   by pat_completeness auto
 termination   
 proof -
   have "\<And>x xs. find_remove ((\<subset>) x) xs = None \<Longrightarrow> (filter (\<lambda>y. \<not> y \<subseteq> x) xs, x # xs) \<in> measure length"
     by (metis dual_order.trans impossible_Cons in_measure length_filter_le not_le_imp_less)
   moreover have "(\<And>(x :: 'a set) xs x2 xa y. find_remove ((\<subset>) x) xs = Some x2 \<Longrightarrow> (xa, y) = x2 \<Longrightarrow> (xa # filter (\<lambda>y. \<not> y \<subseteq> x) y, x # xs) \<in> measure length)"
   proof -
     fix x :: "'a set"
     fix xs y'xs' y' xs'    
     assume "find_remove ((\<subset>) x) xs = Some y'xs'" and "(y', xs') = y'xs'"
     then have "find_remove ((\<subset>) x) xs = Some (y',xs')"
       by auto
 
     have "length xs' = length xs - 1"
       using find_remove_set(2,3)[OF \<open>find_remove ((\<subset>) x) xs = Some (y',xs')\<close>]
       by (simp add: length_remove1) 
     then have "length (y'#xs') = length xs"
       using find_remove_set(2)[OF \<open>find_remove ((\<subset>) x) xs = Some (y',xs')\<close>]
       using remove1_length by fastforce 
     
     have "length (filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xs'"
       by simp
     then have "length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xs' + 1"
       by simp
     then have "length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xs" 
       unfolding \<open>length (y'#xs') = length xs\<close>[symmetric] by simp
     then show "(y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs', x # xs) \<in> measure length"
       by auto 
   qed
   ultimately show ?thesis
     by (relation "measure length"; auto)
 qed
 
 
 lemma remove_subsets_set : "set (remove_subsets xss) = {xs . xs \<in> set xss \<and> (\<nexists> xs' . xs' \<in> set xss \<and> xs \<subset> xs')}"
 proof (induction "length xss" arbitrary: xss rule: less_induct)
   case less
   
   show ?case proof (cases xss)
 
     case Nil
     then show ?thesis by auto
   next
     case (Cons x xss')
     
     show ?thesis proof (cases "find_remove (\<lambda> y . x \<subset> y) xss'")
       case None
       then have "(\<nexists> xs' . xs' \<in> set xss' \<and> x \<subset> xs')"
         using find_remove_None_iff by metis
 
       have "length (filter (\<lambda> y . \<not>(y \<subseteq> x)) xss') < length xss"
         using Cons
         by (meson dual_order.trans impossible_Cons leI length_filter_le) 
   
       have "remove_subsets (x#xss') = x # (remove_subsets (filter (\<lambda> y . \<not>(y \<subseteq> x)) xss'))"
         using None by auto
       then have "set (remove_subsets (x#xss')) = insert x {xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss'). \<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'}"
         using less[OF \<open>length (filter (\<lambda> y . \<not>(y \<subseteq> x)) xss') < length xss\<close>]
         by auto
       also have "\<dots> = {xs . xs \<in> set (x#xss') \<and> (\<nexists> xs' . xs' \<in> set (x#xss') \<and> xs \<subset> xs')}"
       proof -
         have "\<And> xs . xs \<in> insert x {xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss'). \<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'}
               \<Longrightarrow> xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}"
         proof -
           fix xs assume "xs \<in> insert x {xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss'). \<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'}"
           then consider "xs = x" | "xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> (\<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs')"
             by blast
           then show "xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}"
             using \<open>(\<nexists> xs' . xs' \<in> set xss' \<and> x \<subset> xs')\<close> by (cases; auto)
         qed
         moreover have "\<And> xs . xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}
                         \<Longrightarrow> xs \<in> insert x {xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss'). \<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'}" 
         proof -
           fix xs assume "xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}"
           then have "xs \<in> set (x # xss')" and "\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'"
             by blast+
           then consider "xs = x" | "xs \<in> set xss'" by auto
           then show "xs \<in> insert x {xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss'). \<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'}"
           proof cases
             case 1
             then show ?thesis by auto
           next
             case 2
             show ?thesis proof (cases "xs \<subseteq> x")
               case True
               then show ?thesis
                 using \<open>\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'\<close> by auto 
             next
               case False
               then have "xs \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss')"
                 using 2 by auto
               moreover have "\<nexists>xs'. xs' \<in> set (filter (\<lambda>y. \<not> y \<subseteq> x) xss') \<and> xs \<subset> xs'"
                 using \<open>\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'\<close> by auto
               ultimately show ?thesis by auto
             qed 
           qed
         qed
         ultimately show ?thesis
           by (meson subset_antisym subset_eq) 
       qed
       finally show ?thesis unfolding Cons[symmetric] by assumption
     next
       case (Some a)
       then obtain y' xs' where *: "find_remove (\<lambda> y . x \<subset> y) xss' = Some (y',xs')" by force
       
 
       have "length xs' = length xss' - 1"
         using find_remove_set(2,3)[OF *]
         by (simp add: length_remove1) 
       then have "length (y'#xs') = length xss'"
         using find_remove_set(2)[OF *]
         using remove1_length by fastforce 
       
       have "length (filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xs'"
         by simp
       then have "length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xs' + 1"
         by simp
       then have "length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<le> length xss'" 
         unfolding \<open>length (y'#xs') = length xss'\<close>[symmetric] by simp
       then have "length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') < length xss" 
         unfolding Cons by auto
 
 
       have "remove_subsets (x#xss') = remove_subsets (y'# (filter (\<lambda> y . \<not>(y \<subseteq> x)) xs'))"
         using * by auto
       then have "set (remove_subsets (x#xss')) = {xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs'). \<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a}"
         using less[OF \<open>length (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') < length xss\<close>]
         by auto
       also have "\<dots> = {xs . xs \<in> set (x#xss') \<and> (\<nexists> xs' . xs' \<in> set (x#xss') \<and> xs \<subset> xs')}"
       proof -
         have "\<And> xs . xs \<in> {xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs'). \<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a} 
                 \<Longrightarrow> xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}"
         proof -
           fix xs assume "xs \<in> {xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs'). \<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a}"
           then have "xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs')" and "\<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a"
             by blast+
 
           have "xs \<in> set (x # xss')"
             using \<open>xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs')\<close> find_remove_set(2,3)[OF *]
             by auto 
           moreover have "\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'"
             using \<open>\<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a\<close> find_remove_set[OF *]
             by (metis dual_order.strict_trans filter_list_set in_set_remove1 list.set_intros(1) list.set_intros(2) psubsetI set_ConsD)
           ultimately show "xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}" 
             by blast
         qed
         moreover have "\<And> xs . xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'} 
                 \<Longrightarrow> xs \<in> {xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs'). \<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a}" 
         proof -
           fix xs assume "xs \<in> {xs \<in> set (x # xss'). \<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'}"
           then have "xs \<in> set (x # xss')" and  "\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'"
             by blast+
 
           then have "xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs')"
             using find_remove_set[OF *]
             by (metis filter_list_set in_set_remove1 list.set_intros(1) list.set_intros(2) psubsetI set_ConsD) 
           moreover have "\<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a"
             using \<open>xs \<in> set (x # xss')\<close> \<open>\<nexists>xs'. xs' \<in> set (x # xss') \<and> xs \<subset> xs'\<close> find_remove_set[OF *]
             by (metis filter_is_subset list.set_intros(2) notin_set_remove1 set_ConsD subset_iff)
           ultimately show "xs \<in> {xs \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs'). \<nexists>xs'a. xs'a \<in> set (y' # filter (\<lambda>y. \<not> y \<subseteq> x) xs') \<and> xs \<subset> xs'a}"
             by blast
         qed
         ultimately show ?thesis by blast
       qed
       finally show ?thesis unfolding Cons by assumption
     qed
   qed
 qed
 
 subsection \<open>Linear Order on Sum\<close>
 
 instantiation sum :: (ord,ord) ord
 begin
 
 fun less_eq_sum ::  "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
   "less_eq_sum (Inl a) (Inl b) = (a \<le> b)" |
   "less_eq_sum (Inl a) (Inr b) = True" |
   "less_eq_sum (Inr a) (Inl b) = False" |
   "less_eq_sum (Inr a) (Inr b) = (a \<le> b)"
 
 fun less_sum ::  "'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool" where
   "less_sum a b = (a \<le> b \<and> a \<noteq> b)"
 
 instance by (intro_classes)
 end
 
 
 instantiation sum :: (linorder,linorder) linorder
 begin
 
 lemma less_le_not_le_sum :
   fixes x :: "'a + 'b"
   and   y :: "'a + 'b"
 shows "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"  
   by (cases x; cases y; auto)
     
 lemma order_refl_sum :
   fixes x :: "'a + 'b"
   shows "x \<le> x" 
   by (cases x; auto)
 
 lemma order_trans_sum :
   fixes x :: "'a + 'b"
   fixes y :: "'a + 'b"
   fixes z :: "'a + 'b"
   shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
   by (cases x; cases y; cases z; auto)  
 
 lemma antisym_sum :
   fixes x :: "'a + 'b"
   fixes y :: "'a + 'b"
   shows "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
   by (cases x; cases y; auto)
 
 lemma linear_sum :
   fixes x :: "'a + 'b"
   fixes y :: "'a + 'b"
   shows "x \<le> y \<or> y \<le> x"
   by (cases x; cases y; auto) 
 
 
 instance 
   using less_le_not_le_sum order_refl_sum order_trans_sum antisym_sum linear_sum
   by (intro_classes; metis+)
 end
 
 
 subsection \<open>Removing Proper Prefixes\<close>
 
 definition remove_proper_prefixes :: "'a list set \<Rightarrow> 'a list set" where
   "remove_proper_prefixes xs = {x . x \<in> xs \<and> (\<nexists> x' . x' \<noteq> [] \<and> x@x' \<in> xs)}"
 
 lemma remove_proper_prefixes_code[code] :
   "remove_proper_prefixes (set xs) = set (filter (\<lambda>x . (\<forall> y \<in> set xs . is_prefix x y \<longrightarrow> x = y)) xs)"
 proof -
   
   have *: "remove_proper_prefixes (set xs) = Set.filter (\<lambda> zs . \<nexists>ys . ys \<noteq> [] \<and> zs @ ys \<in> (set xs)) (set xs)"
     unfolding remove_proper_prefixes_def by force
 
   have "\<And> zs . (\<nexists>ys . ys \<noteq> [] \<and> zs @ ys \<in> (set xs)) = (\<forall> ys \<in> set xs . is_prefix zs ys \<longrightarrow> zs = ys)"
     unfolding is_prefix_prefix by auto
   
   then show ?thesis
     unfolding * filter_set by auto
 qed
 
 
 subsection \<open>Underspecified List Representations of Sets\<close>
 
 definition as_list_helper :: "'a set \<Rightarrow> 'a list" where
   "as_list_helper X = (SOME xs . set xs = X \<and> distinct xs)"
 
 lemma as_list_helper_props :
   assumes "finite X"
   shows "set (as_list_helper X) = X"
     and "distinct (as_list_helper X)"
   using finite_distinct_list[OF assms]
   using someI[of "\<lambda> xs . set xs = X \<and> distinct xs"]
   by (metis as_list_helper_def)+
 
 
 subsection \<open>Assigning indices to elements of a finite set\<close>
 
 fun assign_indices :: "('a :: linorder) set \<Rightarrow> ('a \<Rightarrow> nat)" where
   "assign_indices xs = (\<lambda> x . the (find_index ((=)x) (sorted_list_of_set xs)))"
 
 lemma assign_indices_bij:
   assumes "finite xs"
   shows "bij_betw (assign_indices xs) xs {..<card xs}"
 proof -
 
   have *:"set (sorted_list_of_set xs) = xs"
     by (simp add: assms)
   
 
   have "\<And>x y . x\<in>xs \<Longrightarrow> y\<in>xs \<Longrightarrow> assign_indices xs x = assign_indices xs y \<Longrightarrow> x = y"
   proof -
     fix x y assume "x\<in>xs" and "y\<in>xs" and "assign_indices xs x = assign_indices xs y"
 
     obtain i where "find_index ((=)x) (sorted_list_of_set xs) = Some i"
       using find_index_exhaustive[of "sorted_list_of_set xs" "((=) x)"]
       using \<open>x\<in>xs\<close> unfolding *
       by blast
     then have "assign_indices xs x = i"
       by auto
 
     obtain j where "find_index ((=)y) (sorted_list_of_set xs) = Some j"
       using find_index_exhaustive[of "sorted_list_of_set xs" "((=) y)"]
       using \<open>y\<in>xs\<close> unfolding *
       by blast
     then have "assign_indices xs y = j"
       by auto
     then have "i = j"
       using \<open>assign_indices xs x = assign_indices xs y\<close> \<open>assign_indices xs x = i\<close>
       by auto
     then have "find_index ((=)y) (sorted_list_of_set xs) = Some i"
       using \<open>find_index ((=)y) (sorted_list_of_set xs) = Some j\<close>
       by auto
 
     show "x = y"
       using find_index_index(2)[OF \<open>find_index ((=)x) (sorted_list_of_set xs) = Some i\<close>]
       using find_index_index(2)[OF \<open>find_index ((=)y) (sorted_list_of_set xs) = Some i\<close>]
       by auto
   qed
   moreover have "(assign_indices xs) ` xs = {..<card xs}"
   proof 
     show "assign_indices xs ` xs \<subseteq> {..<card xs}"
     proof 
       fix i assume "i \<in> assign_indices xs ` xs"
       then obtain x where "x \<in> xs" and "i = assign_indices xs x"
         by blast
       moreover obtain j where "find_index ((=)x) (sorted_list_of_set xs) = Some j"
         using find_index_exhaustive[of "sorted_list_of_set xs" "((=) x)"]
         using \<open>x\<in>xs\<close> unfolding *
         by blast
       ultimately have "find_index ((=)x) (sorted_list_of_set xs) = Some i"
         by auto
       show "i \<in> {..<card xs}"
         using find_index_index(1)[OF \<open>find_index ((=)x) (sorted_list_of_set xs) = Some i\<close>] 
         by auto
     qed
     show "{..<card xs} \<subseteq> assign_indices xs ` xs"
     proof 
       fix i assume "i \<in> {..<card xs}"
       then have "i < length (sorted_list_of_set xs)"
         by auto
       then have "sorted_list_of_set xs ! i \<in> xs"
         using "*" nth_mem by blast
       then obtain j where "find_index ((=) (sorted_list_of_set xs ! i)) (sorted_list_of_set xs) = Some j"
         using find_index_exhaustive[of "sorted_list_of_set xs" "((=) (sorted_list_of_set xs ! i))"]
         unfolding *
         by blast
       have "i = j"
         using find_index_index(1,2)[OF \<open>find_index ((=) (sorted_list_of_set xs ! i)) (sorted_list_of_set xs) = Some j\<close>]
         using \<open>i < length (sorted_list_of_set xs)\<close> distinct_sorted_list_of_set nth_eq_iff_index_eq by blast 
       then show "i \<in> assign_indices xs ` xs"
         using \<open>find_index ((=) (sorted_list_of_set xs ! i)) (sorted_list_of_set xs) = Some j\<close>
         by (metis \<open>sorted_list_of_set xs ! i \<in> xs\<close> assign_indices.elims image_iff option.sel)
     qed
   qed
   ultimately show ?thesis
     unfolding bij_betw_def inj_on_def by blast
 qed
 
 
 subsection \<open>Other Lemmata\<close>
 
 lemma foldr_elem_check: 
   assumes "list.set xs \<subseteq> A"
   shows "foldr (\<lambda> x y . if x \<notin> A then y else f x y) xs v = foldr f xs v"
   using assms by (induction xs; auto)
 
 lemma foldl_elem_check: 
   assumes "list.set xs \<subseteq> A"
   shows "foldl (\<lambda> y x . if x \<notin> A then y else f y x) v xs = foldl f v xs"
   using assms by (induction xs rule: rev_induct; auto)
 
 lemma foldr_length_helper :
   assumes "length xs = length ys"
   shows "foldr (\<lambda>_ x . f x) xs b = foldr (\<lambda>a x . f x) ys b"
   using assms by (induction xs ys rule: list_induct2; auto)
 
 lemma list_append_subset3 : "set xs1 \<subseteq> set ys1 \<Longrightarrow> set xs2 \<subseteq> set ys2 \<Longrightarrow> set xs3 \<subseteq> set ys3 \<Longrightarrow> set (xs1@xs2@xs3) \<subseteq> set(ys1@ys2@ys3)" by auto
 
 lemma subset_filter : "set xs \<subseteq> set ys \<Longrightarrow> set xs = set (filter (\<lambda> x . x \<in> set xs) ys)"
   by auto
 
 lemma map_filter_elem :
   assumes "y \<in> set (List.map_filter f xs)"
   obtains x where "x \<in> set xs" 
               and "f x = Some y"
   using assms unfolding List.map_filter_def
   by auto 
 
 lemma filter_length_weakening :
   assumes "\<And> q . f1 q \<Longrightarrow> f2 q"
   shows "length (filter f1 p) \<le> length (filter f2 p)"
 proof (induction p)
   case Nil
   then show ?case by auto
 next
   case (Cons a p)
   then show ?case using assms by (cases "f1 a"; auto)
 qed
 
 lemma max_length_elem :
   fixes xs :: "'a list set"
   assumes "finite xs"
   and     "xs \<noteq> {}"
 shows "\<exists> x \<in> xs . \<not>(\<exists> y \<in> xs . length y > length x)" 
 using assms proof (induction xs)
   case empty
   then show ?case by auto
 next
   case (insert x F)
   then show ?case proof (cases "F = {}")
     case True
     then show ?thesis by blast
   next
     case False
     then obtain y where "y \<in> F" and "\<not>(\<exists> y' \<in> F . length y' > length y)"
       using insert.IH by blast
     then show ?thesis using dual_order.strict_trans by (cases "length x > length y"; auto)
   qed
 qed
 
 lemma min_length_elem :
   fixes xs :: "'a list set"
   assumes "finite xs"
   and     "xs \<noteq> {}"
 shows "\<exists> x \<in> xs . \<not>(\<exists> y \<in> xs . length y < length x)" 
 using assms proof (induction xs)
   case empty
   then show ?case by auto
 next
   case (insert x F)
   then show ?case proof (cases "F = {}")
     case True
     then show ?thesis by blast
   next
     case False
     then obtain y where "y \<in> F" and "\<not>(\<exists> y' \<in> F . length y' < length y)"
       using insert.IH by blast
     then show ?thesis using dual_order.strict_trans by (cases "length x < length y"; auto)
   qed
 qed
 
 lemma list_property_from_index_property :
   assumes "\<And> i . i < length xs \<Longrightarrow> P (xs ! i)"
   shows "\<And> x . x \<in> set xs \<Longrightarrow> P x"
   by (metis assms in_set_conv_nth) 
 
 lemma list_distinct_prefix :
   assumes "\<And> i . i < length xs \<Longrightarrow> xs ! i \<notin> set (take i xs)"
   shows "distinct xs"
 proof -
   have "\<And> j . distinct (take j xs)"
   proof -
     fix j 
     show "distinct (take j xs)"
     proof (induction j)
       case 0
       then show ?case by auto
     next
       case (Suc j)
       then show ?case proof (cases "Suc j \<le> length xs")
         case True
         then have "take (Suc j) xs = (take j xs) @ [xs ! j]"
           by (simp add: Suc_le_eq take_Suc_conv_app_nth)
         then show ?thesis using Suc.IH assms[of j] True by auto
       next
         case False
         then have "take (Suc j) xs = take j xs" by auto
         then show ?thesis using Suc.IH by auto
       qed
     qed 
   qed
   then have "distinct (take (length xs) xs)"
     by blast
   then show ?thesis by auto 
 qed
 
 
 lemma concat_pair_set :
   "set (concat (map (\<lambda>x. map (Pair x) ys) xs)) = {xy . fst xy \<in> set xs \<and> snd xy \<in> set ys}"
   by auto
 
 lemma list_set_sym :
   "set (x@y) = set (y@x)" by auto
 
 
 
 lemma list_contains_last_take :
   assumes "x \<in> set xs"
   shows "\<exists> i . 0 < i \<and> i \<le> length xs \<and> last (take i xs) = x"
   by (metis Suc_leI assms hd_drop_conv_nth in_set_conv_nth last_snoc take_hd_drop zero_less_Suc)
   
 lemma take_last_index :
   assumes "i < length xs"
   shows "last (take (Suc i) xs) = xs ! i"
   by (simp add: assms take_Suc_conv_app_nth)
 
 lemma integer_singleton_least :
   assumes "{x . P x} = {a::integer}"
   shows "a = (LEAST x . P x)"
   by (metis Collect_empty_eq Least_equality assms insert_not_empty mem_Collect_eq order_refl singletonD)
 
 
 lemma sort_list_split :
   "\<forall> x \<in> set (take i (sort xs)) . \<forall> y \<in> set (drop i (sort xs)) . x \<le> y"
   using sorted_append by fastforce
 
 
 lemma set_map_subset :
   assumes "x \<in> set xs"
   and     "t \<in> set (map f [x])"
 shows "t \<in> set (map f xs)"
   using assms by auto
 
 lemma rev_induct2[consumes 1, case_names Nil snoc]: 
   assumes "length xs = length ys" 
       and "P [] []"
       and "(\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (xs@[x]) (ys@[y]))"
     shows "P xs ys"
 using assms proof (induct xs arbitrary: ys rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
   then show ?case proof (cases ys)
     case Nil
     then show ?thesis
       using snoc.prems(1) by auto 
   next
     case (Cons a list)
     then show ?thesis
       by (metis append_butlast_last_id diff_Suc_1 length_append_singleton list.distinct(1) snoc.hyps snoc.prems) 
   qed
 qed
 
 lemma finite_set_min_param_ex :
   assumes "finite XS"
   and     "\<And> x . x \<in> XS \<Longrightarrow> \<exists> k . \<forall> k' . k \<le> k' \<longrightarrow> P x k'"
 shows "\<exists> (k::nat) . \<forall> x \<in> XS . P x k"
 proof -
   obtain f where f_def : "\<And> x . x \<in> XS \<Longrightarrow> \<forall> k' . (f x) \<le> k' \<longrightarrow> P x k'"
     using assms(2) by meson
   let ?k = "Max (image f XS)"
   have "\<forall> x \<in> XS . P x ?k"
     using f_def by (simp add: assms(1)) 
   then show ?thesis by blast
 qed
 
 fun list_max :: "nat list \<Rightarrow> nat" where
   "list_max [] = 0" |
   "list_max xs = Max (set xs)"
 
 lemma list_max_is_max : "q \<in> set xs \<Longrightarrow> q \<le> list_max xs"
   by (metis List.finite_set Max_ge length_greater_0_conv length_pos_if_in_set list_max.elims) 
 
 lemma list_prefix_subset : "\<exists> ys . ts = xs@ys \<Longrightarrow> set xs \<subseteq> set ts" by auto
 lemma list_map_set_prop : "x \<in> set (map f xs) \<Longrightarrow> \<forall> y . P (f y) \<Longrightarrow> P x" by auto
 lemma list_concat_non_elem : "x \<notin> set xs \<Longrightarrow> x \<notin> set ys \<Longrightarrow> x \<notin> set (xs@ys)" by auto
 lemma list_prefix_elem : "x \<in> set (xs@ys) \<Longrightarrow> x \<notin> set ys \<Longrightarrow> x \<in> set xs" by auto
 lemma list_map_source_elem : "x \<in> set (map f xs) \<Longrightarrow> \<exists> x' \<in> set xs . x = f x'" by auto
 
 
 lemma maximal_set_cover : 
   fixes X :: "'a set set"
   assumes "finite X" 
   and     "S \<in> X"  
 shows "\<exists> S' \<in> X . S \<subseteq> S' \<and> (\<forall> S'' \<in> X . \<not>(S' \<subset> S''))"
 proof (rule ccontr)
   assume "\<not> (\<exists>S'\<in>X. S \<subseteq> S' \<and> (\<forall>S''\<in>X. \<not> S' \<subset> S''))"
   then have *: "\<And> T . T \<in> X \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<exists> T' \<in> X . T \<subset> T'"
     by auto
 
   have "\<And> k . \<exists> ss . (length ss = Suc k) \<and> (hd ss = S) \<and> (\<forall> i < k . ss ! i \<subset> ss ! (Suc i)) \<and> (set ss \<subseteq> X)"
   proof -
     fix k show "\<exists> ss . (length ss = Suc k) \<and> (hd ss = S) \<and> (\<forall> i < k . ss ! i \<subset> ss ! (Suc i)) \<and> (set ss \<subseteq> X)"
     proof (induction k)
       case 0
       have "length [S] = Suc 0 \<and> hd [S] = S \<and> (\<forall> i < 0 . [S] ! i \<subset> [S] ! (Suc i)) \<and> (set [S] \<subseteq> X)" using assms(2) by auto
       then show ?case by blast
     next
       case (Suc k)
       then obtain ss where "length ss = Suc k" 
                        and "hd ss = S" 
                        and "(\<forall>i<k. ss ! i \<subset> ss ! Suc i)" 
                        and "set ss \<subseteq> X"
         by blast
       then have "ss ! k \<in> X"
         by auto
       moreover have "S \<subseteq> (ss ! k)"
       proof -
         have "\<And> i . i < Suc k \<Longrightarrow> S \<subseteq> (ss ! i)"
         proof -
           fix i assume "i < Suc k"
           then show "S \<subseteq> (ss ! i)"
           proof (induction i)
             case 0
             then show ?case using \<open>hd ss = S\<close> \<open>length ss = Suc k\<close>
               by (metis hd_conv_nth list.size(3) nat.distinct(1) order_refl) 
           next
             case (Suc i)
             then have "S \<subseteq> ss ! i" and "i < k" by auto
             then have "ss ! i \<subset> ss ! Suc i" using \<open>(\<forall>i<k. ss ! i \<subset> ss ! Suc i)\<close> by blast
             then show ?case using \<open>S \<subseteq> ss ! i\<close> by auto
           qed
         qed
         then show ?thesis using \<open>length ss = Suc k\<close> by auto 
       qed
       ultimately obtain T' where "T' \<in> X" and "ss ! k \<subset> T'"
         using * by meson 
 
       let ?ss = "ss@[T']"
 
       have "length ?ss = Suc (Suc k)" 
         using \<open>length ss = Suc k\<close> by auto
       moreover have "hd ?ss = S" 
         using \<open>hd ss = S\<close> by (metis \<open>length ss = Suc k\<close> hd_append list.size(3) nat.distinct(1)) 
       moreover have "(\<forall>i < Suc k. ?ss ! i \<subset> ?ss ! Suc i)" 
         using \<open>(\<forall>i<k. ss ! i \<subset> ss ! Suc i)\<close> \<open>ss ! k \<subset> T'\<close> 
         by (metis Suc_lessI \<open>length ss = Suc k\<close> diff_Suc_1 less_SucE nth_append nth_append_length) 
       moreover have "set ?ss \<subseteq> X" 
         using \<open>set ss \<subseteq> X\<close> \<open>T' \<in> X\<close> by auto
       ultimately show ?case by blast
     qed
   qed
 
   then obtain ss where "(length ss = Suc (card X))"
                    and "(hd ss = S)" 
                    and "(\<forall> i < card X . ss ! i \<subset> ss ! (Suc i))" 
                    and "(set ss \<subseteq> X)" 
     by blast
   then have "(\<forall> i < length ss - 1 . ss ! i \<subset> ss ! (Suc i))"
     by auto
 
   have **: "\<And> i (ss :: 'a set list) . (\<forall> i < length ss - 1 . ss ! i \<subset> ss ! (Suc i)) \<Longrightarrow> i < length ss  \<Longrightarrow> \<forall> s \<in> set (take i ss) . s \<subset> ss ! i"
   proof -
     fix i 
     fix ss :: "'a set list"
     assume "i < length ss " and "(\<forall> i < length ss - 1 . ss ! i \<subset> ss ! (Suc i))"
     then show "\<forall> s \<in> set (take i ss) . s \<subset> ss ! i"
     proof (induction i)
       case 0
       then show ?case by auto
     next
       case (Suc i)
       then have "\<forall>s\<in>set (take i ss). s \<subset> ss ! i" by auto
       then have "\<forall>s\<in>set (take i ss). s \<subset> ss ! (Suc i)" using Suc.prems
         by (metis One_nat_def Suc_diff_Suc Suc_lessE diff_zero dual_order.strict_trans nat.inject zero_less_Suc) 
       moreover have "ss ! i \<subset> ss ! (Suc i)" using Suc.prems by auto
       moreover have "(take (Suc i) ss) = (take i ss)@[ss ! i]" using Suc.prems(1)
         by (simp add: take_Suc_conv_app_nth)
       ultimately show ?case by auto 
     qed
   qed
 
   have "distinct ss"
     using \<open>(\<forall> i < length ss - 1 . ss ! i \<subset> ss ! (Suc i))\<close>
   proof (induction ss rule: rev_induct)
     case Nil
     then show ?case by auto
   next
     case (snoc a ss)
     from snoc.prems have "\<forall>i<length ss - 1. ss ! i \<subset> ss ! Suc i"
       by (metis Suc_lessD diff_Suc_1 diff_Suc_eq_diff_pred length_append_singleton nth_append zero_less_diff) 
     then have "distinct ss"
       using snoc.IH by auto
     moreover have "a \<notin> set ss"
       using **[OF snoc.prems, of "length (ss @ [a]) - 1"] by auto
     ultimately show ?case by auto
   qed
 
   then have "card (set ss) = Suc (card X)"
     using \<open>(length ss = Suc (card X))\<close> by (simp add: distinct_card) 
   then show "False"
     using \<open>set ss \<subseteq> X\<close> \<open>finite X\<close> by (metis Suc_n_not_le_n card_mono) 
 qed
 
 
 
 lemma map_set : 
   assumes "x \<in> set xs"
   shows "f x \<in> set (map f xs)" using assms by auto
 
 
 lemma maximal_distinct_prefix :
   assumes "\<not> distinct xs"
   obtains n where "distinct (take (Suc n) xs)"
             and   "\<not> (distinct (take (Suc (Suc n)) xs))"
 using assms proof (induction xs rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
   
   show ?case proof (cases "distinct xs")
     case True
     then have "distinct (take (length xs) (xs@[x]))" by auto
     moreover have"\<not> (distinct (take (Suc (length xs)) (xs@[x])))" using snoc.prems(2) by auto
     ultimately show ?thesis using that by (metis Suc_pred distinct_singleton length_greater_0_conv self_append_conv2 snoc.prems(1) snoc.prems(2))
   next
     case False
     
     then show ?thesis using snoc.IH that
       by (metis Suc_mono butlast_snoc length_append_singleton less_SucI linorder_not_le snoc.prems(1) take_all take_butlast) 
   qed
 qed 
 
 
 lemma distinct_not_in_prefix :
   assumes "\<And> i . (\<And> x . x \<in> set (take i xs) \<Longrightarrow> xs ! i \<noteq> x)"
   shows "distinct xs"
   using assms list_distinct_prefix by blast 
 
 
 lemma list_index_fun_gt : "\<And> xs (f::'a \<Rightarrow> nat) i j . 
                               (\<And> i . Suc i < length xs \<Longrightarrow> f (xs ! i) > f (xs ! (Suc i))) 
                               \<Longrightarrow> j < i 
                               \<Longrightarrow> i < length xs 
                               \<Longrightarrow> f (xs ! j) > f (xs ! i)"
 proof -
   fix xs::"'a list" 
   fix f::"'a \<Rightarrow> nat" 
   fix i j 
   assume "(\<And> i . Suc i < length xs \<Longrightarrow> f (xs ! i) > f (xs ! (Suc i)))"
      and "j < i"
      and "i < length xs"
   then show "f (xs ! j) > f (xs ! i)"
   proof (induction "i - j" arbitrary: i j)
     case 0
     then show ?case by auto
   next
     case (Suc x)
     then show ?case
     proof -
       have f1: "\<forall>n. \<not> Suc n < length xs \<or> f (xs ! Suc n) < f (xs ! n)"
         using Suc.prems(1) by presburger
       have f2: "\<forall>n na. \<not> n < na \<or> Suc n \<le> na"
         using Suc_leI by satx
       have "x = i - Suc j"
         by (metis Suc.hyps(2) Suc.prems(2) Suc_diff_Suc nat.simps(1))
       then have "\<not> Suc j < i \<or> f (xs ! i) < f (xs ! Suc j)"
         using f1 Suc.hyps(1) Suc.prems(3) by blast
       then show ?thesis
         using f2 f1 by (metis Suc.prems(2) Suc.prems(3) leI le_less_trans not_less_iff_gr_or_eq)
     qed 
   qed
 qed
 
-lemma distinct_lists_finite :
-  assumes "finite X"
-  shows "finite {xs . set xs \<subseteq> X \<and> distinct xs }" 
-proof -
-  define k where "k = card X"
-
-  have "\<And> xs . set xs \<subseteq> X \<Longrightarrow> distinct xs \<Longrightarrow> length xs \<le> k"
-    using assms unfolding \<open>k = card X\<close>
-    by (metis card_mono distinct_card)
-
-  then have "{xs . set xs \<subseteq> X \<and> distinct xs } \<subseteq> {xs . set xs \<subseteq> X \<and> length xs \<le> k}"
-    by blast
-  moreover have "finite {xs . set xs \<subseteq> X \<and> length xs \<le> k}"
-    using assms by (simp add: finite_lists_length_le) 
-  ultimately show ?thesis
-    using rev_finite_subset by auto 
-qed
-
-
 lemma finite_set_elem_maximal_extension_ex :
   assumes "xs \<in> S"
   and     "finite S"
 shows "\<exists> ys . xs@ys \<in> S \<and> \<not> (\<exists> zs . zs \<noteq> [] \<and> xs@ys@zs \<in> S)"
 using \<open>finite S\<close> \<open>xs \<in> S\<close> proof (induction S arbitrary: xs)
   case empty
   then show ?case by auto
 next
   case (insert x S)
 
   consider (a) "\<exists> ys . x = xs@ys \<and> \<not> (\<exists> zs . zs \<noteq> [] \<and> xs@ys@zs \<in> (insert x S))" |
            (b) "\<not>(\<exists> ys . x = xs@ys \<and> \<not> (\<exists> zs . zs \<noteq> [] \<and> xs@ys@zs \<in> (insert x S)))"
     by blast
   then show ?case proof cases
     case a
     then show ?thesis by auto
   next
     case b
     then show ?thesis proof (cases "\<exists> vs . vs \<noteq> [] \<and> xs@vs \<in> S")
       case True
       then obtain vs where "vs \<noteq> []" and "xs@vs \<in> S"
         by blast
       
       have "\<exists>ys. xs @ (vs @ ys) \<in> S \<and> (\<nexists>zs. zs \<noteq> [] \<and> xs @ (vs @ ys) @ zs \<in> S)"
         using insert.IH[OF \<open>xs@vs \<in> S\<close>] by auto
       then have "\<exists>ys. xs @ (vs @ ys) \<in> S \<and> (\<nexists>zs. zs \<noteq> [] \<and> xs @ (vs @ ys) @ zs \<in> (insert x S))"
         using b 
         unfolding append.assoc append_is_Nil_conv append_self_conv insert_iff
         by (metis append.assoc append_Nil2 append_is_Nil_conv same_append_eq) 
       then show ?thesis by blast
     next
       case False
       then show ?thesis using insert.prems
         by (metis append_is_Nil_conv append_self_conv insertE same_append_eq) 
     qed
   qed
 qed
 
 
 lemma list_index_split_set: 
   assumes "i < length xs"
 shows "set xs = set ((xs ! i) # ((take i xs) @ (drop (Suc i) xs)))"  
 using assms proof (induction xs arbitrary: i)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then show ?case proof (cases i)
     case 0
     then show ?thesis by auto
   next
     case (Suc j)
     then have "j < length xs" using Cons.prems by auto
     then have "set xs = set ((xs ! j) # ((take j xs) @ (drop (Suc j) xs)))" using Cons.IH[of j] by blast
     
     have *: "take (Suc j) (x#xs) = x#(take j xs)" by auto
     have **: "drop (Suc (Suc j)) (x#xs) = (drop (Suc j) xs)" by auto
     have ***: "(x # xs) ! Suc j = xs ! j" by auto
     
     show ?thesis
       using \<open>set xs = set ((xs ! j) # ((take j xs) @ (drop (Suc j) xs)))\<close>
       unfolding Suc * ** *** by auto
   qed
 qed
 
 
 lemma max_by_foldr :
   assumes "x \<in> set xs"
   shows "f x < Suc (foldr (\<lambda> x' m . max (f x') m) xs 0)"
   using assms by (induction xs; auto)
 
 lemma Max_elem : "finite (xs :: 'a set) \<Longrightarrow> xs \<noteq> {} \<Longrightarrow> \<exists> x \<in> xs . Max (image (f :: 'a \<Rightarrow> nat) xs) = f x"
   by (metis (mono_tags, opaque_lifting) Max_in empty_is_image finite_imageI imageE)
 
 
 lemma card_union_of_singletons :
   assumes "\<And> S . S \<in> SS \<Longrightarrow> (\<exists> t . S = {t})"
 shows "card (\<Union> SS) = card SS"
 proof -
   let ?f = "\<lambda> x . {x}"
   have "bij_betw ?f (\<Union> SS) SS" 
     unfolding bij_betw_def inj_on_def using assms by fastforce
   then show ?thesis 
     using bij_betw_same_card by blast 
 qed
 
 lemma card_union_of_distinct :
   assumes "\<And> S1 S2 . S1 \<in> SS \<Longrightarrow> S2 \<in> SS \<Longrightarrow> S1 = S2 \<or> f S1 \<inter> f S2 = {}"
   and     "finite SS"
   and     "\<And> S . S \<in> SS \<Longrightarrow> f S \<noteq> {}"
 shows "card (image f SS) = card SS" 
 proof -
   from assms(2) have "\<forall> S1 \<in> SS . \<forall> S2 \<in> SS . S1 = S2 \<or> f S1 \<inter> f S2 = {} 
                       \<Longrightarrow> \<forall> S \<in> SS . f S \<noteq> {} \<Longrightarrow> ?thesis"
   proof (induction SS)
     case empty
     then show ?case by auto
   next
     case (insert x F)
     then have "\<not> (\<exists> y \<in> F . f y = f x)" 
       by auto
     then have "f x \<notin> image f F" 
       by auto
     then have "card (image f (insert x F)) = Suc (card (image f F))" 
       using insert by auto
     moreover have "card (f ` F) = card F" 
       using insert by auto
     moreover have "card (insert x F) = Suc (card F)" 
       using insert by auto
     ultimately show ?case 
       by simp
   qed
   then show ?thesis 
     using assms by simp
 qed
 
 
 lemma take_le :
   assumes "i \<le> length xs"
   shows "take i (xs@ys) = take i xs"
   by (simp add: assms less_imp_le_nat)
 
 
 lemma butlast_take_le :
   assumes "i \<le> length (butlast xs)" 
   shows "take i (butlast xs) = take i xs" 
   using take_le[OF assms, of "[last xs]"]
   by (metis append_butlast_last_id butlast.simps(1)) 
 
 
 lemma distinct_union_union_card :
   assumes "finite xs"
   and     "\<And> x1 x2 y1 y2 . x1 \<noteq> x2 \<Longrightarrow> x1 \<in> xs \<Longrightarrow> x2 \<in> xs \<Longrightarrow> y1 \<in> f x1 \<Longrightarrow> y2 \<in> f x2 \<Longrightarrow> g y1 \<inter> g y2 = {}"
   and     "\<And> x1 y1 y2 . y1 \<in> f x1 \<Longrightarrow> y2 \<in> f x1 \<Longrightarrow> y1 \<noteq> y2 \<Longrightarrow> g y1 \<inter> g y2 = {}"
   and     "\<And> x1 . finite (f x1)"
   and     "\<And> y1 . finite (g y1)"
   and     "\<And> y1 . g y1 \<subseteq> zs"
   and     "finite zs"
 shows "(\<Sum> x \<in> xs . card (\<Union> y \<in> f x . g y)) \<le> card zs" 
 proof -
   have "(\<Sum> x \<in> xs . card (\<Union> y \<in> f x . g y)) = card (\<Union> x \<in> xs . (\<Union> y \<in> f x . g y))"
     using assms(1,2) proof induction
     case empty
     then show ?case by auto
   next
     case (insert x xs)
     then have "(\<And>x1 x2. x1 \<in> xs \<Longrightarrow> x2 \<in> xs \<Longrightarrow> x1 \<noteq> x2 \<Longrightarrow> \<Union> (g ` f x1) \<inter> \<Union> (g ` f x2) = {})" and "x \<in> insert x xs" by blast+
     then have "(\<Sum>x\<in>xs. card (\<Union> (g ` f x))) = card (\<Union>x\<in>xs. \<Union> (g ` f x))" using insert.IH by blast
 
     moreover have "(\<Sum>x\<in>(insert x xs). card (\<Union> (g ` f x))) = (\<Sum>x\<in>xs. card (\<Union> (g ` f x))) + card (\<Union> (g ` f x))"
       using insert.hyps by auto
 
     moreover have "card (\<Union>x\<in>(insert x xs). \<Union> (g ` f x)) = card (\<Union>x\<in>xs. \<Union> (g ` f x)) + card (\<Union> (g ` f x))"
     proof -
       have "((\<Union>x\<in>xs. \<Union> (g ` f x)) \<union> \<Union> (g ` f x)) = (\<Union>x\<in>(insert x xs). \<Union> (g ` f x))"
         by blast
 
       have *: "(\<Union>x\<in>xs. \<Union> (g ` f x)) \<inter> (\<Union> (g ` f x)) = {}"
       proof (rule ccontr)
         assume "(\<Union>x\<in>xs. \<Union> (g ` f x)) \<inter> \<Union> (g ` f x) \<noteq> {}"
         then obtain z where "z \<in> \<Union> (g ` f x)" and "z \<in> (\<Union>x\<in>xs. \<Union> (g ` f x))" by blast
         then obtain x' where "x' \<in> xs" and "z \<in> \<Union> (g ` f x')" by blast
         then have "x' \<noteq> x" and "x' \<in> insert x xs" using insert.hyps by blast+
 
         have "\<Union> (g ` f x') \<inter> \<Union> (g ` f x) = {}"
           using insert.prems[OF \<open>x' \<noteq> x\<close> \<open>x' \<in> insert x xs\<close> \<open>x \<in> insert x xs\<close> ]
           by blast 
         then show "False"
           using \<open>z \<in> \<Union> (g ` f x')\<close> \<open>z \<in> \<Union> (g ` f x)\<close> by blast
       qed
       have **: "finite (\<Union> (g ` f x))"
         using assms(4) assms(5) by blast 
       have ***: "finite (\<Union>x\<in>xs. \<Union> (g ` f x))"
         by (simp add: assms(4) assms(5) insert.hyps(1))
 
       have "card ((\<Union>x\<in>xs. \<Union> (g ` f x)) \<union> \<Union> (g ` f x)) = card (\<Union>x\<in>xs. \<Union> (g ` f x)) + card (\<Union> (g ` f x))" 
         using card_Un_disjoint[OF *** ** *] by simp
 
       
       then show ?thesis 
         unfolding \<open>((\<Union>x\<in>xs. \<Union> (g ` f x)) \<union> \<Union> (g ` f x)) = (\<Union>x\<in>(insert x xs). \<Union> (g ` f x))\<close> by assumption
     qed
 
     ultimately show ?case by linarith
   qed
 
   moreover have "card (\<Union> x \<in> xs . (\<Union> y \<in> f x . g y)) \<le> card zs"
   proof -
     have "(\<Union> x \<in> xs . (\<Union> y \<in> f x . g y)) \<subseteq> zs"
       using assms(6) by (simp add: UN_least) 
     moreover have "finite (\<Union> x \<in> xs . (\<Union> y \<in> f x . g y))"
       by (simp add: assms(1) assms(4) assms(5)) 
     ultimately show ?thesis
       using assms(7)
       by (simp add: card_mono) 
   qed
 
   ultimately show ?thesis
     by linarith 
 qed
 
 
 lemma set_concat_elem :
   assumes "x \<in> set (concat xss)"
   obtains xs where "xs \<in> set xss" and "x \<in> set xs" 
   using assms by auto
 
 lemma set_map_elem :
   assumes "y \<in> set (map f xs)"
   obtains x where "y = f x" and "x \<in> set xs" 
   using assms by auto
 
 lemma finite_snd_helper: 
   assumes "finite xs" 
   shows "finite {z. ((q, p), z) \<in> xs}" 
 proof -
   have "{z. ((q, p), z) \<in> xs} \<subseteq> (\<lambda>((a,b),c) . c) ` xs" 
   proof 
     fix x assume "x \<in> {z. ((q, p), z) \<in> xs}"
     then have "((q,p),x) \<in> xs" by auto
     then show "x \<in> (\<lambda>((a,b),c) . c) ` xs" by force
   qed
   then show ?thesis using assms
     using finite_surj by blast 
 qed
 
 lemma fold_dual : "fold (\<lambda> x (a1,a2) . (g1 x a1, g2 x a2)) xs (a1,a2) = (fold g1 xs a1, fold g2 xs a2)"
   by (induction xs arbitrary: a1 a2; auto)
 
 lemma recursion_renaming_helper :
   assumes "f1 = (\<lambda>x . if P x then x else f1 (Suc x))"
   and     "f2 = (\<lambda>x . if P x then x else f2 (Suc x))"
   and     "\<And> x . x \<ge> k \<Longrightarrow> P x"
 shows "f1 = f2"
 proof 
   fix x 
   show "f1 x = f2 x"
   proof (induction "k - x" arbitrary: x)
     case 0
     then have "x \<ge> k" 
       by auto
     then show ?case 
       using assms(3) by (simp add: assms(1,2))
   next
     case (Suc k')
     show ?case proof (cases "P x")
       case True
       then show ?thesis by (simp add: assms(1,2))
     next
       case False
       moreover have "f1 (Suc x) = f2 (Suc x)"
         using Suc.hyps(1)[of "Suc x"] Suc.hyps(2) by auto
       ultimately show ?thesis by (simp add: assms(1,2))
     qed
   qed
 qed
 
 
 lemma minimal_fixpoint_helper :
   assumes "f = (\<lambda>x . if P x then x else f (Suc x))"
   and     "\<And> x . x \<ge> k \<Longrightarrow> P x"
 shows "P (f x)"
   and "\<And> x' . x' \<ge> x \<Longrightarrow> x' < f x \<Longrightarrow> \<not> P x'"
 proof -
   have "P (f x) \<and> (\<forall> x' . x' \<ge> x \<longrightarrow> x' < f x \<longrightarrow> \<not> P x')"
   proof (induction "k-x" arbitrary: x)
     case 0
     then have "P x" 
       using assms(2) by auto
     moreover have "f x = x"
       using calculation by (simp add: assms(1))
     ultimately show ?case 
       using assms(1) by auto  
   next
     case (Suc k')
     then have "P (f (Suc x))" and "\<And> x' . x' \<ge> Suc x \<Longrightarrow> x' < f (Suc x) \<Longrightarrow> \<not> P x'"
       by force+
 
     show ?case proof (cases "P x")
       case True
       then have "f x = x"
         by (simp add: assms(1))
       show ?thesis 
         using True unfolding \<open>f x = x\<close> by auto
     next
       case False
       then have "f x = f (Suc x)"
         by (simp add: assms(1))
       then have "P (f x)"
         using \<open>P (f (Suc x))\<close> by simp
       moreover have "(\<forall>x'\<ge>x. x' < f x \<longrightarrow> \<not> P x')"
         using \<open>\<And> x' . x' \<ge> Suc x \<Longrightarrow> x' < f (Suc x) \<Longrightarrow> \<not> P x'\<close> False \<open>f x = f (Suc x)\<close>
         by (metis Suc_leI le_neq_implies_less) 
       ultimately show ?thesis
         by blast
     qed
   qed
   then show "P (f x)" and "\<And> x' . x' \<ge> x \<Longrightarrow> x' < f x \<Longrightarrow> \<not> P x'"
     by blast+
 qed
 
 lemma map_set_index_helper :
   assumes "xs \<noteq> []"
   shows "set (map f xs) = (\<lambda>i . f (xs ! i)) ` {.. (length xs - 1)}" 
 using assms proof (induction xs rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x xs)
   show ?case proof (cases "xs = []")
     case True
     show ?thesis 
       using snoc.prems unfolding True by auto
   next
     case False    
 
     have "{..length (xs@[x]) - 1} = insert (length (xs@[x]) - 1) {..length xs - 1}"
       by force
     moreover have "((\<lambda>i. f ((xs@[x]) ! i)) (length (xs@[x]) - 1)) = f x"
       by auto
     moreover have "((\<lambda>i. f ((xs@[x]) ! i)) ` {..length xs - 1}) = ((\<lambda>i. f (xs ! i)) ` {..length xs - 1})"
     proof -
       have "\<And> i . i < length xs \<Longrightarrow> f ((xs@[x]) ! i) = f (xs ! i)"
         by (simp add: nth_append)
       moreover have "\<And> i . i \<in> {..length xs - 1} \<Longrightarrow> i < length xs"
         using False
         by (metis Suc_pred' atMost_iff length_greater_0_conv less_Suc_eq_le) 
       ultimately show ?thesis
         by (meson image_cong)
     qed
     ultimately have "(\<lambda>i. f ((xs@[x]) ! i)) ` {..length (xs@[x]) - 1} = insert (f x) ((\<lambda>i. f (xs ! i)) ` {..length xs - 1})"
       by auto
     moreover have "set (map f (xs@[x])) = insert (f x) (set (map f xs))"
       by auto
     moreover have "set (map f xs) = (\<lambda>i. f (xs ! i)) ` {..length xs - 1}"
       using snoc.IH False by auto
     ultimately show ?thesis
       by force
   qed
 qed
 
 lemma partition_helper :
   assumes "finite X"
   and     "X \<noteq> {}"
   and     "\<And> x . x \<in> X \<Longrightarrow> p x \<subseteq> X"
   and     "\<And> x . x \<in> X \<Longrightarrow> p x \<noteq> {}"
   and     "\<And> x y . x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> p x = p y \<or> p x \<inter> p y = {}"
   and     "(\<Union> x \<in> X . p x) = X"
 obtains l::nat and p' where
   "p' ` {..l} = p ` X"
   "\<And> i j . i \<le> l \<Longrightarrow> j \<le> l \<Longrightarrow> i \<noteq> j \<Longrightarrow> p' i \<inter> p' j = {}"
   "card (p ` X) = Suc l"
 proof -
   let ?P = "as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X)"
 
 
   have "?P \<noteq> []"
     using assms(1) assms(2)
     by (metis as_list_helper_props(1) finite_imageI image_is_empty set_empty) 
 
   define l where l: "l = length ?P - 1"
   define p' where p': "p' = (\<lambda> x . set (?P ! x))"
 
   have "finite ((\<lambda>x. as_list_helper (p x)) ` X)"
     using assms(1)
     by simp 
 
   have "set ` ((\<lambda>x. as_list_helper (p x)) ` X) = p ` X"
   proof -
     have "set ` ((\<lambda>x. as_list_helper (p x)) ` X) = ((\<lambda>x. set (as_list_helper (p x))) ` X)"
       by auto
     also have "\<dots> = p ` X"
       by (metis (no_types, lifting) as_list_helper_props(1) assms(1) assms(6) finite_UN image_cong)
     finally show ?thesis .
   qed
   moreover have "set ?P = (\<lambda>x. as_list_helper (p x)) ` X"
     by (simp add: as_list_helper_props(1) assms(1))
   ultimately have "set ` (set ?P) = p ` X"
     by auto
   moreover have "(p' ` {..l}) = set (map set ?P)"
     using map_set_index_helper[OF \<open>?P \<noteq> []\<close>]
   proof -
     have "(\<lambda>n. set (as_list_helper ((\<lambda>n. as_list_helper (p n)) ` X) ! n)) ` {..l} = p' ` {..l}"
       using p' by force
     then show ?thesis
       by (metis \<open>\<And>f. set (map f (as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X))) = (\<lambda>i. f (as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X) ! i)) ` {..length (as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X)) - 1}\<close> l)
   qed
   ultimately have p1: "p' ` {..l} = p ` X"
     by (metis list.set_map)
 
   moreover have p2: "\<And> i j . i \<le> l \<Longrightarrow> j \<le> l \<Longrightarrow> i \<noteq> j \<Longrightarrow> p' i \<inter> p' j = {}"
   proof -
     fix i j assume "i \<le> l" "j \<le> l" "i \<noteq> j"
     moreover define PX where PX: "PX = ((\<lambda>x. as_list_helper (p x)) ` X)"
     ultimately have "i < length (as_list_helper PX)" and "j < length (as_list_helper PX)"
       unfolding l by auto
     then have "?P ! i \<noteq> ?P ! j"
       using \<open>i \<noteq> j\<close> unfolding PX
       using as_list_helper_props(2)[OF \<open>finite ((\<lambda>x. as_list_helper (p x)) ` X)\<close>]
       using nth_eq_iff_index_eq by blast
     moreover obtain xi where "xi \<in> X" and *:"?P ! i = as_list_helper (p xi)"
       by (metis (no_types, lifting) PX \<open>i < length (as_list_helper PX)\<close> \<open>set (as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X)) = (\<lambda>x. as_list_helper (p x)) ` X\<close> image_iff nth_mem)
     moreover obtain xj where "xj \<in> X" and **:"?P ! j = as_list_helper (p xj)"
       by (metis (no_types, lifting) PX \<open>j < length (as_list_helper PX)\<close> \<open>set (as_list_helper ((\<lambda>x. as_list_helper (p x)) ` X)) = (\<lambda>x. as_list_helper (p x)) ` X\<close> image_iff nth_mem)
     ultimately have "p xi \<noteq> p xj"
       by metis
     then have "p' i \<noteq> p' j"
       unfolding p'
       by (metis "*" "**" \<open>xi \<in> X\<close> \<open>xj \<in> X\<close> as_list_helper_props(1) assms(1) assms(3) infinite_super)
     then show "p' i \<inter> p' j = {}"
       using assms(5)
       by (metis "*" "**" \<open>xi \<in> X\<close> \<open>xj \<in> X\<close> as_list_helper_props(1) assms(1) assms(3) finite_subset p') 
   qed
   moreover have "card (p ` X) = Suc l" 
   proof -
     have "\<And> i . i \<in> {..l} \<Longrightarrow> p' i \<noteq> {}"
       using p1 assms (4)
       by (metis imageE imageI) 
     then show ?thesis 
       unfolding p1[symmetric] 
       by (metis atMost_iff card_atMost card_union_of_distinct finite_atMost p2) 
   qed
   ultimately show ?thesis
     using that[of p' l]
     by blast
 qed
 
 lemma take_diff :
   assumes "i \<le> length xs"
   and     "j \<le> length xs"
   and     "i \<noteq> j"
 shows "take i xs \<noteq> take j xs"
   by (metis assms(1) assms(2) assms(3) length_take min.commute min.order_iff)
 
 lemma image_inj_card_helper :
   assumes "finite X"
   and     "\<And> a b . a \<in> X \<Longrightarrow> b \<in> X \<Longrightarrow> a \<noteq> b \<Longrightarrow> f a \<noteq> f b"
 shows "card (f ` X) = card X"
 using assms proof (induction X)
   case empty
   then show ?case by auto
 next
   case (insert x X)
   then have "f x \<notin> f ` X"
     by (metis imageE insertCI) 
   then have "card (f ` (insert x X)) = Suc (card X)"
     using insert.IH insert.hyps(1) insert.prems by auto
   moreover have "card (insert x X) = Suc (card X)"
     by (meson card_insert_if insert.hyps(1) insert.hyps(2))  
   ultimately show ?case 
     by auto
 qed
 
 
 lemma sum_image_inj_card_helper :
   fixes l :: nat
   assumes "\<And> i . i \<le> l \<Longrightarrow> finite (I i)"
   and     "\<And> i j . i \<le> l \<Longrightarrow> j \<le> l \<Longrightarrow> i \<noteq> j \<Longrightarrow> I i \<inter> I j = {}"
 shows "(\<Sum> i \<in> {..l} . (card (I i))) = card (\<Union> i \<in> {..l} . I i)" 
   using assms proof (induction l)
 case 0
   then show ?case by auto
 next
   case (Suc l)
   then have "(\<Sum>i\<le>l. card (I i)) = card (\<Union> (I ` {..l}))"
     using le_Suc_eq by presburger
   moreover have "(\<Sum>i\<le>Suc l. card (I i)) = card (I (Suc l)) + (\<Sum>i\<le>l. card (I i))"
     by auto
   moreover have "card (\<Union> (I ` {..Suc l})) = card (I (Suc l)) + card (\<Union> (I ` {..l}))"
     using Suc.prems(2)
     by (simp add: Suc.prems(1) card_UN_disjoint) 
   ultimately show ?case 
     by auto
 qed
 
 lemma Min_elem : "finite (xs :: 'a set) \<Longrightarrow> xs \<noteq> {} \<Longrightarrow> \<exists> x \<in> xs . Min (image (f :: 'a \<Rightarrow> nat) xs) = f x"
   by (metis (mono_tags, opaque_lifting) Min_in empty_is_image finite_imageI imageE)
 
 lemma finite_subset_mapping_limit :
   fixes f :: "nat \<Rightarrow> 'a set"
   assumes "finite (f 0)"
   and     "\<And> i j . i \<le> j \<Longrightarrow> f j \<subseteq> f i"
 obtains k where "\<And> k' . k \<le> k' \<Longrightarrow> f k' = f k"  
 proof (cases "f 0 = {}")
   case True
   then show ?thesis
     using assms(2) that by fastforce 
 next
   case False
   then have "(f ` UNIV) \<noteq> {}"
     by auto
 
   have "\<exists> k . \<forall> k' . k \<le> k' \<longrightarrow> f k' = f k"
   proof (rule ccontr)
     assume "\<nexists>k. \<forall>k'\<ge>k. f k' = f k"
     then have "\<And> k . \<exists> k' . k' > k \<and> f k' \<subset> f k"
       using assms(2)
       by (metis dual_order.order_iff_strict)
 
     have "f ` UNIV \<subseteq> Pow (f 0)"
       using assms(2)
       by (simp add: image_subset_iff) 
     moreover have "finite (Pow (f 0))"
       using assms(1) by simp
     ultimately have "finite (f ` UNIV)"
       using finite_subset by auto
 
 
     obtain x where "x \<in> f ` UNIV" and "\<And> x' . x' \<in> f ` UNIV \<Longrightarrow> card x \<le> card x'"
       using Min_elem[OF \<open>finite (f ` UNIV)\<close> \<open>(f ` UNIV) \<noteq> {}\<close>, of card]
       by (metis (mono_tags, lifting) Min.boundedE \<open>finite (range f)\<close> \<open>range f \<noteq> {}\<close> ball_imageD finite_imageI image_is_empty order_refl)  
 
     obtain k where "f k = x"
       using \<open>x \<in> f ` UNIV\<close> by blast 
     then obtain k' where "f k' \<subset> x"
       using \<open>\<And> k . \<exists> k' . k' > k \<and> f k' \<subset> f k\<close> by blast 
     moreover have "\<And> k . finite (f k)"
       by (meson assms(1) assms(2) infinite_super le0) 
     ultimately have "card (f k') < card x"
       using \<open>f k = x\<close> by (metis psubset_card_mono)  
     then show "False"
       using \<open>\<And> x' . x' \<in> f ` UNIV \<Longrightarrow> card x \<le> card x'\<close>
       by (simp add: less_le_not_le) 
   qed
   then show ?thesis 
     using that by blast
 qed
 
 lemma finite_card_less_witnesses :
   assumes "finite A"
   and     "card (g ` A) < card (f ` A)" 
 obtains a b where "a \<in> A" and "b \<in> A" and "f a \<noteq> f b" and "g a = g b" 
 proof -
   have "\<exists> a b . a \<in> A \<and> b \<in> A \<and> f a \<noteq> f b \<and> g a = g b"
     using assms proof (induction A)
     case empty
     then show ?case by auto
   next
     case (insert x F)
     show ?case proof (cases "card (g ` F) < card (f ` F)")
       case True
       then show ?thesis using insert.IH by blast
     next
       case False 
 
       have "finite (g ` F)" and "finite (f ` F)"
         using insert.hyps(1) by auto
       have "card (g ` insert x F) = (if g x \<in> g ` F then card (g ` F) else Suc (card (g ` F)))"
         using card_insert_if[OF \<open>finite (g ` F)\<close>]
         by simp 
       moreover have "card (f ` insert x F) = (if f x \<in> f ` F then card (f ` F) else Suc (card (f ` F)))"
         using card_insert_if[OF \<open>finite (f ` F)\<close>]
         by simp
       ultimately have "card (g ` F) = card (f ` F)"
         using insert.prems False
         by (metis Suc_lessD not_less_less_Suc_eq) 
       then have "card (g ` insert x F) = card (g ` F)"
         using insert.prems
         by (metis Suc_lessD \<open>card (f ` insert x F) = (if f x \<in> f ` F then card (f ` F) else Suc (card (f ` F)))\<close> \<open>card (g ` insert x F) = (if g x \<in> g ` F then card (g ` F) else Suc (card (g ` F)))\<close> less_not_refl3) 
 
       then obtain y where "y \<in> F" and "g x = g y"
         using \<open>finite F\<close>
         by (metis \<open>card (g ` insert x F) = (if g x \<in> g ` F then card (g ` F) else Suc (card (g ` F)))\<close> imageE lessI less_irrefl_nat)
 
       have "card (f ` insert x F) > card (f ` F)"
         using \<open>card (g ` F) = card (f ` F)\<close> \<open>card (g ` insert x F) = card (g ` F)\<close> insert.prems by presburger
       then have "f x \<noteq> f y"
         using \<open>y \<in> F\<close>
         by (metis \<open>card (f ` insert x F) = (if f x \<in> f ` F then card (f ` F) else Suc (card (f ` F)))\<close> image_eqI less_irrefl_nat) 
 
       then show ?thesis
         using \<open>y \<in> F\<close> \<open>g x = g y\<close> by blast
     qed
   qed
   then show ?thesis
     using that by blast
 qed
 
 lemma monotone_function_with_limit_witness_helper :
   fixes f :: "nat \<Rightarrow> nat"
   assumes "\<And> i j . i \<le> j \<Longrightarrow> f i \<le> f j"
   and     "\<And> i j m . i < j \<Longrightarrow> f i = f j \<Longrightarrow> j \<le> m \<Longrightarrow> f i = f m"
   and     "\<And> i . f i \<le> k"
 obtains x where "f (Suc x) = f x" and "x \<le> k - f 0"
 proof -
   have "\<And> i . f (Suc i) \<ge> f 0 + Suc i \<or> (f (Suc i) < f 0 + Suc i \<and> f i = f (Suc i))"
   proof -
     fix i 
     show "f (Suc i) \<ge> f 0 + Suc i \<or> (f (Suc i) < f 0 + Suc i \<and> f i = f (Suc i))"
     proof (induction i)
       case 0
       then show ?case using assms(1)
         by (metis add.commute add.left_neutral add_Suc_shift le0 le_antisym lessI not_less_eq_eq) 
     next
       case (Suc i)
       then show ?case
       proof -
         have "\<forall>n. n \<le> Suc n"
           by simp
         then show ?thesis
           by (metis Suc add_Suc_right assms(1) assms(2) le_antisym not_less not_less_eq_eq order_trans_rules(23))
       qed        
     qed
   qed
 
   have "\<exists> x . f (Suc x) = f x \<and> x \<le> k - f 0"
   using assms(3) proof (induction k)
     case 0
     then show ?case by auto
   next
     case (Suc k)
     
     consider "f 0 + Suc k \<le> f (Suc k)" | "f (Suc k) < f 0 + Suc k \<and> f k = f (Suc k)"
       using \<open>\<And> i . f (Suc i) \<ge> f 0 + Suc i \<or> (f (Suc i) < f 0 + Suc i \<and> f i = f (Suc i))\<close>[of k]  
       by blast
 
     then show ?case proof cases
       case 1
       then have "f (Suc (Suc k)) = f (Suc k)"
         using Suc.prems[of "Suc (Suc k)"] assms(1)[of "Suc k" "Suc (Suc k)"]
         by auto
       then show ?thesis
         by (metis "1" Suc.prems add.commute add_diff_cancel_left' add_increasing2 le_add2 le_add_same_cancel2 le_antisym) 
     next
       case 2
       then have "f (Suc k) < f 0 + Suc k" and "f k = f (Suc k)"
         by auto
       then show ?thesis
         by (metis Suc.prems \<open>\<And>i. f 0 + Suc i \<le> f (Suc i) \<or> f (Suc i) < f 0 + Suc i \<and> f i = f (Suc i)\<close> add_Suc_right add_diff_cancel_left' le0 le_Suc_ex nat_arith.rule0 not_less_eq_eq)
     qed
   qed
 
   then show ?thesis 
     using that by blast
 qed
 
 lemma different_lists_shared_prefix :
   assumes "xs \<noteq> xs'"
 obtains i where "take i xs = take i xs'" 
             and "take (Suc i) xs \<noteq> take (Suc i) xs'"
 proof -
   have "\<exists> i . take i xs = take i xs' \<and> take (Suc i) xs \<noteq> take (Suc i) xs'"
   proof (rule ccontr)
     assume "\<nexists>i. take i xs = take i xs' \<and> take (Suc i) xs \<noteq> take (Suc i) xs'"
     
     have "\<And> i . take i xs = take i xs'"
     proof -
       fix i show "take i xs = take i xs'" 
       proof (induction i)
         case 0
         then show ?case by auto
       next
         case (Suc i)
         then show ?case 
           using \<open>\<nexists>i. take i xs = take i xs' \<and> take (Suc i) xs \<noteq> take (Suc i) xs'\<close> by blast
       qed 
     qed
     
     have "xs = xs'"
       by (simp add: \<open>\<And>i. take i xs = take i xs'\<close> take_equalityI) 
     then show "False"
       using assms by simp
   qed
   then show ?thesis using that by blast
 qed
 
 lemma foldr_funion_fempty : "foldr (|\<union>|) xs fempty = ffUnion (fset_of_list xs)"
   by (induction xs; auto)
 
 lemma foldr_funion_fsingleton : "foldr (|\<union>|) xs x = ffUnion (fset_of_list (x#xs))"
   by (induction xs; auto)
 
 lemma foldl_funion_fempty : "foldl (|\<union>|) fempty xs = ffUnion (fset_of_list xs)"
   by (induction xs rule: rev_induct; auto)
 
 lemma foldl_funion_fsingleton : "foldl (|\<union>|) x xs = ffUnion (fset_of_list (x#xs))"
   by (induction xs rule: rev_induct; auto)
 
 lemma ffUnion_fmember_ob : "x |\<in>| ffUnion XS \<Longrightarrow> \<exists> X . X |\<in>| XS \<and> x |\<in>| X"
   by (induction XS; auto)
 
 
 lemma filter_not_all_length :
   "filter P xs \<noteq> [] \<Longrightarrow> length (filter (\<lambda> x . \<not> P x) xs) < length xs"
   by (metis filter_False length_filter_less)
 
 lemma foldr_funion_fmember : "B |\<subseteq>| (foldr (|\<union>|) A B)"
   by (induction A; auto)
 
 lemma prefix_free_set_maximal_list_ob :
   assumes "finite xs"
   and     "x \<in> xs"
 obtains x' where "x@x' \<in> xs" and "\<nexists> y' . y' \<noteq> [] \<and> (x@x')@y' \<in> xs" 
 proof -
 
   let ?xs = "{x' . x@x' \<in> xs}"
   let ?x' = "arg_max length (\<lambda> x . x \<in> ?xs)"
 
  
   have "\<And>y. y \<in> ?xs \<Longrightarrow> length y < Suc (Max (length ` xs))"
   proof -
     fix y assume "y \<in> ?xs"
     then have "x@y \<in> xs"
       by blast
     moreover have "\<And>y. y \<in> xs \<Longrightarrow> length y < Suc (Max (length ` xs))"
       using assms(1)
       by (simp add: le_imp_less_Suc) 
     ultimately show "length y < Suc (Max (length ` xs))"
       by fastforce 
   qed
   moreover have "[] \<in> ?xs"
     using assms(2) by auto
   ultimately have "?x' \<in> ?xs" and "(\<forall> x' . x' \<in> ?xs \<longrightarrow> length x' \<le> length ?x')"
     using arg_max_nat_lemma[of "(\<lambda> x . x \<in> ?xs)" "[]" length "Suc (Max (length ` xs))"]
     by blast+     
   
   have "\<nexists> y' . y' \<noteq> [] \<and> (x@?x')@y' \<in> xs"
   proof 
     assume "\<exists> y' . y' \<noteq> [] \<and> (x@?x')@y' \<in> xs"
     then obtain y' where "y' \<noteq> [] \<and> x@(?x'@y')\<in> xs"
       by auto
     then have "(?x'@y') \<in> ?xs" and "length (?x'@y') > length ?x'" 
       by auto
     then show False
       using \<open>(\<forall> x' . x' \<in> ?xs \<longrightarrow> length x' \<le> length ?x')\<close>
       by auto
   qed
 
   then show ?thesis
     using that using \<open>?x' \<in> ?xs\<close> by blast
 qed
 
 lemma map_upds_map_set_left :
   assumes "[map f xs [\<mapsto>] xs] q = Some x"
   shows "x \<in> set xs" and "q = f x"
 proof -
   have "x \<in> set xs \<and> q = f x"
   using assms proof (induction xs rule: rev_induct)
     case Nil
     then show ?case by auto
   next
     case (snoc x' xs)
     show ?case proof (cases "f x' = q")
       case True
       then have "x = x'"
         using snoc.prems by (induction xs; auto)
       then show ?thesis 
         using True by auto
     next
       case False
       then have "[map f (xs @ [x']) [\<mapsto>] xs @ [x']] q = [map f (xs) [\<mapsto>] xs] q" 
         by (induction xs; auto)
       then show ?thesis 
         using snoc by auto
     qed
   qed
   then show "x \<in> set xs" and "q = f x"
     by auto
 qed
 
 lemma map_upds_map_set_right :
   assumes "x \<in> set xs"
   shows "[xs [\<mapsto>] map f xs] x = Some (f x)" 
 using assms proof (induction xs rule: rev_induct)
   case Nil
   then show ?case by auto
 next
   case (snoc x' xs)
   show ?case proof (cases "x=x'")
     case True
     then show ?thesis 
       by (induction xs; auto)
   next
     case False
     then have "[xs @ [x'] [\<mapsto>] map f (xs @ [x'])] x = [xs [\<mapsto>] map f xs] x"
       by (induction xs; auto)
     then show ?thesis 
       using snoc False by auto
   qed
 qed
 
 
 lemma map_upds_overwrite :
   assumes "x \<in> set xs"
       and "length xs = length ys"
   shows "(m(xs[\<mapsto>]ys)) x = [xs[\<mapsto>]ys] x" 
   using assms(2,1) by (induction xs ys rule: rev_induct2; auto)
 
 
 lemma ran_dom_the_eq : "(\<lambda>k . the (m k)) ` dom m = ran m" 
   unfolding ran_def dom_def by force
 
 
 lemma map_pair_fst :
   "map fst (map (\<lambda>x . (x,f x)) xs) = xs"
   by (induction xs; auto)
 
 lemma map_of_map_pair_entry: "map_of (map (\<lambda>k. (k, f k)) xs) x = (if x \<in> list.set xs then Some (f x) else None)"
   by (induction xs; auto)
 
 lemma map_filter_alt_def :
   "List.map_filter f1' xs = map the (filter (\<lambda>x . x \<noteq> None) (map f1' xs))"
   by (induction xs; unfold map_filter_simps; auto)
 
 lemma map_filter_Nil :
   "List.map_filter f1' xs = [] \<longleftrightarrow> (\<forall> x \<in> list.set xs . f1' x = None)"
   unfolding map_filter_alt_def by (induction xs; auto)
 
 lemma sorted_list_of_set_set: "set ((sorted_list_of_set \<circ> set) xs) = set xs"
   by auto
 
 fun mapping_of :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" where
   "mapping_of kvs = foldl (\<lambda>m kv . Mapping.update (fst kv) (snd kv) m) Mapping.empty kvs"
 
 lemma mapping_of_map_of :
   assumes "distinct (map fst kvs)"
   shows "Mapping.lookup (mapping_of kvs) = map_of kvs"
 proof
   show "\<And>x. Mapping.lookup (mapping_of kvs) x = map_of kvs x"
     using assms
   proof (induction kvs rule: rev_induct)
     case Nil
     then show ?case by auto
   next
     case (snoc xy xs)
 
     have *:"map_of (xs @ [xy]) = map_of (xy#xs)"
       using snoc.prems map_of_inject_set[of "xs @ [xy]" "xy#xs", OF snoc.prems]
       by simp 
 
     show ?case 
       using snoc unfolding *
       by (cases "x = fst xy"; auto)
   qed
 qed
 
 
 lemma map_pair_fst_helper :
   "map fst (map (\<lambda> (x1,x2) . ((x1,x2), f x1 x2)) xs) = xs"
   using map_pair_fst[of "\<lambda> (x1,x2) . f x1 x2" xs]
   by (metis (no_types, lifting) map_eq_conv prod.collapse split_beta) 
 
 end
\ No newline at end of file
diff --git a/thys/Falling_Factorial_Sum/Falling_Factorial_Sum_Combinatorics.thy b/thys/Falling_Factorial_Sum/Falling_Factorial_Sum_Combinatorics.thy
--- a/thys/Falling_Factorial_Sum/Falling_Factorial_Sum_Combinatorics.thy
+++ b/thys/Falling_Factorial_Sum/Falling_Factorial_Sum_Combinatorics.thy
@@ -1,356 +1,359 @@
 (*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)
 
 section \<open>Proving Falling Factorial of a Sum with Combinatorics\<close>
 
 theory Falling_Factorial_Sum_Combinatorics
 imports
   Discrete_Summation.Factorials
   Card_Partitions.Injectivity_Solver
 begin
 
 subsection \<open>Preliminaries\<close>
 
 subsubsection \<open>Addition to Factorials Theory\<close>
 
 lemma card_lists_distinct_length_eq:
   assumes "finite A"
   shows "card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = ffact n (card A)"
 proof cases
   assume "n \<le> card A"
   have "card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - n + 1..card A}"
     using \<open>finite A\<close> \<open>n \<le> card A\<close> by (rule card_lists_distinct_length_eq)
   also have "\<dots> = ffact n (card A)"
     using \<open>n \<le> card A\<close> by (simp add: prod_rev_ffact_nat'[symmetric])
   finally show ?thesis .
 next
   assume "\<not> n \<le> card A"
   from this \<open>finite A\<close> have "\<forall>xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A \<longrightarrow> False"
     by (metis card_mono distinct_card)
   from this have eq_empty: "{xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A} = {}"
     using \<open>finite A\<close> by auto
   from \<open>\<not> n \<le> card A\<close> show ?thesis
     by (simp add: ffact_nat_triv eq_empty)
 qed
 
 subsection \<open>Interleavings of Two Lists\<close>
 
 inductive interleavings :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "interleavings [] ys ys"
 | "interleavings xs [] xs"
 | "interleavings xs ys zs \<Longrightarrow> interleavings (x#xs) ys (x#zs)"
 | "interleavings xs ys zs \<Longrightarrow> interleavings xs (y#ys) (y#zs)"
 
 lemma interleaving_Nil_implies_eq1:
   assumes "interleavings xs ys zs"
   assumes "xs = []"
   shows "ys = zs"
 using assms by (induct rule: interleavings.induct) auto
 
 lemma interleaving_Nil_iff1:
   "interleavings [] ys zs \<longleftrightarrow> (ys = zs)"
 using interleaving_Nil_implies_eq1
 by (auto simp add: interleavings.intros(1))
 
 lemma interleaving_Nil_implies_eq2:
   assumes "interleavings xs ys zs"
   assumes "ys = []"
   shows "xs = zs"
 using assms by (induct rule: interleavings.induct) auto
 
 lemma interleaving_Nil_iff2:
   "interleavings xs [] zs \<longleftrightarrow> (xs = zs)"
 using interleaving_Nil_implies_eq2
 by (auto simp add: interleavings.intros(2))
 
 lemma interleavings_Cons:
   "{zs. interleavings (x#xs) (y#ys) zs} =
     {x#zs|zs. interleavings xs (y#ys) zs} \<union> {y#zs|zs. interleavings (x#xs) ys zs}"
   (is "?S = ?expr")
 proof
   show "?S \<subseteq> ?expr"
     by (auto elim: interleavings.cases)
 next
   show "?expr \<subseteq> ?S"
     by (auto intro: interleavings.intros)
 qed
 
 lemma interleavings_filter:
   assumes "X \<inter> Y = {}" "set zs \<subseteq> X \<union> Y"
   shows "interleavings [z\<leftarrow>zs . z \<in> X] [z\<leftarrow>zs . z \<in> Y] zs"
 using assms by (induct zs) (auto intro: interleavings.intros)
 
 lemma interleavings_filter_eq1:
   assumes "interleavings xs ys zs"
   assumes "(\<forall>x\<in>set xs. P x) \<and> (\<forall>y\<in>set ys. \<not> P y)"
   shows "filter P zs = xs"
 using assms by (induct rule: interleavings.induct) auto
 
 lemma interleavings_filter_eq2:
   assumes "interleavings xs ys zs"
   assumes "(\<forall>x\<in>set xs. \<not> P x) \<and> (\<forall>y\<in>set ys. P y)"
   shows "filter P zs = ys"
 using assms by (induct rule: interleavings.induct) auto
 
 lemma interleavings_length:
   assumes "interleavings xs ys zs"
   shows "length xs + length ys = length zs"
 using assms by (induct xs ys zs rule: interleavings.induct) auto
 
 lemma interleavings_set:
   assumes "interleavings xs ys zs"
   shows "set xs \<union> set ys = set zs"
 using assms by (induct xs ys zs rule: interleavings.induct) auto
 
 lemma interleavings_distinct:
   assumes "interleavings xs ys zs"
   shows "distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {} \<longleftrightarrow> distinct zs"
 using assms interleavings_set by (induct xs ys zs rule: interleavings.induct) fastforce+
 
 lemma two_mutual_lists_induction:
   assumes "\<And>ys. P [] ys"
   assumes "\<And>xs. P xs []"
   assumes "\<And>x xs y ys. P xs (y#ys) \<Longrightarrow> P (x#xs) ys \<Longrightarrow> P (x#xs) (y#ys)"
   shows "P xs ys"
 using assms by (induction_schema) (pat_completeness, lexicographic_order)
 
 lemma finite_interleavings:
   "finite {zs. interleavings xs ys zs}"
 proof (induct xs ys rule: two_mutual_lists_induction)
   case (1 ys)
   show ?case by (simp add: interleaving_Nil_iff1)
 next
   case (2 xs)
   then show ?case by (simp add: interleaving_Nil_iff2)
 next
   case (3 x xs y ys)
   then show ?case by (simp add: interleavings_Cons)
 qed
 
 lemma card_interleavings:
   assumes "set xs \<inter> set ys = {}"
   shows "card {zs. interleavings xs ys zs} = (length xs + length ys choose (length xs))"
 using assms
 proof (induct xs ys rule: two_mutual_lists_induction)
   case (1 ys)
   have "card {zs. interleavings [] ys zs} = card {ys}"
     by (simp add: interleaving_Nil_iff1)
   also have "\<dots> = (length [] + length ys choose (length []))" by simp
   finally show ?case .
 next
   case (2 xs)
   have "card {zs. interleavings xs [] zs} = card {xs}"
     by (simp add: interleaving_Nil_iff2)
   also have "\<dots> = (length xs + length [] choose (length xs))" by simp
   finally show ?case .
 next
   case (3 x xs y ys)
   have "card {zs. interleavings (x # xs) (y # ys) zs} =
     card ({x#zs|zs. interleavings xs (y#ys) zs} \<union> {y#zs|zs. interleavings (x#xs) ys zs})"
     by (simp add: interleavings_Cons)
   also have "\<dots> = card {x#zs|zs. interleavings xs (y#ys) zs} + card {y#zs|zs. interleavings (x#xs) ys zs}"
   proof -
     have "finite {x # zs |zs. interleavings xs (y # ys) zs}"
       by (simp add: finite_interleavings)
     moreover have "finite {y # zs |zs. interleavings (x # xs) ys zs}"
       by (simp add: finite_interleavings)
     moreover have "{x # zs |zs. interleavings xs (y # ys) zs} \<inter> {y # zs |zs. interleavings (x # xs) ys zs} = {}"
       using \<open>set (x # xs) \<inter> set (y # ys) = {}\<close> by auto
     ultimately show ?thesis by (simp add: card_Un_disjoint)
   qed
   also have "\<dots> = card ((\<lambda>zs. x # zs) ` {zs. interleavings xs (y # ys) zs}) +
     card ((\<lambda>zs. y # zs) ` {zs. interleavings (x#xs) ys zs})"
     by (simp add: setcompr_eq_image)
   also have "\<dots> = card {zs. interleavings xs (y # ys) zs} + card {zs. interleavings (x#xs) ys zs}"
     by (simp add: card_image)
   also have "\<dots> = (length xs + length (y # ys) choose length xs) + (length (x # xs) + length ys choose length (x # xs))"
     using 3 by simp
   also have "\<dots> = length (x # xs) + length (y # ys) choose length (x # xs)" by simp
   finally show ?case .
 qed
 
 subsection \<open>Cardinality of Distinct Fixed-Length Lists from a Union of Two Sets\<close>
 
 lemma lists_distinct_union_by_interleavings:
   assumes "X \<inter> Y = {}"
   shows "{zs. length zs = n \<and> distinct zs \<and> set zs \<subseteq> X \<union> Y} = do {
     k \<leftarrow> {0..n};
     xs \<leftarrow> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X};
     ys \<leftarrow> {ys. length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y};
     {zs. interleavings xs ys zs}
   }" (is "?S = ?expr")
 proof
   show "?S \<subseteq> ?expr"
   proof
     fix zs
     assume "zs \<in> ?S"
     from this have "length zs = n" and "distinct zs" and "set zs \<subseteq> X \<union> Y" by auto
     define xs where "xs = filter (\<lambda>z. z \<in> X) zs"
     define ys where "ys = filter (\<lambda>z. z \<in> Y) zs"
     have eq: "[z\<leftarrow>zs . z \<in> Y] = [z\<leftarrow>zs . z \<notin> X]"
       using \<open>set zs \<subseteq> X \<union> Y\<close> \<open>X \<inter> Y = {}\<close>
       by (auto intro: filter_cong)
     have "length xs \<le> n \<and> distinct xs \<and> set xs \<subseteq> X"
       using \<open>length zs = n\<close> \<open>distinct zs\<close> unfolding xs_def by auto
     moreover have "length ys = n - length xs"
       using \<open>set zs \<subseteq> X \<union> Y\<close> \<open>length zs = n\<close>
       unfolding xs_def ys_def eq
       by (metis diff_add_inverse sum_length_filter_compl)
     moreover have "distinct ys \<and> set ys \<subseteq> Y"
       using \<open>distinct zs\<close> unfolding ys_def by auto
     moreover have "interleavings xs ys zs"
       using xs_def ys_def \<open>X \<inter> Y = {}\<close> \<open>set zs \<subseteq> X \<union> Y\<close>
       by (simp add: interleavings_filter)
     ultimately show "zs \<in> ?expr" by force
   qed
 next
   show "?expr \<subseteq> ?S"
   proof
     fix zs
     assume "zs \<in> ?expr"
     from this obtain xs ys where "length xs \<le> n" "distinct xs" "set xs \<subseteq> X"
       and "length ys = n - length xs" "distinct ys" "set ys \<subseteq> Y" "interleavings xs ys zs" by auto
     have "length zs = n"
       using \<open>length xs \<le> n\<close> \<open>length ys = n - length xs\<close> \<open>interleavings xs ys zs\<close>
       using interleavings_length by force
     moreover have "distinct zs"
       using \<open>distinct xs\<close> \<open>distinct ys\<close> \<open>interleavings xs ys zs\<close> \<open>set xs \<subseteq> X\<close> \<open>set ys \<subseteq> Y\<close>
       using \<open>X \<inter> Y = {}\<close> interleavings_distinct by fastforce
     moreover have "set zs \<subseteq> X \<union> Y"
       using \<open>interleavings xs ys zs\<close> \<open>set xs \<subseteq> X\<close> \<open>set ys \<subseteq> Y\<close> interleavings_set by blast
     ultimately show "zs \<in> ?S" by blast
   qed
 qed
 
 lemma interleavings_inject:
   assumes "(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}"
   assumes "interleavings xs ys zs" "interleavings xs' ys' zs'"
   assumes "zs = zs'"
   shows "xs = xs'" and "ys = ys'"
 proof -
   have "xs = filter (\<lambda>z. z \<in> set xs \<union> set xs') zs"
     using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs ys zs\<close>
     by (auto intro: interleavings_filter_eq1[symmetric])
   also have "\<dots> = filter (\<lambda>z. z \<in> set xs \<union> set xs') zs'"
     using \<open>zs = zs'\<close> by simp
   also have "\<dots> = xs'"
     using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs' ys' zs'\<close>
     by (auto intro: interleavings_filter_eq1)
   finally show "xs = xs'" by simp
   have "ys = filter (\<lambda>z. z \<in> set ys \<union> set ys') zs"
     using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs ys zs\<close>
     by (auto intro: interleavings_filter_eq2[symmetric])
   also have "\<dots> = filter (\<lambda>z. z \<in> set ys \<union> set ys') zs'"
     using \<open>zs = zs'\<close> by simp
   also have "\<dots> = ys'"
     using \<open>(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}\<close> \<open>interleavings xs' ys' zs'\<close>
     by (auto intro: interleavings_filter_eq2)
   finally show "ys = ys'" .
 qed
 
 lemma injectivity:
   assumes "X \<inter> Y = {}"
   assumes "k \<in> {0..n} \<and> k' \<in> {0..n}"
   assumes "(length xs = k \<and> distinct xs \<and> set xs \<subseteq> X) \<and> (length xs' = k' \<and> distinct xs' \<and> set xs' \<subseteq> X)"
   assumes "(length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y) \<and> (length ys' = n - k' \<and> distinct ys' \<and> set ys' \<subseteq> Y)"
   assumes "interleavings xs ys zs \<and> interleavings xs' ys' zs'"
   assumes "zs = zs'"
   shows "k = k'" and "xs = xs'" and "ys = ys'"
 proof -
   from assms(1,3,4) have "(set xs \<union> set xs') \<inter> (set ys \<union> set ys') = {}" by blast
   from this assms(5) \<open>zs = zs'\<close> show "xs = xs'" and "ys = ys'"
     using interleavings_inject by fastforce+
   from this assms(3) show "k = k'" by auto
 qed
 
+lemma finite_length_distinct: "finite X \<Longrightarrow>  finite {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X}"
+by(fast elim: rev_finite_subset[OF finite_subset_distinct])
+
 lemma card_lists_distinct_length_eq_union:
   assumes "finite X" "finite Y" "X \<inter> Y = {}"
   shows "card {zs. length zs = n \<and> distinct zs \<and> set zs \<subseteq> X \<union> Y} =
     (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
   (is "card ?S = _")
 proof -
   let ?expr = "do {
     k \<leftarrow> {0..n};
     xs \<leftarrow> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X};
     ys \<leftarrow> {ys. length ys = n - k \<and> distinct ys \<and> set ys \<subseteq> Y};
     {zs. interleavings xs ys zs}
   }"
   from \<open>X \<inter> Y = {}\<close> have "card ?S = card ?expr"
     by (simp add: lists_distinct_union_by_interleavings)
   let "?S \<bind> ?comp" = "?expr"
   {
     fix k
     assume "k \<in> ?S"
     let "?expr" = "?comp k"
     let "?S \<bind> ?comp" = "?expr"
-    from \<open>finite X\<close> have "finite ?S" by auto
+    from \<open>finite X\<close> have "finite ?S" by(rule finite_length_distinct)
     moreover {
       fix xs
       assume xs: "xs \<in> ?S"
       let ?expr = "?comp xs"
       let "?S \<bind> ?comp" = ?expr
-      from \<open>finite Y\<close> have "finite ?S" by auto
+      from \<open>finite Y\<close> have "finite ?S" by(rule finite_length_distinct)
       moreover {
         fix ys
         assume ys: "ys \<in> ?S"
         let ?expr = "?comp ys"
         have "finite ?expr"
           by (simp add: finite_interleavings)
         moreover have "card ?expr = (n choose k)"
           using xs ys \<open>X \<inter> Y = {}\<close> \<open>k \<in> _\<close>
           by (subst card_interleavings) auto
         ultimately have "finite ?expr \<and> card ?expr = (n choose k)" ..
       }
       moreover have "disjoint_family_on ?comp ?S"
         using \<open>k \<in> {0..n}\<close> \<open>xs \<in> {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> X}\<close>
         by (injectivity_solver rule: injectivity(3)[OF \<open>X \<inter> Y = {}\<close>])
       moreover have "card ?S = ffact (n - k) (card Y)"
         using \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq)
       ultimately have "card ?expr = (n choose k) * ffact (n - k) (card Y)"
         by (subst card_bind_constant) auto
       moreover have "finite ?expr"
         using \<open>finite ?S\<close> by (auto intro!: finite_bind finite_interleavings)
       ultimately have "finite ?expr \<and> card ?expr = (n choose k) * ffact (n - k) (card Y)"
         by blast
     }
     moreover have "disjoint_family_on ?comp ?S"
       using \<open>k \<in> {0..n}\<close>
       by (injectivity_solver rule: injectivity(2)[OF \<open>X \<inter> Y = {}\<close>])
     moreover have "card ?S = ffact k (card X)"
       using \<open>finite X\<close> by (simp add: card_lists_distinct_length_eq)
     ultimately have "card ?expr = (n choose k) * ffact k (card X) * ffact (n - k) (card Y)"
       by (subst card_bind_constant) auto
     moreover have "finite ?expr"
-      using \<open>finite ?S\<close> \<open>finite Y\<close> by (auto intro!: finite_bind finite_interleavings)
+      using \<open>finite ?S\<close> \<open>finite Y\<close> by (auto intro!: finite_bind finite_interleavings finite_length_distinct)
     ultimately have "finite ?expr \<and> card ?expr = (n choose k) * ffact k (card X) * ffact (n - k) (card Y)"
       by blast
   }
   moreover have "disjoint_family_on ?comp ?S"
     by (injectivity_solver rule: injectivity(1)[OF \<open>X \<inter> Y = {}\<close>])
   ultimately have "card ?expr = (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
     by (auto simp add: card_bind)
   from \<open>card _ = card ?expr\<close> this show ?thesis by simp
 qed
 
 lemma
   "ffact n (x + y) = (\<Sum>k=0..n. (n choose k) * ffact k x * ffact (n - k) y)"
 proof -
   define X where "X = {..<x}"
   define Y where "Y = {x..<x+y}"
   have "finite X" and "card X = x" unfolding X_def by auto
   have "finite Y" and "card Y = y" unfolding Y_def by auto
   have "X \<inter> Y = {}" unfolding X_def Y_def by auto
   have "ffact n (x + y) = ffact n (card X + card Y)"
     using \<open>card X = x\<close> \<open>card Y = y\<close> by simp
   also have "\<dots> = ffact n (card (X \<union> Y))"
     using \<open>X \<inter> Y = {}\<close> \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_Un_disjoint)
   also have "\<dots> = card {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> X \<union> Y}"
    using \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq)
   also have "\<dots> = (\<Sum>k=0..n. (n choose k) * ffact k (card X) * ffact (n - k) (card Y))"
     using \<open>X \<inter> Y = {}\<close> \<open>finite X\<close> \<open>finite Y\<close> by (simp add: card_lists_distinct_length_eq_union)
   also have "\<dots> = (\<Sum>k=0..n. (n choose k) * ffact k x * ffact (n - k) y)"
     using \<open>card X = x\<close> \<open>card Y = y\<close> by simp
   finally show ?thesis .
 qed
 
 end
diff --git a/thys/Finite_Fields/Card_Irreducible_Polynomials.thy b/thys/Finite_Fields/Card_Irreducible_Polynomials.thy
--- a/thys/Finite_Fields/Card_Irreducible_Polynomials.thy
+++ b/thys/Finite_Fields/Card_Irreducible_Polynomials.thy
@@ -1,231 +1,235 @@
 subsection \<open>Gauss Formula\label{sec:card_irred}\<close>
 
 theory Card_Irreducible_Polynomials
   imports
     Dirichlet_Series.Moebius_Mu
     Card_Irreducible_Polynomials_Aux
 begin
 
 hide_const "Polynomial.order"
 
 text \<open>The following theorem is a slightly generalized form of the formula discovered by
 Gauss for the number of monic irreducible polynomials over a finite field. He originally verified
 the result for the case when @{term "R"} is a simple prime field.
 The version of the formula here for the case where @{term "R"} may be an arbitrary finite field can
 be found in Chebolu and Min{\'a}{\v{c}}~\<^cite>\<open>"chebolu2010"\<close>.\<close>
 
 theorem (in finite_field) card_irred:
   assumes "n > 0"
   shows "n * card {f. monic_irreducible_poly R f \<and> degree f = n} =
     (\<Sum>d | d dvd n. moebius_mu d * (order R^(n div d)))"
     (is "?lhs = ?rhs")
 proof -
   have "?lhs = dirichlet_prod moebius_mu (\<lambda>x. int (order R) ^ x) n"
     using card_irred_aux
     by (intro moebius_inversion assms) (simp flip:of_nat_power)
   also have "... = ?rhs"
     by (simp add:dirichlet_prod_def)
   finally show ?thesis by simp
 qed
 
 text \<open>In the following an explicit analytic lower bound for the cardinality of monic irreducible
 polynomials is shown, with which existence follows. This part deviates from the classic approach,
 where existence is verified using a divisibility argument. The reason for the deviation is that an
 analytic bound can also be used to estimate the runtime of a randomized algorithm selecting an
 irreducible polynomial, by randomly sampling monic polynomials.\<close>
 
 lemma (in finite_field) card_irred_1:
   "card {f. monic_irreducible_poly R f \<and> degree f = 1} = order R"
 proof -
   have "int (1 * card {f. monic_irreducible_poly R f \<and> degree f = 1})
     = int (order R)"
     by (subst card_irred, auto)
   thus ?thesis by simp
 qed
 
 lemma (in finite_field) card_irred_2:
   "real (card {f. monic_irreducible_poly R f \<and> degree f = 2}) =
     (real (order R)^2 - order R) / 2"
 proof -
   have "x dvd 2 \<Longrightarrow> x = 1 \<or> x = 2" for x :: nat
     using nat_dvd_not_less[where m="2"]
     by (metis One_nat_def even_zero gcd_nat.strict_trans2
         less_2_cases nat_neq_iff pos2)
   hence a: "{d. d dvd 2} = {1,2::nat}"
     by (auto simp add:set_eq_iff)
 
   have "2*real (card {f. monic_irreducible_poly R f \<and> degree f = 2})
     = of_int (2* card {f. monic_irreducible_poly R f \<and> degree f = 2})"
     by simp
   also have "... =
     of_int (\<Sum>d | d dvd 2. moebius_mu d * int (order R) ^ (2 div d))"
     by (subst card_irred, auto)
   also have "... = order R^2 - int (order R)"
     by (subst a, simp)
   also have "... = real (order R)^2 - order R"
     by simp
   finally have
     "2 * real (card {f. monic_irreducible_poly R f \<and> degree f = 2}) =
     real (order R)^2 - order R"
     by simp
   thus ?thesis by simp
 qed
 
 lemma (in finite_field) card_irred_gt_2:
   assumes "n > 2"
   shows "real (order R)^n / (2*real n) \<le>
     card {f. monic_irreducible_poly R f \<and> degree f = n}"
     (is "?lhs \<le> ?rhs")
 proof -
   let ?m = "real (order R)"
   have a:"?m \<ge> 2"
     using finite_field_min_order by simp
 
   have b:"moebius_mu n \<ge> -(1::real)" for n :: nat
     using abs_moebius_mu_le[where n="n"]
     unfolding abs_le_iff by auto
 
   have c: "n > 0" using assms by simp
   have d: "x < n - 1" if d_assms: "x dvd n" "x \<noteq> n" for x :: nat
   proof -
     have "x < n"
       using d_assms dvd_nat_bounds c by auto
     moreover have "\<not>(n-1 dvd n)" using assms
       by (metis One_nat_def Suc_diff_Suc c diff_zero
           dvd_add_triv_right_iff nat_dvd_1_iff_1
           nat_neq_iff numeral_2_eq_2 plus_1_eq_Suc)
     hence "x \<noteq> n-1" using d_assms by auto
     ultimately show "x < n-1"  by simp
   qed
 
   have "?m^n / 2 = ?m^n - ?m^n/2" by simp
   also have "... \<le> ?m^n - ?m^n/?m^1"
     using a by (intro diff_mono divide_left_mono, simp_all)
   also have "... \<le> ?m^n - ?m^(n-1)"
     using a c by (subst power_diff, simp_all)
   also have "... \<le> ?m^n - (?m^(n-1) - 1)/1" by simp
   also have "... \<le> ?m^n - (?m^(n-1)-1)/(?m-1)"
     using a by (intro diff_left_mono divide_left_mono, simp_all)
   also have "... = ?m^n - (\<Sum>i \<in> {..<n-1}. ?m^i)"
     using a by (subst geometric_sum, simp_all)
   also have "... \<le> ?m^n - (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. ?m^i)"
     using d
     by (intro diff_mono sum_mono2 subsetI, auto simp add:not_less)
   also have "... = ?m^n + (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. (-1) * ?m^i)"
     by (subst sum_distrib_left[symmetric], simp)
   also have "... \<le> moebius_mu 1 * ?m^n +
     (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. moebius_mu (n div i) * ?m^i)"
     using b
     by (intro add_mono sum_mono mult_right_mono)
       (simp_all add:not_less)
   also have "... =  (\<Sum>i \<in> insert n {k. k dvd n \<and> k \<noteq> n}.
     moebius_mu (n div i) * ?m^i)"
     using c by (subst sum.insert, auto)
   also have "... = (\<Sum>i \<in> {k. k dvd n}. moebius_mu (n div i) * ?m^i)"
     by (intro sum.cong, auto simp add:set_eq_iff)
   also have "... = dirichlet_prod (\<lambda>i. ?m^i) moebius_mu n"
     unfolding dirichlet_prod_def by (intro sum.cong, auto)
   also have "... = dirichlet_prod moebius_mu (\<lambda>i. ?m^i) n"
     using dirichlet_prod_commutes by metis
   also have "... =
     of_int (\<Sum>d | d dvd n. moebius_mu d * order R^(n div d))"
     unfolding dirichlet_prod_def by simp
   also have "... = of_int (n *
     card {f. monic_irreducible_poly R f \<and> length f - 1 = n})"
     using card_irred[OF c] by simp
   also have "... = n * ?rhs" by simp
   finally have "?m^n / 2 \<le> n * ?rhs" by simp
   hence "?m ^ n \<le> 2 * n * ?rhs" by simp
   hence "?m^n/(2*real n) \<le> ?rhs"
     using c by (subst pos_divide_le_eq, simp_all add:algebra_simps)
   thus ?thesis by simp
 qed
 
+lemma (in finite_field) card_irred_gt_0:
+  assumes "d > 0"
+  shows "real(order R)^d / (2*real d) \<le> real (card {f. monic_irreducible_poly R f \<and> degree f = d})"
+    (is "?L \<le> ?R")
+proof -
+  consider (a) "d = 1" | (b) "d = 2" | (c) "d > 2" using assms by linarith
+  thus ?thesis
+  proof (cases)
+    case a
+    hence "?L = real (order R)/2" by simp
+    also have "... \<le> real (order R)" using finite_field_min_order by simp
+    also have "... = ?R" unfolding a card_irred_1 by simp
+    finally show ?thesis by simp
+  next
+    case b
+    hence "?L = real (order R^2)/4 + 0" by simp
+    also have "... \<le> real (order R^2)/4 + real (order R)/2 * (real (order R)/2 - 1)"
+      using finite_field_min_order by (intro add_mono mult_nonneg_nonneg) auto
+    also have "... = (real (order R^2) - real (order R))/2"
+      by (simp add:algebra_simps power2_eq_square)
+    also have "... = ?R" unfolding b card_irred_2 by simp
+    finally show ?thesis by simp
+  next
+    case c thus ?thesis by (rule card_irred_gt_2)
+  qed
+qed
+
 lemma (in finite_field) exist_irred:
   assumes "n > 0"
   obtains f where "monic_irreducible_poly R f" "degree f = n"
 proof -
-  consider (i) "n = 1" | (ii) "n = 2" | (iii) "n>2"
-    using assms by linarith
-  then have
-    "card {f. monic_irreducible_poly R f \<and> degree f = n} > 0"
-    (is "card ?A > 0")
-  proof (cases)
-    case i
-    hence "card ?A = order R"
-      using card_irred_1 by simp
-    also have "... > 0"
-       using finite_field_min_order by simp
-    finally show ?thesis by simp
-  next
-    case ii
-    have "0 < (real (order R) * (real (order R) - 1)) / 2"
-      using finite_field_min_order by simp
-    also have "... = (real (order R)^2 - order R) / 2"
-      by (simp add:power2_eq_square algebra_simps)
-    also have "... = real (card ?A)"
-      using ii by (subst card_irred_2[symmetric], simp)
-    finally have " 0 < real (card ?A)" by simp
-    then show ?thesis by simp
-  next
-    case iii
-    have "0 < real (order R)^n / (2*real n)"
-      using finite_field_min_order assms by simp
-    also have "... \<le> real (card ?A)"
-      using iii card_irred_gt_2 by simp
-    finally have "0 < real (card ?A)" by simp
-    then show ?thesis by simp
-  qed
+  have "0 < real(order R)^n / (2*real n)"
+    using finite_field_min_order assms
+    by (intro divide_pos_pos mult_pos_pos zero_less_power) auto
+  also have "... \<le> real (card {f. monic_irreducible_poly R f \<and> degree f = n})"
+    (is "_ \<le> real(card ?A)")
+    by (intro card_irred_gt_0 assms)
+  finally have "0 < card {f. monic_irreducible_poly R f \<and> degree f = n}"
+    by auto
   hence "?A \<noteq> {}"
     by (metis card.empty nless_le)
   then obtain f where "monic_irreducible_poly R f" "degree f = n"
     by auto
   thus ?thesis using that by simp
 qed
 
 theorem existence:
   assumes "n > 0"
   assumes "Factorial_Ring.prime p"
   shows "\<exists>(F:: int set list set ring). finite_field F \<and> order F = p^n"
 proof -
   interpret zf: finite_field "ZFact (int p)"
     using zfact_prime_is_finite_field assms by simp
 
   interpret zfp: polynomial_ring "ZFact p" "carrier (ZFact p)"
     unfolding polynomial_ring_def polynomial_ring_axioms_def
     using zf.field_axioms zf.carrier_is_subfield by simp
 
   have p_gt_0: "p > 0" using prime_gt_0_nat assms(2) by simp
 
   obtain f where f_def:
     "monic_irreducible_poly (ZFact (int p)) f"
     "degree f = n"
     using zf.exist_irred assms by auto
 
   let ?F  = "Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f"
   have "f \<in> carrier (poly_ring (ZFact (int p)))"
     using f_def(1) zf.monic_poly_carr
     unfolding monic_irreducible_poly_def
     by simp
   moreover have "degree f > 0"
     using assms(1) f_def by simp
   ultimately have "order ?F =  card (carrier (ZFact p))^degree f"
     by (intro zf.rupture_order[OF zf.carrier_is_subfield]) auto
   hence a:"order ?F = p^n"
     unfolding f_def(2) card_zfact_carr[OF p_gt_0] by simp
 
   have "field ?F"
     using f_def(1) zf.monic_poly_carr monic_irreducible_poly_def
     by (subst zfp.rupture_is_field_iff_pirreducible) auto
   moreover have "order ?F > 0"
     unfolding a using assms(1,2) p_gt_0 by simp
   ultimately have b:"finite_field ?F"
     using card_ge_0_finite
     by (intro finite_fieldI, auto simp add:Coset.order_def)
 
   show ?thesis
     using a b
     by (intro exI[where x="?F"], simp)
 qed
 
 end
diff --git a/thys/Finite_Fields/Find_Irreducible_Poly.thy b/thys/Finite_Fields/Find_Irreducible_Poly.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Find_Irreducible_Poly.thy
@@ -0,0 +1,794 @@
+section \<open>Algorithms for finding irreducible polynomials\<close>
+
+theory Find_Irreducible_Poly
+  imports
+    Finite_Fields_Poly_Factor_Ring_Code
+    Rabin_Irreducibility_Test_Code
+    Probabilistic_While.While_SPMF
+    Card_Irreducible_Polynomials
+    Executable_Randomized_Algorithms.Randomized_Algorithm
+    "HOL-Library.Log_Nat"
+begin
+
+hide_const (open) Numeral_Type.mod_ring
+hide_const (open) Polynomial.degree
+hide_const (open) Polynomial.order
+
+text \<open>Enumeration of the monic polynomials in lexicographic order.\<close>
+
+definition enum_monic_poly :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
+  where "enum_monic_poly A d i = 1\<^sub>C\<^bsub>A\<^esub>#[ idx_enum A (nth_digit i j (idx_size A)). j \<leftarrow> rev [0..<d]]"
+
+lemma enum_monic_poly:
+  assumes "field\<^sub>C R" "enum\<^sub>C R"
+  shows "bij_betw (enum_monic_poly R d) {..<order (ring_of R)^d}
+    {f. monic_poly (ring_of R) f \<and> degree f = d}"
+proof -
+  let ?f = " (\<lambda>x. 1\<^sub>C\<^bsub>R\<^esub> # map (\<lambda>j. idx_enum R (x j)) (rev [ 0..<d ] ))"
+  let ?R = "ring_of R"
+
+  note select_bij = enum_cD(3)[OF assms(2)]
+  note fin_carr = enum_cD(1)[OF assms(2)]
+  note fo = field_cD[OF assms(1)]
+
+  interpret finite_field "ring_of R"
+    using fin_carr assms(1) unfolding finite_field_def finite_field_axioms_def field\<^sub>C_def by auto
+
+  have 1:"enum_monic_poly R d = ?f \<circ> (\<lambda>v. \<lambda>x\<in>{..<d}. nth_digit v x (order (ring_of R)))"
+    unfolding enum_monic_poly_def comp_def enum_cD[OF assms(2)]
+    by (intro ext arg_cong2[where f="(#)"] refl map_cong) auto
+
+  have 2:"?f = (\<lambda>x. 1\<^sub>C\<^bsub>R\<^esub> # map x (rev [ 0..<d ] )) \<circ> (\<lambda>x. \<lambda>i\<in>{..<d}. idx_enum R ( x i))"
+    unfolding comp_def by auto
+
+  have 3: "(\<lambda>x. \<one>\<^bsub>ring_of R\<^esub>#map x (rev [0..<d])) = (\<lambda>x. \<one>\<^bsub>ring_of R\<^esub>#x) \<circ>rev\<circ> (\<lambda>x. map x [0..<d])"
+    unfolding comp_def by (intro ext) (simp add:rev_map)
+
+  have ap_bij: "bij_betw ((#) \<one>\<^bsub>?R\<^esub>) {x. set x\<subseteq>carrier ?R\<and>length x=d} {f. monic_poly ?R f \<and> degree f=d}"
+    using list.collapse unfolding monic_poly_def univ_poly_carrier[symmetric] polynomial_def
+    by (intro bij_betwI[where g="tl"]) (fastforce intro:in_set_tlD)+
+
+  have rev_bij:
+    "bij_betw rev {x. set x \<subseteq> carrier ?R \<and> length x = d} {x. set x \<subseteq> carrier ?R \<and> length x = d}"
+    by (intro bij_betwI[where g="rev"]) auto
+
+  have "bij_betw (\<lambda>x. \<one>\<^bsub>?R\<^esub>#map x (rev [ 0..<d] )) ({..<d} \<rightarrow>\<^sub>E carrier ?R) {f. monic_poly ?R f\<and>degree f=d}"
+    unfolding 3 by (intro bij_betw_trans[OF lists_bij] bij_betw_trans[OF rev_bij] ap_bij)
+  hence "bij_betw ?f ({..<d} \<rightarrow>\<^sub>E {..<order ?R}) {f. monic_poly ?R f \<and> degree f = d}"
+    unfolding 2 by (intro bij_betw_trans[OF lift_bij_betw[OF select_bij]]) (simp add:fo)
+  thus ?thesis
+    unfolding 1 by (intro bij_betw_trans[OF nth_digit_bij])
+qed
+
+lemma measure_bind_pmf:
+  "measure (bind_pmf m f) s = (\<integral>x. measure (f x) s \<partial>m)" (is "?L = ?R")
+proof -
+  have "ennreal ?L = emeasure (bind_pmf m f) s"
+    unfolding measure_pmf.emeasure_eq_measure by simp
+  also have "... = (\<integral>\<^sup>+x. emeasure (f x) s \<partial>m)"
+    unfolding emeasure_bind_pmf by simp
+  also have "... = (\<integral>\<^sup>+x. measure (f x) s \<partial>m)"
+    unfolding measure_pmf.emeasure_eq_measure by simp
+  also have "... = ennreal ?R"
+    by (intro nn_integral_eq_integral measure_pmf.integrable_const_bound[where B="1"] AE_pmfI) auto
+  finally have "ennreal ?L = ennreal ?R" by simp
+  thus ?thesis
+    by (intro iffD1[OF ennreal_inj]) simp_all
+qed
+
+lemma powr_mono_rev:
+  fixes x :: real
+  assumes "a \<le> b" and  "x > 0" "x \<le> 1"
+  shows "x powr b \<le> x powr a"
+proof -
+  have "x powr b = (1/x) powr (-b)" using assms by (simp add: powr_divide powr_minus_divide)
+  also have "... \<le> (1/x) powr (-a)" using assms by (intro powr_mono) auto
+  also have "... = x powr a" using assms by (simp add: powr_divide powr_minus_divide)
+  finally show ?thesis by simp
+qed
+
+abbreviation tick_spmf :: "('a \<times> nat) spmf \<Rightarrow> ('a \<times> nat) spmf"
+  where "tick_spmf \<equiv> map_spmf (\<lambda>(x,c). (x,c+1))"
+
+text \<open>Finds an irreducible polynomial in the finite field @{term "mod_ring p"} with given degree n:\<close>
+
+partial_function (spmf) sample_irreducible_poly :: "nat \<Rightarrow> nat \<Rightarrow> (nat list \<times> nat) spmf"
+  where
+    "sample_irreducible_poly p n =
+      do {
+        k \<leftarrow> spmf_of_set {..<p^n};
+        let poly = enum_monic_poly (mod_ring p) n k;
+        if rabin_test (mod_ring p) poly
+          then return_spmf (poly,1)
+          else tick_spmf (sample_irreducible_poly p n)
+      }"
+
+text \<open>The following is a deterministic version. It returns the lexicographically minimal monic
+irreducible polynomial. Note that contrary to the randomized algorithm, the run time of the
+deterministic algorithm may be exponential (w.r.t. to the size of the field and degree of the
+polynomial).\<close>
+
+fun find_irreducible_poly :: "nat \<Rightarrow> nat \<Rightarrow> nat list"
+  where "find_irreducible_poly p n = (let f = enum_monic_poly (mod_ring p) n in
+    f (while ((\<lambda>k. \<not>rabin_test (mod_ring p) (f k))) (\<lambda>x. x + 1) 0))"
+
+definition cost :: "('a \<times> nat) option \<Rightarrow> enat"
+  where "cost x = (case x of None \<Rightarrow> \<infinity> | Some (_,r) \<Rightarrow> enat r)"
+
+lemma cost_tick: "cost (map_option (\<lambda>(x, c). (x, Suc c)) c) = eSuc (cost c)"
+  by (cases c) (auto simp:cost_def eSuc_enat)
+
+context
+  fixes n p :: nat
+  assumes p_prime: "Factorial_Ring.prime p"
+  assumes n_gt_0: "n > 0"
+begin
+
+private definition S where "S = {f. monic_poly (ring_of (mod_ring p)) f \<and> degree f = n }"
+private definition T where "T = {f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = n}"
+
+lemmas field_c = mod_ring_is_field_c[OF p_prime]
+lemmas enum_c = mod_ring_is_enum_c[where n="p"]
+
+interpretation finite_field "ring_of (mod_ring p)"
+  unfolding finite_field_def finite_field_axioms_def
+  by (intro mod_ring_is_field conjI mod_ring_finite p_prime)
+
+private lemmas field_ops = field_cD[OF field_c]
+
+private lemma S_fin: "finite S"
+  unfolding S_def
+  using enum_monic_poly[OF field_c enum_c, where d="n"]
+    bij_betw_finite by auto
+
+private lemma T_sub_S: "T \<subseteq> S"
+  unfolding S_def T_def monic_irreducible_poly_def by auto
+
+private lemma T_card_gt_0: "real (card T) > 0"
+proof -
+  have "0 < real (order (ring_of (mod_ring p))) ^ n / (2 * real n)"
+    using n_gt_0 finite_field_min_order by (intro divide_pos_pos) (simp_all)
+  also have "... \<le> real (card T)" unfolding T_def by (intro card_irred_gt_0 n_gt_0)
+  finally show  "real (card T) > 0" by auto
+qed
+
+private lemma S_card_gt_0: "real (card S) > 0"
+proof -
+  have "0 < card T" using T_card_gt_0 by simp
+  also have "... \<le> card S" by (intro card_mono T_sub_S S_fin)
+  finally have "0 < card S" by simp
+  thus ?thesis by simp
+qed
+
+private lemma S_ne: "S \<noteq> {}" using S_card_gt_0 by auto
+
+private lemma sample_irreducible_poly_step_aux:
+   "do {
+      k \<leftarrow> spmf_of_set {..<p^n};
+      let poly = enum_monic_poly (mod_ring p) n k;
+      if rabin_test (mod_ring p) poly then return_spmf (poly,c) else x
+    } =
+    do {
+      poly \<leftarrow> spmf_of_set S;
+      if monic_irreducible_poly (ring_of (mod_ring p)) poly
+          then return_spmf (poly,c)
+          else x
+    }"
+  (is "?L = ?R")
+proof -
+  have "order (ring_of (mod_ring p)) = p"
+    unfolding Finite_Fields_Mod_Ring_Code.mod_ring_def Coset.order_def ring_of_def by simp
+  hence 0:"spmf_of_set S = map_spmf (enum_monic_poly (mod_ring p) n) (spmf_of_set {..<p^n})"
+    using enum_monic_poly[OF field_c enum_c, where d="n"] unfolding bij_betw_def S_def
+    by (subst map_spmf_of_set_inj_on) auto
+
+  have "?L =do {f \<leftarrow> spmf_of_set S; if rabin_test (mod_ring p) f then return_spmf (f,c) else x}"
+    unfolding 0 bind_map_spmf by (simp add:Let_def comp_def)
+  also have "... = ?R"
+    using set_spmf_of_set_finite[OF S_fin]
+    by (intro bind_spmf_cong refl if_cong rabin_test field_c enum_c) (simp add:S_def)
+  finally show ?thesis by simp
+qed
+
+private lemma sample_irreducible_poly_step:
+  "sample_irreducible_poly p n =
+      do {
+        poly \<leftarrow> spmf_of_set S;
+        if monic_irreducible_poly (ring_of (mod_ring p)) poly
+          then return_spmf (poly,1)
+          else tick_spmf (sample_irreducible_poly p n)
+      }"
+  by (subst sample_irreducible_poly.simps) (simp add:sample_irreducible_poly_step_aux)
+
+private lemma sample_irreducible_poly_aux_1:
+  "ord_spmf (=) (map_spmf fst (sample_irreducible_poly p n)) (spmf_of_set T)"
+proof (induction rule:sample_irreducible_poly.fixp_induct)
+  case 1 thus ?case by simp
+next
+  case 2 thus ?case by simp
+next
+  case (3 rec)
+  let ?f = "monic_irreducible_poly (ring_of (mod_ring p))"
+
+  have "real (card (S\<inter>-{x. ?f x})) = real (card (S - T))"
+    unfolding S_def T_def by (intro arg_cong[where f="card"] arg_cong[where f="of_nat"]) (auto)
+  also have "... = real (card S - card T)"
+    by (intro arg_cong[where f="of_nat"] card_Diff_subset T_sub_S finite_subset[OF T_sub_S S_fin])
+  also have "... = real (card S) - card T"
+    by (intro of_nat_diff card_mono S_fin T_sub_S)
+  finally have 0:"real (card (S\<inter>-{x. ?f x})) = real (card S) - card T" by simp
+
+  have S_card_gt_0: "real (card S) > 0" using S_ne S_fin by auto
+
+  have "do {f \<leftarrow> spmf_of_set S;if ?f f then return_spmf f else spmf_of_set T} = spmf_of_set T"
+    (is "?L = ?R")
+  proof (rule spmf_eqI)
+    fix i
+    have "spmf ?L i = spmf (pmf_of_set S \<bind>(\<lambda>x. if ?f x then return_spmf x else spmf_of_set T)) i"
+      unfolding spmf_of_pmf_pmf_of_set[OF S_fin S_ne, symmetric] spmf_of_pmf_def
+      by (simp add:bind_spmf_def bind_map_pmf)
+    also have "... = (\<integral>x. (if ?f x then of_bool (x=i) else spmf (spmf_of_set T) i) \<partial>pmf_of_set S)"
+      unfolding pmf_bind if_distrib if_distribR pmf_return_spmf indicator_def by (simp cong:if_cong)
+    also have "... = (\<Sum>x \<in> S. (if ?f x then of_bool (x = i) else spmf (spmf_of_set T) i))/card S"
+      by (subst integral_pmf_of_set[OF S_ne S_fin]) simp
+    also have "... = (of_bool (i \<in> T) + spmf (spmf_of_set T) i*real (card (S\<inter>-{x. ?f x})))/card S"
+      using S_fin S_ne
+      by (subst sum.If_cases[OF S_fin]) (simp add:of_bool_def T_def monic_irreducible_poly_def S_def)
+    also have "... = (of_bool (i \<in> T)*(1 + real (card (S\<inter>-{x. ?f x}))/real (card T)))/card S"
+      unfolding spmf_of_set indicator_def by (simp add:algebra_simps)
+    also have "... = (of_bool (i \<in> T)*(real (card S)/real (card T)))/card S"
+      using T_card_gt_0 unfolding 0 by (simp add:field_simps)
+    also have "... = of_bool (i \<in> T)/real (card T)"
+      using S_card_gt_0 by (simp add:field_simps)
+    also have "... = spmf ?R i"
+      unfolding spmf_of_set by simp
+    finally show "spmf ?L i = spmf ?R i"
+      by simp
+  qed
+  hence "ord_spmf (=)
+    (spmf_of_set S \<bind> (\<lambda>x. if ?f x then return_spmf x else spmf_of_set T)) (spmf_of_set T)"
+    by simp
+  moreover have "ord_spmf (=)
+    (do { poly \<leftarrow> spmf_of_set S; if ?f poly then return_spmf poly else map_spmf fst (rec p n)})
+    (do { poly \<leftarrow> spmf_of_set S; if ?f poly then return_spmf poly else spmf_of_set T})"
+    using 3 by (intro bind_spmf_mono') simp_all
+  ultimately have "ord_spmf (=) (spmf_of_set S \<bind>
+    (\<lambda>x. if ?f x then return_spmf x else map_spmf fst (rec p n))) (spmf_of_set T)"
+    using spmf.leq_trans by force
+  thus ?case unfolding sample_irreducible_poly_step_aux map_spmf_bind_spmf
+    by (simp add:comp_def if_distribR if_distrib spmf.map_comp case_prod_beta cong:if_cong)
+qed
+
+lemma cost_sample_irreducible_poly:
+  "(\<integral>\<^sup>+x. cost x \<partial>sample_irreducible_poly p n) \<le> 2*real n" (is "?L \<le> ?R")
+proof -
+  let ?f = "monic_irreducible_poly (ring_of (mod_ring p))"
+  let ?a = "(\<lambda>t. measure (sample_irreducible_poly p n) {\<omega>. enat t < cost \<omega>})"
+  let ?b = "(\<lambda>t. measure (sample_irreducible_poly p n) {\<omega>. enat t \<ge> cost \<omega>})"
+
+  define \<alpha> where "\<alpha> = measure (pmf_of_set S) {x. ?f x}"
+  have \<alpha>_le_1: "\<alpha> \<le> 1" unfolding \<alpha>_def by simp
+
+  have "1 / (2* real n) = (card S / (2 * real n)) / card S"
+    using S_card_gt_0 by (simp add:algebra_simps)
+  also have "... = (real (order (ring_of (mod_ring p)))^n / (2 * real n)) / card S"
+    unfolding S_def bij_betw_same_card[OF enum_monic_poly[OF field_c enum_c, where d="n"],symmetric]
+    by simp
+  also have "... \<le> card T / card S"
+    unfolding T_def  by (intro divide_right_mono card_irred_gt_0 n_gt_0) auto
+  also have "... = \<alpha>"
+    unfolding \<alpha>_def measure_pmf_of_set[OF S_ne S_fin]
+    by (intro arg_cong2[where f="(/)"] refl arg_cong[where f="of_nat"]  arg_cong[where f="card"])
+     (auto simp: S_def T_def monic_irreducible_poly_def)
+  finally have \<alpha>_lb: "1/ (2*real n) \<le> \<alpha>"
+    by simp
+  have "0 < 1/ (2*real n)" using n_gt_0 by simp
+  also have "... \<le> \<alpha>" using \<alpha>_lb by simp
+  finally have \<alpha>_gt_0: "\<alpha> > 0" by simp
+
+  have a_step_aux: "norm (a * b) \<le> 1" if "norm a \<le> 1" "norm b \<le> 1" for a b :: real
+    using that by (simp add:abs_mult mult_le_one)
+
+  have b_eval: "?b t = (\<integral>x. (if ?f x then of_bool(t \<ge> 1) else
+    measure (sample_irreducible_poly p n) {\<omega>. enat t \<ge> eSuc (cost \<omega>)}) \<partial>pmf_of_set S)"
+    (is "?L1 = ?R1") for t
+  proof -
+    have "?b t = measure (bind_spmf (spmf_of_set S) (\<lambda>x. if ?f x then return_spmf (x,1) else
+        tick_spmf (sample_irreducible_poly p n))) {\<omega>. enat t \<ge> cost \<omega>}"
+      by (subst sample_irreducible_poly_step) simp
+    also have "... = measure (bind_pmf (pmf_of_set S) (\<lambda>x. if ?f x then return_spmf (x,1) else
+        tick_spmf (sample_irreducible_poly p n))) {\<omega>. enat t \<ge> cost \<omega>}"
+      unfolding spmf_of_pmf_pmf_of_set[OF S_fin S_ne, symmetric]
+      by (simp add:spmf_of_pmf_def bind_map_pmf bind_spmf_def)
+    also have "... = (\<integral>x. (if ?f x then of_bool(t \<ge> 1) else
+      measure (tick_spmf (sample_irreducible_poly p n)) {\<omega>. enat t \<ge> cost \<omega>})  \<partial>pmf_of_set S)"
+      unfolding measure_bind_pmf if_distrib if_distribR emeasure_return_pmf
+      by (simp add:indicator_def cost_def comp_def cong:if_cong)
+    also have "... = ?R1"
+      unfolding measure_map_pmf vimage_def
+      by (intro arg_cong2[where f="integral\<^sup>L"] refl ext if_cong arg_cong2[where f="measure"])
+       (auto simp add:vimage_def cost_tick eSuc_enat[symmetric])
+    finally show ?thesis by simp
+  qed
+
+  have b_eval_2: "?b t = 1 - (1-\<alpha>)^t" for t
+  proof (induction t)
+    case 0
+    have "?b 0 = 0" unfolding b_eval by (simp add:enat_0 cong:if_cong )
+    thus ?case by simp
+  next
+    case (Suc t)
+    have "?b (Suc t) = (\<integral>x. (if ?f x then 1 else  ?b t) \<partial>pmf_of_set S)"
+      unfolding b_eval[of "Suc t"]
+      by (intro arg_cong2[where f="integral\<^sup>L"] if_cong arg_cong2[where f="measure"])
+       (auto simp add: eSuc_enat[symmetric])
+    also have "... = (\<integral>x. indicator {x. ?f x} x + ?b t * indicator {x. \<not>?f x} x \<partial>pmf_of_set S)"
+      by (intro Bochner_Integration.integral_cong) (auto simp:algebra_simps)
+    also have "... = (\<integral>x. indicator {x. ?f x} x \<partial>pmf_of_set S) +
+      (\<integral>x. ?b t * indicator {x. \<not>?f x} x \<partial>pmf_of_set S)"
+      by (intro Bochner_Integration.integral_add measure_pmf.integrable_const_bound[where B="1"]
+          AE_pmfI a_step_aux) auto
+    also have "... = \<alpha> + ?b t * measure (pmf_of_set S) {x. \<not>?f x}" unfolding \<alpha>_def by simp
+    also have "... = \<alpha> + (1-\<alpha>) * ?b t"
+      unfolding \<alpha>_def
+      by (subst measure_pmf.prob_compl[symmetric]) (auto simp:Compl_eq_Diff_UNIV Collect_neg_eq)
+    also have "... = 1 - (1-\<alpha>)^Suc t"
+      unfolding Suc by (simp add:algebra_simps)
+    finally show ?case by simp
+  qed
+
+  hence a_eval: "?a t = (1-\<alpha>)^t" for t
+  proof -
+    have "?a t = 1 - ?b t"
+      by (simp add: measure_pmf.prob_compl[symmetric] Compl_eq_Diff_UNIV[symmetric]
+          Collect_neg_eq[symmetric] not_le)
+    also have "... =  (1-\<alpha>)^t"
+      unfolding b_eval_2 by simp
+    finally show ?thesis by simp
+  qed
+
+  have "?L = (\<Sum>t. emeasure (sample_irreducible_poly p n) {\<omega>. enat t < cost \<omega>})"
+    by (subst nn_integral_enat_function) simp_all
+  also have "... = (\<Sum>t. ennreal (?a t))"
+    unfolding measure_pmf.emeasure_eq_measure by simp
+  also have "... = (\<Sum>t. ennreal ((1-\<alpha>)^t))"
+    unfolding a_eval by (intro arg_cong[where f="suminf"] ext) (simp add: \<alpha>_def ennreal_mult')
+  also have "... = ennreal (1 / (1-(1-\<alpha>)))"
+    using \<alpha>_le_1 \<alpha>_gt_0
+    by (intro arg_cong2[where f="(*)"] refl suminf_ennreal_eq geometric_sums) auto
+  also have "... = ennreal (1 / \<alpha>)" using \<alpha>_le_1 \<alpha>_gt_0 by auto
+  also have "... \<le> ?R"
+    using \<alpha>_lb n_gt_0 \<alpha>_gt_0 by (intro ennreal_leI) (simp add:field_simps)
+  finally show ?thesis by simp
+qed
+
+private lemma weight_sample_irreducible_poly:
+  "weight_spmf (sample_irreducible_poly p n) = 1" (is "?L = ?R")
+proof (rule ccontr)
+  assume "?L \<noteq> 1"
+  hence "?L < 1" using less_eq_real_def weight_spmf_le_1 by blast
+  hence "(\<infinity>::ennreal) = \<infinity> * ennreal (1-?L)" by simp
+  also have "... = \<infinity> * ennreal (pmf (sample_irreducible_poly p n) None)"
+    unfolding pmf_None_eq_weight_spmf[symmetric] by simp
+  also have "... = (\<integral>\<^sup>+x. \<infinity> * indicator {None} x  \<partial>sample_irreducible_poly p n)"
+    by (simp add:emeasure_pmf_single)
+  also have "... \<le> (\<integral>\<^sup>+x. cost x \<partial>sample_irreducible_poly p n)"
+    unfolding cost_def by (intro nn_integral_mono) (auto simp:indicator_def)
+  also have "... \<le> 2*real n" by (intro cost_sample_irreducible_poly)
+  finally have "(\<infinity>::ennreal) \<le> 2 * real n" by simp
+  thus "False" using linorder_not_le by fastforce
+qed
+
+lemma sample_irreducible_poly_result:
+  "map_spmf fst (sample_irreducible_poly p n) =
+    spmf_of_set {f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = n}" (is "?L = ?R")
+proof -
+  have "?L = spmf_of_set T" using weight_sample_irreducible_poly
+    by (intro eq_iff_ord_spmf sample_irreducible_poly_aux_1) (auto intro:weight_spmf_le_1)
+  thus ?thesis  unfolding T_def by simp
+qed
+
+lemma find_irreducible_poly_result:
+  defines "res \<equiv> find_irreducible_poly p n"
+  shows "monic_irreducible_poly (ring_of (mod_ring p)) res" "degree res = n"
+proof -
+  let ?f = "enum_monic_poly (mod_ring p) n"
+
+  have ex:"\<exists>k. ?f k \<in> T \<and> k < order (ring_of (mod_ring p))^n"
+  proof (rule ccontr)
+    assume "\<nexists>k. ?f k \<in> T \<and> k < order (ring_of (mod_ring p)) ^ n"
+    hence "?f ` {..<order (ring_of (mod_ring p)) ^ n} \<inter> T = {}" by auto
+    hence "S \<inter> T = {}"
+      unfolding S_def using bij_betw_imp_surj_on[OF enum_monic_poly[OF field_c enum_c]] by auto
+    hence "T = {}" using T_sub_S by auto
+    thus "False" using T_card_gt_0 by simp
+  qed
+
+  then obtain k :: nat where k_def: "?f k \<in> T" "\<forall>j<k. ?f j \<notin> T"
+    using exists_least_iff[where P="\<lambda>x. ?f x \<in> T"] by auto
+
+  have k_ub: "k < order (ring_of (mod_ring p))^n"
+    using ex k_def(2) by (meson dual_order.strict_trans1 not_less)
+
+  have a: "monic_irreducible_poly (ring_of (mod_ring p)) (?f k)"
+    using k_def(1) unfolding T_def by simp
+  have b: "monic_poly (ring_of (mod_ring p)) (?f j)" "degree (?f j) = n" if "j \<le> k" for j
+  proof -
+    have "j < order (ring_of (mod_ring p)) ^n" using k_ub that by simp
+    hence "?f j \<in> S" unfolding S_def using bij_betw_apply[OF enum_monic_poly[OF field_c enum_c]] by auto
+    thus "monic_poly (ring_of (mod_ring p)) (?f j)" "degree (?f j) = n" unfolding S_def by auto
+  qed
+
+  have c: "\<not>monic_irreducible_poly (ring_of (mod_ring p)) (?f j)"  if " j < k" for j
+    using b[of "j"] that k_def(2) unfolding T_def by auto
+
+  have 2: "while ((\<lambda>k. \<not>rabin_test (mod_ring p) (?f k))) (\<lambda>x. x + 1) (k-j) = k" if "j \<le> k" for j
+  using that proof (induction j)
+    case 0
+    have "rabin_test (mod_ring p) (?f k)" by (intro iffD2[OF rabin_test] a b field_c enum_c) auto
+    thus ?case by (subst while_unfold) simp
+  next
+    case (Suc j)
+    hence "\<not>rabin_test (mod_ring p) (?f (k-Suc j))"
+      using b c by (subst rabin_test[OF field_c enum_c]) auto
+    moreover have "Suc (Suc (k - Suc j)) = Suc (k-j)" using Suc by simp
+    ultimately show ?case using Suc(1) by (subst while_unfold) simp
+  qed
+
+  have 3:"while ((\<lambda>k. \<not>rabin_test (mod_ring p) (?f k))) (\<lambda>x. x + 1) 0 = k"
+    using 2[of "k"] by simp
+
+  have "?f k \<in> T" using a b unfolding T_def by auto
+  hence "res \<in> T" unfolding res_def find_irreducible_poly.simps Let_def 3 by simp
+  thus "monic_irreducible_poly (ring_of (mod_ring p)) res" "degree res = n" unfolding T_def by auto
+qed
+
+lemma monic_irred_poly_set_nonempty_finite:
+  "{f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = n} \<noteq> {}" (is "?R1")
+  "finite {f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = n}" (is "?R2")
+proof -
+  have "card T > 0" using T_card_gt_0 by auto
+  hence "T \<noteq> {}" "finite T" using card_ge_0_finite by auto
+  thus ?R1 ?R2 unfolding T_def by auto
+qed
+
+end
+
+text \<open>Returns @{term "m"} @{term "e"} such that @{term "n = m^e"}, where @{term "e"} is maximal.\<close>
+
+definition split_power :: "nat \<Rightarrow> nat \<times> nat"
+  where "split_power n = (
+    let e = last (filter (\<lambda>x. is_nth_power_nat x n) (1#[2..<floorlog 2 n]))
+    in (nth_root_nat e n, e))"
+
+lemma split_power_result:
+  assumes "(x,e) = split_power n"
+  shows "n = x^e" "\<And>k. n > 1 \<Longrightarrow> k>e \<Longrightarrow> \<not>is_nth_power k n"
+proof -
+  define es where "es = filter (\<lambda>x. is_nth_power_nat x n) (1#[2..<floorlog 2 n])"
+  define m where "m = max 2 (floorlog 2 n)"
+
+  have 0: "x < m" if that0: "is_nth_power_nat x n" "n > 1" for x
+  proof (rule ccontr)
+    assume a:"\<not>(x < m)"
+    obtain y where n_def:"n = y^x" using that0 is_nth_power_def is_nth_power_nat_def by auto
+    have "y \<noteq> 0" using that(2) unfolding n_def
+      by (metis (mono_tags) nat_power_eq_Suc_0_iff not_less0 power_0_left power_inject_exp)
+    moreover have "y \<noteq> 1" using that(2) unfolding n_def by auto
+    ultimately have y_ge_2: "y \<ge> 2" by simp
+    have "n < 2^floorlog 2 n" using that floorlog_bounds by simp
+    also have "... \<le> 2^x" using a unfolding m_def by (intro power_increasing) auto
+    also have "... \<le> y^x" using y_ge_2 by (intro power_mono) auto
+    also have "... = n" using n_def by auto
+    finally show "False" by simp
+  qed
+
+  have 1: "m = 2" if "\<not>(n > 1)"
+  proof -
+    have "floorlog 2 n \<le> 2" using that by (intro floorlog_leI) auto
+    thus ?thesis unfolding m_def by auto
+  qed
+
+  have 2: "n = 1" if "is_nth_power_nat 0 n" using that by (simp add: is_nth_power_nat_code)
+
+  have "set es = {x \<in> insert 1 {2..<floorlog 2 n}. is_nth_power_nat x n}" unfolding es_def by auto
+  also have "... = {x. x \<noteq> 0 \<and> x < m \<and> is_nth_power_nat x n}" unfolding m_def by auto
+  also have "... = {x. is_nth_power_nat x n \<and> (n > 1 \<or> x = 1)}"
+    using 0 1 2 zero_neq_one by (intro Collect_cong iffI conjI) fastforce+
+  finally have set_es: "set es = {x. is_nth_power_nat x n \<and> (n > 1 \<or> x = 1)}" by simp
+
+  have "is_nth_power_nat 1 n" unfolding is_nth_power_nat_def by simp
+  hence es_ne: "es \<noteq> []" unfolding es_def by auto
+
+  have sorted: "sorted es" unfolding es_def by (intro sorted_wrt_filter) simp
+
+  have e_def: "e = last es" and x_def: "x = nth_root_nat e n"
+    using assms unfolding es_def split_power_def by (simp_all add:Let_def)
+
+  hence e_in_set_es: "e \<in> set es" unfolding e_def using es_ne by (intro last_in_set) auto
+
+  have e_max: "x \<le> e" if that1:"x \<in> set es" for x
+  proof -
+    obtain k where "k < length es" "x = es ! k" using that1 by (metis in_set_conv_nth)
+    moreover have "e = es ! (length es -1)" unfolding e_def using es_ne last_conv_nth by auto
+    ultimately show ?thesis using sorted_nth_mono[OF sorted] es_ne by simp
+  qed
+  have 3:"is_nth_power_nat e n \<and> (1 < n \<or> e = 1)" using e_in_set_es unfolding set_es by simp
+  hence "e > 0" using 2 zero_neq_one by fast
+  thus "n = x^e" using 3 unfolding x_def using nth_root_nat_nth_power
+    by (metis is_nth_power_nat_code nth_root_nat_naive_code power_eq_0_iff)
+  show "\<not>is_nth_power k n" if "n > 1" "k > e" for k
+  proof (rule ccontr)
+    assume "\<not>(\<not>is_nth_power k n)"
+    hence "k \<in> set es" using that unfolding set_es is_nth_power_nat_def by auto
+    hence "k \<le> e" using e_max by auto
+    thus "False" using that(2) by auto
+  qed
+qed
+
+definition not_perfect_power :: "nat \<Rightarrow> bool"
+  where "not_perfect_power n = (n > 1 \<and> (\<forall>x k. n = x ^ k \<longrightarrow> k = 1))"
+
+lemma is_nth_power_from_multiplicities:
+  assumes "n > (0::nat)"
+  assumes "\<And>p. Factorial_Ring.prime p \<Longrightarrow> k dvd (multiplicity p n)"
+  shows "is_nth_power k n"
+proof -
+  have "n = (\<Prod>p \<in> prime_factors n. p^multiplicity p n)" using assms(1)
+    by (simp add: prod_prime_factors)
+  also have "... = (\<Prod>p \<in> prime_factors n. p^((multiplicity p n div k)*k))"
+    by (intro prod.cong arg_cong2[where f="power"] dvd_div_mult_self[symmetric] refl assms(2)) auto
+  also have "... = (\<Prod>p \<in> prime_factors n. p^(multiplicity p n div k))^k"
+    unfolding power_mult prod_power_distrib[symmetric] by simp
+  finally have "n = (\<Prod>p \<in> prime_factors n. p^(multiplicity p n div k))^k" by simp
+  thus ?thesis by (intro is_nth_powerI) simp
+qed
+
+lemma power_inj_aux:
+  assumes "not_perfect_power a" "not_perfect_power b"
+  assumes "n > 0" "m > n"
+  assumes "a ^ n = b ^ m"
+  shows "False"
+proof -
+  define s where "s = gcd n m"
+  define u where "u = n div gcd n m"
+  define t where "t = m div gcd n m"
+
+  have a_nz: "a \<noteq> 0" and b_nz: "b \<noteq> 0" using assms(1,2) unfolding not_perfect_power_def by auto
+
+  have "gcd n m \<noteq> 0" using assms (3,4) by simp
+
+  then obtain t u where n_def: "n = t * s" and m_def: "m = u * s" and cp: "coprime t u"
+    using gcd_coprime_exists unfolding s_def t_def u_def by blast
+
+  have s_gt_0: "s > 0" and t_gt_0: "t > 0" and u_gt_t: "u > t"
+    using assms(3,4) unfolding n_def m_def by auto
+
+  have "(a ^ t) ^ s = (b ^ u) ^ s" using assms(5) unfolding n_def m_def power_mult by simp
+  hence 0: "a^t = b^u" using s_gt_0 by (metis nth_root_nat_nth_power)
+
+  have "u dvd multiplicity p a" if "Factorial_Ring.prime p" for p
+  proof -
+    have "prime_elem p" using that by simp
+    hence "t * multiplicity p a = u * multiplicity p b"
+      using 0 a_nz b_nz by (subst (1 2) prime_elem_multiplicity_power_distrib[symmetric]) auto
+    hence "u dvd t * multiplicity p a" by simp
+    thus ?thesis using cp coprime_commute coprime_dvd_mult_right_iff by blast
+  qed
+
+  hence "is_nth_power u a" using a_nz by (intro is_nth_power_from_multiplicities) auto
+  moreover have "u > 1" using u_gt_t t_gt_0 by auto
+  ultimately show "False" using assms(1) unfolding not_perfect_power_def is_nth_power_def by auto
+qed
+
+text \<open>Generalization of @{thm [source] prime_power_inj'}\<close>
+
+lemma power_inj:
+  assumes "not_perfect_power a" "not_perfect_power b"
+  assumes "n > 0" "m > 0"
+  assumes "a ^ n = b ^ m"
+  shows "a = b \<and> n = m"
+proof -
+  consider (a) "n < m" | (b) "m < n" | (c) "n = m" by linarith
+  thus ?thesis
+  proof (cases)
+    case a thus ?thesis using assms power_inj_aux by auto
+  next
+    case b thus ?thesis using assms power_inj_aux[OF assms(2,1,4) b] by auto
+  next
+    case c thus ?thesis using assms by (simp add: power_eq_iff_eq_base)
+  qed
+qed
+
+lemma split_power_base_not_perfect:
+  assumes "n > 1"
+  shows "not_perfect_power (fst (split_power n))"
+proof (rule ccontr)
+  obtain b e where be_def: "(b,e) = split_power n" by (metis surj_pair)
+  have n_def:"n = b ^ e" and e_max: "\<And>k. e < k \<Longrightarrow> \<not> is_nth_power k n"
+    using assms split_power_result[OF be_def] by auto
+
+  have e_gt_0: "e > 0" using assms unfolding n_def by (cases e) auto
+
+  assume "\<not>not_perfect_power (fst (split_power n))"
+  hence "\<not>not_perfect_power b" unfolding be_def[symmetric] by simp
+  moreover have b_gt_1: "b > 1" using assms unfolding n_def
+    by (metis less_one nat_neq_iff nat_power_eq_Suc_0_iff power_0_left)
+  ultimately obtain k b' where "k \<noteq> 1" and b_def: "b = b'^k"
+    unfolding not_perfect_power_def by auto
+  hence k_gt_1: "k > 1" using b_gt_1 nat_neq_iff by force
+  have "n = b'^(k*e)" unfolding power_mult n_def b_def by auto
+  moreover have "k*e > e" using k_gt_1 e_gt_0 by simp
+  hence "\<not>is_nth_power (k*e) n" using e_max by auto
+  ultimately show "False" unfolding is_nth_power_def by auto
+qed
+
+lemma prime_not_perfect:
+  assumes "Factorial_Ring.prime p"
+  shows "not_perfect_power p"
+proof -
+  have "k=1" if "p = x^k" for x k using assms unfolding that by (simp add:prime_power_iff)
+  thus ?thesis using prime_gt_1_nat[OF assms] unfolding not_perfect_power_def by auto
+qed
+
+lemma split_power_prime:
+  assumes "Factorial_Ring.prime p" "n > 0"
+  shows "split_power (p^n) = (p,n)"
+proof -
+  obtain x e where xe:"(x,e) = split_power (p^n)" by (metis surj_pair)
+
+  have "1 < p^1" using prime_gt_1_nat[OF assms(1)] by simp
+  also have "... \<le> p^n" using assms(2) prime_gt_0_nat[OF assms(1)] by (intro power_increasing) auto
+  finally have 0:"p^n > 1" by simp
+
+  have "not_perfect_power x"
+    using split_power_base_not_perfect[OF 0] unfolding xe[symmetric] by simp
+  moreover have "not_perfect_power p" by (rule prime_not_perfect[OF assms(1)])
+  moreover have 1:"p^n = x^e" using split_power_result[OF xe] by simp
+  moreover have "e > 0" using 0 1 by (cases e) auto
+  ultimately have "p=x \<and> n = e" by (intro power_inj assms(2))
+  thus ?thesis using xe by simp
+qed
+
+definition "is_prime_power n = (\<exists>p k. Factorial_Ring.prime p \<and> k > 0 \<and> n = p^k)"
+
+definition GF where
+  "GF n = (
+    let (p,k) = split_power n;
+        f = find_irreducible_poly p k
+     in poly_mod_ring (mod_ring p) f)"
+
+
+definition GF\<^sub>R where
+  "GF\<^sub>R n =
+    do {
+      let (p,k) = split_power n;
+      f \<leftarrow> sample_irreducible_poly p k;
+      return_spmf (poly_mod_ring (mod_ring p) (fst f))
+    }"
+
+lemma GF_in_GF_R:
+  assumes "is_prime_power n"
+  shows "GF n \<in> set_spmf (GF\<^sub>R n)"
+proof-
+  obtain p k where n_def: "n = p^k" and p_prime: "prime p" and k_gt_0: "k > 0"
+    using assms unfolding is_prime_power_def by blast
+  have pk_def: "(p,k) = split_power n"
+    unfolding n_def using split_power_prime[OF p_prime k_gt_0] by auto
+  let ?S = "{f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = k}"
+
+  have S_fin: "finite ?S" by (intro monic_irred_poly_set_nonempty_finite p_prime k_gt_0)
+
+  have "find_irreducible_poly p k \<in> ?S"
+    using find_irreducible_poly_result[OF p_prime k_gt_0] by auto
+  also have "... = set_spmf (map_spmf fst (sample_irreducible_poly p k))"
+    unfolding sample_irreducible_poly_result[OF p_prime k_gt_0] set_spmf_of_set_finite[OF S_fin]
+    by simp
+  finally have 0: "find_irreducible_poly p k \<in> set_spmf(map_spmf fst (sample_irreducible_poly p k))"
+    by simp
+
+  have "GF n = poly_mod_ring (mod_ring p) (find_irreducible_poly p k)"
+    unfolding GF_def pk_def[symmetric] by (simp del:find_irreducible_poly.simps)
+  also have "... \<in> set_spmf (map_spmf fst (sample_irreducible_poly p k)) \<bind> (\<lambda>x. {poly_mod_ring (mod_ring p) x})"
+    using 0 by force
+  also have "... = set_spmf (GF\<^sub>R n)"
+    unfolding GF\<^sub>R_def pk_def[symmetric] by (simp add:set_bind_spmf comp_def bind_image)
+  finally show ?thesis by simp
+qed
+
+lemma galois_field_random_1:
+  assumes "is_prime_power n"
+  shows "\<And>\<omega>. \<omega> \<in> set_spmf (GF\<^sub>R n) \<Longrightarrow> enum\<^sub>C \<omega> \<and> field\<^sub>C \<omega> \<and> order (ring_of \<omega>) = n"
+    and "lossless_spmf (GF\<^sub>R n)"
+proof -
+  let ?pred = "\<lambda>\<omega>. enum\<^sub>C \<omega> \<and> field\<^sub>C \<omega> \<and> order (ring_of \<omega>) = n"
+
+  obtain p k where n_def: "n = p^k" and p_prime: "prime p" and k_gt_0: "k > 0"
+    using assms unfolding is_prime_power_def by blast
+  let ?r = "(\<lambda>f. poly_mod_ring (mod_ring p) f)"
+  let ?S = "{f. monic_irreducible_poly (ring_of (mod_ring p)) f \<and> degree f = k}"
+
+  have fc: "field\<^sub>C (mod_ring p)" by (intro mod_ring_is_field_c p_prime)
+  have ec: "enum\<^sub>C (mod_ring p)" by (intro mod_ring_is_enum_c)
+
+  have S_fin: "finite ?S" by (intro monic_irred_poly_set_nonempty_finite p_prime k_gt_0)
+  have S_ne: "?S \<noteq> {}" by (intro monic_irred_poly_set_nonempty_finite p_prime k_gt_0)
+
+  have pk_def: "(p,k) = split_power n"
+    unfolding n_def using split_power_prime[OF p_prime k_gt_0] by auto
+
+  have cond: "?pred (?r x)" if "x \<in> ?S" for x
+  proof -
+    have "order (ring_of (poly_mod_ring (mod_ring p) x)) = idx_size (poly_mod_ring (mod_ring p) x)"
+      using enum_cD[OF enum_c_poly_mod_ring[OF ec field_c_imp_ring[OF fc]]] by simp
+    also have "... = p^(degree x)"
+      by (simp add:poly_mod_ring_def Finite_Fields_Mod_Ring_Code.mod_ring_def)
+    also have "... = n" unfolding n_def using that by simp
+    finally have "order (ring_of (poly_mod_ring (mod_ring p) x)) = n" by simp
+
+    thus ?thesis using that
+      by (intro conjI enum_c_poly_mod_ring field_c_poly_mod_ring ec field_c_imp_ring fc) auto
+  qed
+
+  have "GF\<^sub>R n = bind_spmf (map_spmf fst (sample_irreducible_poly p k)) (\<lambda>x. return_spmf (?r x))"
+    unfolding GF\<^sub>R_def pk_def[symmetric] map_spmf_conv_bind_spmf by simp
+  also have "... = spmf_of_set ?S \<bind> (\<lambda>f. return_spmf ((?r f)))"
+    unfolding sample_irreducible_poly_result[OF p_prime k_gt_0] by (simp)
+  also have "... = pmf_of_set ?S \<bind> (\<lambda>f. return_spmf (?r f))"
+    unfolding spmf_of_pmf_pmf_of_set[OF S_fin S_ne, symmetric] spmf_of_pmf_def
+    by (simp add:bind_spmf_def bind_map_pmf)
+  finally have 0:"GF\<^sub>R n = map_pmf (Some \<circ> ?r) (pmf_of_set ?S) " by (simp add:comp_def map_pmf_def)
+
+  show "enum\<^sub>C \<omega> \<and> field\<^sub>C \<omega> \<and> order (ring_of \<omega>) = n" if "\<omega> \<in> set_spmf (GF\<^sub>R n)" for \<omega>
+  proof -
+    have "Some \<omega> \<in> set_pmf (GF\<^sub>R n)" unfolding in_set_spmf[symmetric] by (rule that)
+    also have "... = (Some \<circ> ?r) ` ?S" unfolding 0 set_map_pmf set_pmf_of_set[OF S_ne S_fin] by simp
+    finally have "Some \<omega> \<in> (Some \<circ> ?r) ` ?S" by simp
+    hence "\<omega> \<in> ?r ` ?S" by auto
+    then obtain x where x:"x \<in> ?S" and \<omega>_def:"\<omega> = ?r x" by auto
+    show ?thesis unfolding \<omega>_def by (intro cond x)
+  qed
+
+  have "None \<notin> set_pmf(GF\<^sub>R n)" unfolding 0 set_map_pmf set_pmf_of_set[OF S_ne S_fin] by auto
+  thus "lossless_spmf (GF\<^sub>R n)" using lossless_iff_set_pmf_None by blast
+qed
+
+lemma galois_field:
+  assumes "is_prime_power n"
+  shows "enum\<^sub>C (GF n)" "field\<^sub>C (GF n)" "order (ring_of (GF n)) = n"
+  using galois_field_random_1(1)[OF assms(1) GF_in_GF_R[OF assms(1)]] by auto
+
+lemma lossless_imp_spmf_of_pmf:
+  assumes "lossless_spmf M"
+  shows "spmf_of_pmf (map_pmf the M) = M"
+proof -
+  have "spmf_of_pmf (map_pmf the M) = map_pmf (Some \<circ> the) M"
+    unfolding spmf_of_pmf_def by (simp add: pmf.map_comp)
+  also have "... = map_pmf id M"
+    using assms unfolding lossless_iff_set_pmf_None
+    by (intro map_pmf_cong refl) (metis id_apply o_apply option.collapse)
+  also have "... = M" by simp
+  finally show ?thesis by simp
+qed
+
+lemma galois_field_random_2:
+  assumes "is_prime_power n"
+  shows "map_spmf (\<lambda>\<omega>. enum\<^sub>C \<omega> \<and> field\<^sub>C \<omega> \<and> order (ring_of \<omega>) = n) (GF\<^sub>R n) = return_spmf True"
+    (is "?L = _")
+proof -
+  have "?L = map_spmf (\<lambda>\<omega>. True) (GF\<^sub>R n)"
+    using galois_field_random_1[OF assms] by (intro map_spmf_cong refl) auto
+  also have "... = map_pmf (\<lambda>\<omega>. Some True) (GF\<^sub>R n)"
+    by (subst lossless_imp_spmf_of_pmf[OF galois_field_random_1(2)[OF assms],symmetric]) simp
+  also have "... = return_spmf True" unfolding map_pmf_def by simp
+  finally show ?thesis by simp
+qed
+
+lemma bind_galois_field_cong:
+  assumes "is_prime_power n"
+  assumes "\<And>\<omega>. enum\<^sub>C \<omega> \<Longrightarrow> field\<^sub>C \<omega> \<Longrightarrow> order (ring_of \<omega>) = n \<Longrightarrow> f \<omega> = g \<omega>"
+  shows "bind_spmf (GF\<^sub>R n) f = bind_spmf (GF\<^sub>R n) g"
+  using galois_field_random_1(1)[OF assms(1)]
+  by (intro bind_spmf_cong refl assms(2)) auto
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Factorization_Ext.thy b/thys/Finite_Fields/Finite_Fields_Factorization_Ext.thy
--- a/thys/Finite_Fields/Finite_Fields_Factorization_Ext.thy
+++ b/thys/Finite_Fields/Finite_Fields_Factorization_Ext.thy
@@ -1,516 +1,516 @@
 subsection "Factorization"
 
 theory Finite_Fields_Factorization_Ext
   imports Finite_Fields_Preliminary_Results
 begin
 
 text \<open>This section contains additional results building on top of the development in
 @{theory "HOL-Algebra.Divisibility"} about factorization in a @{locale "factorial_monoid"}.\<close>
 
-definition factor_mset where "factor_mset G x = 
+definition factor_mset where "factor_mset G x =
   (THE f. (\<exists> as. f = fmset G as \<and> wfactors G as x \<and> set as \<subseteq> carrier G))"
 
 text \<open>In @{theory "HOL-Algebra.Divisibility"} it is already verified that the multiset representing
 the factorization of an element of a factorial monoid into irreducible factors is well-defined.
 With these results it is then possible to define @{term "factor_mset"} and show its properties,
 without referring to a factorization in list form first.\<close>
 
 definition multiplicity where
   "multiplicity G d g = Max {(n::nat). (d [^]\<^bsub>G\<^esub> n) divides\<^bsub>G\<^esub> g}"
 
-definition canonical_irreducibles where 
+definition canonical_irreducibles where
   "canonical_irreducibles G A = (
     A \<subseteq> {a. a \<in> carrier G \<and> irreducible G a} \<and>
     (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x \<sim>\<^bsub>G\<^esub> y \<longrightarrow> x = y) \<and>
     (\<forall>x \<in> carrier G. irreducible G x \<longrightarrow> (\<exists>y \<in> A. x \<sim>\<^bsub>G\<^esub> y)))"
 
 text \<open>A set of irreducible elements that contains exactly one element from each equivalence class
-of an irreducible element formed by association, is called a set of 
+of an irreducible element formed by association, is called a set of
 @{term "canonical_irreducibles"}. An example is the set of monic irreducible polynomials as
 representatives of all irreducible polynomials.\<close>
 
 context factorial_monoid
 begin
 
 lemma assoc_as_fmset_eq:
   assumes "wfactors G as a"
     and "wfactors G bs b"
     and "a \<in> carrier G"
     and "b \<in> carrier G"
     and "set as \<subseteq> carrier G"
     and "set bs \<subseteq> carrier G"
   shows "a \<sim> b \<longleftrightarrow> (fmset G as = fmset G bs)"
 proof -
   have "a \<sim> b \<longleftrightarrow> (a divides b \<and> b divides a)"
     by (simp add:associated_def)
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (fmset G as \<subseteq># fmset G bs \<and> fmset G bs \<subseteq># fmset G as)"
     using divides_as_fmsubset assms by blast
   also have "... \<longleftrightarrow> (fmset G as = fmset G bs)" by auto
   finally show ?thesis by simp
 qed
 
 lemma factor_mset_aux_1:
   assumes "a \<in> carrier G" "set as \<subseteq> carrier G" "wfactors G as a"
   shows "factor_mset G a = fmset G as"
 proof -
   define H where "H = {as. wfactors G as a \<and> set as \<subseteq> carrier G}"
   have b:"as \<in> H"
     using H_def assms by simp
 
   have c: "x \<in> H \<Longrightarrow> y \<in> H \<Longrightarrow> fmset G x = fmset G y" for x y
-    unfolding H_def using assoc_as_fmset_eq 
-    using associated_refl assms by blast 
+    unfolding H_def using assoc_as_fmset_eq
+    using associated_refl assms by blast
 
   have "factor_mset G a = (THE f. \<exists>as \<in> H. f= fmset G as)"
-    by (simp add:factor_mset_def H_def, metis) 
+    by (simp add:factor_mset_def H_def, metis)
 
   also have "... = fmset G as"
     using b c
     by (intro the1_equality) blast+
   finally have "factor_mset G a = fmset G as" by simp
 
   thus ?thesis
     using b unfolding H_def by auto
 qed
 
 lemma factor_mset_aux:
   assumes "a \<in> carrier G"
-  shows "\<exists>as. factor_mset G a = fmset G as \<and> wfactors G as a \<and> 
+  shows "\<exists>as. factor_mset G a = fmset G as \<and> wfactors G as a \<and>
     set as \<subseteq> carrier G"
 proof -
   obtain as where as_def: "wfactors G as a" "set as \<subseteq> carrier G"
     using wfactors_exist assms by blast
   thus ?thesis using factor_mset_aux_1 assms by blast
 qed
 
 lemma factor_mset_set:
   assumes "a \<in> carrier G"
-  assumes "x \<in># factor_mset G a" 
-  obtains y where 
-    "y \<in> carrier G" 
-    "irreducible G y" 
-    "assocs G y = x" 
+  assumes "x \<in># factor_mset G a"
+  obtains y where
+    "y \<in> carrier G"
+    "irreducible G y"
+    "assocs G y = x"
 proof -
-  obtain as where as_def: 
-    "factor_mset G a = fmset G as" 
+  obtain as where as_def:
+    "factor_mset G a = fmset G as"
     "wfactors G as a" "set as \<subseteq> carrier G"
     using factor_mset_aux assms by blast
   hence "x \<in># fmset G as"
     using assms by simp
   hence "x \<in> assocs G ` set as"
     using assms as_def by (simp add:fmset_def)
   hence "\<exists>y. y \<in> set as \<and> x = assocs G y"
     by auto
-  moreover have "y \<in> carrier G \<and> irreducible G y" 
+  moreover have "y \<in> carrier G \<and> irreducible G y"
     if "y \<in> set as" for y
     using as_def that wfactors_def
     by (simp add: wfactors_def) auto
   ultimately show ?thesis
     using that by blast
 qed
 
 lemma factor_mset_mult:
   assumes "a \<in> carrier G" "b \<in> carrier G"
   shows "factor_mset G (a \<otimes> b) = factor_mset G a + factor_mset G b"
 proof -
-  obtain as where as_def: 
-    "factor_mset G a = fmset G as" 
+  obtain as where as_def:
+    "factor_mset G a = fmset G as"
     "wfactors G as a" "set as \<subseteq> carrier G"
     using factor_mset_aux assms by blast
-  obtain bs where bs_def: 
-    "factor_mset G b = fmset G bs" 
+  obtain bs where bs_def:
+    "factor_mset G b = fmset G bs"
     "wfactors G bs b" "set bs \<subseteq> carrier G"
     using factor_mset_aux assms(2) by blast
   have "a \<otimes> b \<in> carrier G" using assms by auto
   then obtain cs where cs_def:
-    "factor_mset G (a \<otimes> b) = fmset G cs" 
-    "wfactors G cs (a \<otimes> b)" 
+    "factor_mset G (a \<otimes> b) = fmset G cs"
+    "wfactors G cs (a \<otimes> b)"
     "set cs \<subseteq> carrier G"
     using factor_mset_aux assms by blast
   have "fmset G cs = fmset G as + fmset G bs"
-    using as_def bs_def cs_def assms 
+    using as_def bs_def cs_def assms
     by (intro  mult_wfactors_fmset[where a="a" and b="b"]) auto
   thus ?thesis
     using as_def bs_def cs_def by auto
 qed
 
 lemma factor_mset_unit: "factor_mset G \<one> = {#}"
 proof -
   have "factor_mset G \<one> = factor_mset G (\<one> \<otimes> \<one>)"
     by simp
   also have "... = factor_mset G \<one> + factor_mset G \<one>"
     by (intro factor_mset_mult, auto)
   finally show "factor_mset G \<one> = {#}"
     by simp
 qed
 
-lemma factor_mset_irred: 
+lemma factor_mset_irred:
   assumes "x \<in> carrier G" "irreducible G x"
   shows "factor_mset G x = image_mset (assocs G) {#x#}"
 proof -
   have "wfactors G [x] x"
     using assms by (simp add:wfactors_def)
   hence "factor_mset G x = fmset G [x]"
     using factor_mset_aux_1 assms by simp
   also have "... = image_mset (assocs G) {#x#}"
     by (simp add:fmset_def)
   finally show ?thesis by simp
 qed
 
 lemma factor_mset_divides:
   assumes "a \<in> carrier G" "b \<in> carrier G"
   shows "a divides b \<longleftrightarrow> factor_mset G a \<subseteq># factor_mset G b"
 proof -
-  obtain as where as_def: 
-    "factor_mset G a = fmset G as" 
+  obtain as where as_def:
+    "factor_mset G a = fmset G as"
     "wfactors G as a" "set as \<subseteq> carrier G"
     using factor_mset_aux assms by blast
-  obtain bs where bs_def: 
-    "factor_mset G b = fmset G bs" 
+  obtain bs where bs_def:
+    "factor_mset G b = fmset G bs"
     "wfactors G bs b" "set bs \<subseteq> carrier G"
     using factor_mset_aux assms(2) by blast
   hence "a divides b \<longleftrightarrow> fmset G as \<subseteq># fmset G bs"
     using as_def bs_def assms
     by (intro divides_as_fmsubset) auto
   also have "... \<longleftrightarrow> factor_mset G a \<subseteq># factor_mset G b"
     using as_def bs_def by simp
   finally show ?thesis by simp
 qed
 
 lemma factor_mset_sim:
   assumes "a \<in> carrier G" "b \<in> carrier G"
   shows "a \<sim> b \<longleftrightarrow> factor_mset G a = factor_mset G b"
   using factor_mset_divides assms
   by (simp add:associated_def) auto
 
 lemma factor_mset_prod:
   assumes "finite A"
-  assumes "f ` A \<subseteq> carrier G" 
-  shows "factor_mset G (\<Otimes>a \<in> A. f a) = 
+  assumes "f ` A \<subseteq> carrier G"
+  shows "factor_mset G (\<Otimes>a \<in> A. f a) =
     (\<Sum>a \<in> A. factor_mset G (f a))"
   using assms
 proof (induction A rule:finite_induct)
   case empty
   then show ?case by (simp add:factor_mset_unit)
 next
   case (insert x F)
-  have "factor_mset G (finprod G f (insert x F)) = 
+  have "factor_mset G (finprod G f (insert x F)) =
     factor_mset G (f x \<otimes> finprod G f F)"
     using insert by (subst finprod_insert) auto
   also have "... = factor_mset G (f x) + factor_mset G (finprod G f F)"
     using insert by (intro factor_mset_mult finprod_closed) auto
-  also have 
+  also have
     "... = factor_mset G (f x) + (\<Sum>a \<in> F. factor_mset G (f a))"
     using insert by simp
   also have "... = (\<Sum>a\<in>insert x F. factor_mset G (f a))"
     using insert by simp
   finally show ?case by simp
 qed
 
 lemma factor_mset_pow:
   assumes "a \<in> carrier G"
   shows "factor_mset G (a [^] n) = repeat_mset n (factor_mset G a)"
 proof (induction n)
   case 0
   then show ?case by (simp add:factor_mset_unit)
 next
   case (Suc n)
   have "factor_mset G (a [^] Suc n) = factor_mset G (a [^] n \<otimes> a)"
     by simp
   also have "... = factor_mset G (a [^] n) + factor_mset G a"
     using assms by (intro factor_mset_mult) auto
   also have "... = repeat_mset n (factor_mset G a) + factor_mset G a"
     using Suc by simp
   also have "... = repeat_mset (Suc n) (factor_mset G a)"
     by simp
   finally show ?case by simp
 qed
 
 lemma image_mset_sum:
   assumes "finite F"
-  shows 
+  shows
     "image_mset h (\<Sum>x \<in> F. f x) = (\<Sum>x \<in> F. image_mset h (f x))"
   using assms
   by (induction F rule:finite_induct, simp, simp)
 
-lemma decomp_mset: 
+lemma decomp_mset:
   "(\<Sum>x\<in>set_mset R. replicate_mset (count R x) x) = R"
   by (rule multiset_eqI, simp add:count_sum count_eq_zero_iff)
 
 lemma factor_mset_count:
   assumes "a \<in> carrier G" "d \<in> carrier G" "irreducible G d"
   shows "count (factor_mset G a) (assocs G d) = multiplicity G d a"
 proof -
-  have a: 
+  have a:
     "count (factor_mset G a) (assocs G d) \<ge> m \<longleftrightarrow> d [^] m divides a"
     (is "?lhs \<longleftrightarrow> ?rhs") for m
   proof -
     have "?lhs \<longleftrightarrow> replicate_mset m (assocs G d) \<subseteq># factor_mset G a"
       by (simp add:count_le_replicate_mset_subset_eq)
     also have "... \<longleftrightarrow> factor_mset G (d [^] m) \<subseteq># factor_mset G a"
       using assms(2,3) by (simp add:factor_mset_pow factor_mset_irred)
     also have "... \<longleftrightarrow> ?rhs"
       using assms(1,2) by (subst factor_mset_divides) auto
     finally show ?thesis by simp
   qed
 
   define M where "M = {(m::nat). d [^] m divides a}"
 
   have M_alt: "M = {m. m \<le> count (factor_mset G a) (assocs G d)}"
     using a by (simp add:M_def)
 
   hence "Max M = count (factor_mset G a) (assocs G d)"
     by (intro Max_eqI, auto)
   thus ?thesis
     unfolding multiplicity_def M_def by auto
 qed
 
 lemma multiplicity_ge_iff:
   assumes "d \<in> carrier G" "irreducible G d" "a \<in> carrier G"
-  shows "multiplicity G d a \<ge> k \<longleftrightarrow> d [^] k divides a" 
+  shows "multiplicity G d a \<ge> k \<longleftrightarrow> d [^] k divides a"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   have "?lhs \<longleftrightarrow> count (factor_mset G a) (assocs G d) \<ge> k"
     using factor_mset_count[OF assms(3,1,2)] by simp
   also have "... \<longleftrightarrow> replicate_mset k (assocs G d) \<subseteq># factor_mset G a"
-    by (subst count_le_replicate_mset_subset_eq, simp) 
+    by (subst count_le_replicate_mset_subset_eq, simp)
   also have "... \<longleftrightarrow>
-    repeat_mset k (factor_mset G d) \<subseteq># factor_mset G a" 
+    repeat_mset k (factor_mset G d) \<subseteq># factor_mset G a"
     by (subst factor_mset_irred[OF assms(1,2)], simp)
-  also have "... \<longleftrightarrow> factor_mset G (d [^]\<^bsub>G\<^esub> k) \<subseteq># factor_mset G a" 
+  also have "... \<longleftrightarrow> factor_mset G (d [^]\<^bsub>G\<^esub> k) \<subseteq># factor_mset G a"
     by (subst factor_mset_pow[OF assms(1)], simp)
   also have "... \<longleftrightarrow> (d [^] k) divides\<^bsub>G\<^esub> a"
     using assms(1) factor_mset_divides[OF _ assms(3)] by simp
   finally show ?thesis by simp
 qed
 
 lemma multiplicity_gt_0_iff:
   assumes "d \<in> carrier G" "irreducible G d" "a \<in> carrier G"
   shows "multiplicity G d a > 0 \<longleftrightarrow> d divides a"
   using multiplicity_ge_iff[OF assms(1,2,3), where k="1"] assms
   by auto
 
 lemma factor_mset_count_2:
-  assumes "a \<in> carrier G" 
+  assumes "a \<in> carrier G"
   assumes "\<And>z. z \<in> carrier G \<Longrightarrow> irreducible G z \<Longrightarrow> y \<noteq> assocs G z"
   shows "count (factor_mset G a) y = 0"
   using factor_mset_set [OF assms(1)] assms(2) by (metis count_inI)
 
 lemma factor_mset_choose:
   assumes "a \<in> carrier G" "set_mset R \<subseteq> carrier G"
-  assumes "image_mset (assocs G) R = factor_mset G a" 
+  assumes "image_mset (assocs G) R = factor_mset G a"
   shows "a \<sim> (\<Otimes>x\<in>set_mset R. x [^] count R x)" (is "a \<sim> ?rhs")
 proof -
   have b:"irreducible G x" if a:"x \<in># R" for x
   proof -
-    have x_carr: "x \<in> carrier G" 
+    have x_carr: "x \<in> carrier G"
       using a assms(2) by auto
     have "assocs G x \<in> assocs G ` set_mset R"
       using a by simp
     hence "assocs G x \<in># factor_mset G a"
       using assms(3) a in_image_mset by metis
-    then obtain z where z_def: 
+    then obtain z where z_def:
       "z \<in> carrier G" "irreducible G z" "assocs G x = assocs G z"
       using factor_mset_set assms(1) by metis
-    have "z \<sim> x" using z_def(1,3) assocs_eqD x_carr by simp 
+    have "z \<sim> x" using z_def(1,3) assocs_eqD x_carr by simp
     thus ?thesis using z_def(1,2) x_carr irreducible_cong by simp
   qed
 
-  have "factor_mset G ?rhs = 
+  have "factor_mset G ?rhs =
     (\<Sum>x\<in>set_mset R. factor_mset G (x [^] count R x))"
-    using assms(2) by (subst factor_mset_prod, auto) 
-  also have "... = 
+    using assms(2) by (subst factor_mset_prod, auto)
+  also have "... =
     (\<Sum>x\<in>set_mset R. repeat_mset (count R x) (factor_mset G x))"
     using assms(2) by (intro sum.cong, auto simp add:factor_mset_pow)
-  also have "... = (\<Sum>x\<in>set_mset R. 
+  also have "... = (\<Sum>x\<in>set_mset R.
     repeat_mset (count R x) (image_mset (assocs G) {#x#}))"
     using assms(2) b by (intro sum.cong, auto simp add:factor_mset_irred)
-  also have "... = (\<Sum>x\<in>set_mset R. 
+  also have "... = (\<Sum>x\<in>set_mset R.
     image_mset (assocs G) (replicate_mset (count R x) x))"
     by simp
-  also have "... = image_mset (assocs G) 
+  also have "... = image_mset (assocs G)
     (\<Sum>x\<in>set_mset R. (replicate_mset (count R x) x))"
     by (simp add: image_mset_sum)
   also have "... = image_mset (assocs G) R"
     by (simp add:decomp_mset)
   also have "... = factor_mset G a"
     using assms by simp
   finally have "factor_mset G ?rhs = factor_mset G a" by simp
   moreover have "(\<Otimes>x\<in>set_mset R. x [^] count R x) \<in> carrier G"
     using assms(2) by (intro finprod_closed, auto)
-  ultimately show ?thesis 
+  ultimately show ?thesis
     using assms(1) by (subst factor_mset_sim) auto
 qed
 
 lemma divides_iff_mult_mono:
-  assumes "a \<in> carrier G" "b \<in> carrier G" 
+  assumes "a \<in> carrier G" "b \<in> carrier G"
   assumes "canonical_irreducibles G R"
   assumes "\<And>d. d \<in> R \<Longrightarrow> multiplicity G d a \<le> multiplicity G d b"
   shows "a divides b"
 proof -
   have "count (factor_mset G a) d \<le> count (factor_mset G b) d" for d
   proof (cases "\<exists>y \<in> carrier G. irreducible G y \<and> d = assocs G y")
     case True
-    then obtain y where y_def: 
+    then obtain y where y_def:
       "irreducible G y" "y \<in> carrier G" "d = assocs G y"
       by blast
     then obtain z where z_def: "z \<in> R" "y \<sim> z"
       using assms(3) unfolding canonical_irreducibles_def by metis
     have z_more: "irreducible G z" "z \<in> carrier G"
       using z_def(1) assms(3)
       unfolding canonical_irreducibles_def by auto
-    have "y \<in> assocs G z" using z_def(2) z_more(2) y_def(2) 
+    have "y \<in> assocs G z" using z_def(2) z_more(2) y_def(2)
       by (simp add: closure_ofI2)
     hence d_def: "d = assocs G z"
       using y_def(2,3) z_more(2) assocs_repr_independence
       by blast
     have "count (factor_mset G a) d = multiplicity G z a"
       unfolding d_def
       by (intro factor_mset_count[OF assms(1) z_more(2,1)])
     also have "... \<le> multiplicity G z b"
       using assms(4) z_def(1) by simp
     also have "... = count (factor_mset G b) d"
       unfolding d_def
       by (intro factor_mset_count[symmetric, OF assms(2) z_more(2,1)])
-    finally show ?thesis by simp 
+    finally show ?thesis by simp
   next
     case False
     have "count (factor_mset G a) d = 0" using False
       by (intro factor_mset_count_2[OF assms(1)], simp)
     moreover have "count (factor_mset G b) d = 0" using False
       by (intro factor_mset_count_2[OF assms(2)], simp)
     ultimately show ?thesis by simp
   qed
 
-  hence "factor_mset G a \<subseteq># factor_mset G b" 
+  hence "factor_mset G a \<subseteq># factor_mset G b"
     unfolding subseteq_mset_def by simp
   thus ?thesis using factor_mset_divides assms(1,2) by simp
 qed
 
 lemma count_image_mset_inj:
   assumes "inj_on f R" "x \<in> R" "set_mset A \<subseteq> R"
   shows "count (image_mset f A) (f x) = count A x"
 proof (cases "x \<in># A")
   case True
-  hence "(f y = f x \<and> y \<in># A) = (y = x)" for y 
+  hence "(f y = f x \<and> y \<in># A) = (y = x)" for y
     by (meson assms(1) assms(3) inj_onD subsetD)
-  hence "(f -` {f x} \<inter> set_mset A) = {x}" 
+  hence "(f -` {f x} \<inter> set_mset A) = {x}"
     by (simp add:set_eq_iff)
   thus ?thesis
     by (subst count_image_mset, simp)
 next
   case False
   hence "x \<notin> set_mset A" by simp
   hence "f x \<notin> f ` set_mset A" using assms
     by (simp add: inj_on_image_mem_iff)
-  hence "count (image_mset f A) (f x) = 0" 
+  hence "count (image_mset f A) (f x) = 0"
     by (simp add:count_eq_zero_iff)
   thus ?thesis by (metis count_inI False)
 qed
 
-text \<open>Factorization of an element from a @{locale "factorial_monoid"} using a selection of representatives 
+text \<open>Factorization of an element from a @{locale "factorial_monoid"} using a selection of representatives
 from each equivalence class formed by @{term "(\<sim>)"}.\<close>
 
 lemma split_factors:
   assumes "canonical_irreducibles G R"
   assumes "a \<in> carrier G"
-  shows 
+  shows
     "finite {d. d \<in> R \<and> multiplicity G d a > 0}"
-    "a \<sim> (\<Otimes>d\<in>{d. d \<in> R \<and> multiplicity G d a > 0}. 
+    "a \<sim> (\<Otimes>d\<in>{d. d \<in> R \<and> multiplicity G d a > 0}.
           d [^] multiplicity G d a)" (is "a \<sim> ?rhs")
 proof -
-  have r_1: "R \<subseteq> {x. x \<in> carrier G \<and> irreducible G x}" 
-    using assms(1) unfolding canonical_irreducibles_def by simp
-  have r_2: "\<And>x y. x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> x \<sim> y \<Longrightarrow> x = y" 
+  have r_1: "R \<subseteq> {x. x \<in> carrier G \<and> irreducible G x}"
     using assms(1) unfolding canonical_irreducibles_def by simp
-  
+  have r_2: "\<And>x y. x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> x \<sim> y \<Longrightarrow> x = y"
+    using assms(1) unfolding canonical_irreducibles_def by simp
+
   have assocs_inj: "inj_on (assocs G) R"
-    using r_1 r_2 assocs_eqD by (intro inj_onI, blast) 
-  
+    using r_1 r_2 assocs_eqD by (intro inj_onI, blast)
+
   define R' where
     "R' = (\<Sum>d\<in> {d. d \<in> R \<and> multiplicity G d a > 0}.
     replicate_mset (multiplicity G d a) d)"
 
-  have "count (factor_mset G a) (assocs G x) > 0" 
+  have "count (factor_mset G a) (assocs G x) > 0"
     if "x \<in> R" "0 < multiplicity G x a" for x
     using assms r_1 r_2 that
     by (subst factor_mset_count[OF assms(2)]) auto
-  hence "assocs G ` {d \<in> R. 0 < multiplicity G d a} 
+  hence "assocs G ` {d \<in> R. 0 < multiplicity G d a}
     \<subseteq> set_mset (factor_mset G a)"
     by (intro image_subsetI, simp)
   hence a:"finite (assocs G ` {d \<in> R. 0 < multiplicity G d a})"
     using finite_subset by auto
 
-  show "finite {d \<in> R. 0 < multiplicity G d a}" 
+  show "finite {d \<in> R. 0 < multiplicity G d a}"
     using assocs_inj inj_on_subset[OF assocs_inj]
     by (intro finite_imageD[OF a], simp)
 
-  hence count_R': 
+  hence count_R':
     "count R' d = (if d \<in> R then multiplicity G d a else 0)"
     for d
-    by (auto simp add:R'_def count_sum) 
+    by (auto simp add:R'_def count_sum)
 
   have set_R': "set_mset R' = {d \<in> R. 0 < multiplicity G d a}"
     unfolding set_mset_def using count_R' by auto
 
-  have "count (image_mset (assocs G) R') x = 
+  have "count (image_mset (assocs G) R') x =
     count (factor_mset G a) x" for x
   proof (cases "\<exists>x'. x' \<in> R \<and> x = assocs G x'")
     case True
     then obtain x' where x'_def: "x' \<in> R" "x = assocs G x'"
       by blast
     have "count (image_mset (assocs G) R') x = count R' x'"
       using assocs_inj inj_on_subset[OF assocs_inj] x'_def
       by (subst x'_def(2), subst count_image_mset_inj[OF assocs_inj])
-        (auto simp:set_R') 
+        (auto simp:set_R')
     also have "... = multiplicity G x' a"
       using count_R' x'_def by simp
     also have "... = count (factor_mset G a) (assocs G x')"
       using x'_def(1) r_1
       by (subst factor_mset_count[OF assms(2)]) auto
     also have "... = count (factor_mset G a) x"
       using x'_def(2) by simp
     finally show ?thesis by simp
   next
     case False
-    have a:"x \<noteq> assocs G z" 
+    have a:"x \<noteq> assocs G z"
       if a1: "z \<in> carrier G" and a2: "irreducible G z" for z
     proof -
       obtain v where v_def: "v \<in> R" "z \<sim> v"
         using a1 a2 assms(1)
         unfolding canonical_irreducibles_def by auto
       hence "z \<in> assocs G v"
         using a1 r_1 v_def(1) by (simp add: closure_ofI2)
       hence "assocs G z = assocs G v"
         using a1 r_1 v_def(1)  assocs_repr_independence
         by auto
       moreover have "x \<noteq> assocs G v"
         using False v_def(1) by simp
       ultimately show ?thesis by simp
     qed
 
     have "count (image_mset (assocs G) R') x = 0"
       using False count_R' by (simp add: count_image_mset) auto
     also have "... = count (factor_mset G a) x"
       using a
-      by (intro factor_mset_count_2[OF assms(2), symmetric]) auto 
+      by (intro factor_mset_count_2[OF assms(2), symmetric]) auto
     finally show ?thesis by simp
   qed
 
   hence "image_mset (assocs G) R' = factor_mset G a"
     by (rule multiset_eqI)
 
-  moreover have "set_mset R' \<subseteq> carrier G" 
-    using r_1 by (auto simp add:set_R') 
+  moreover have "set_mset R' \<subseteq> carrier G"
+    using r_1 by (auto simp add:set_R')
   ultimately have "a \<sim> (\<Otimes>x\<in>set_mset R'. x [^] count R' x)"
     using assms(2) by (intro factor_mset_choose, auto)
   also have "... = ?rhs"
     using set_R' assms r_1 r_2
     by (intro finprod_cong', auto simp add:count_R')
   finally show "a \<sim> ?rhs" by simp
 qed
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Indexed_Algebra_Code.thy b/thys/Finite_Fields/Finite_Fields_Indexed_Algebra_Code.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Finite_Fields_Indexed_Algebra_Code.thy
@@ -0,0 +1,194 @@
+section \<open>Executable Structures\<close>
+
+theory Finite_Fields_Indexed_Algebra_Code
+  imports "HOL-Algebra.Ring" "HOL-Algebra.Coset"
+begin
+
+text \<open>In the following, we introduce records for executable operations for algebraic structures,
+which can be used for code-generation and evaluation. These are then shown to be equivalent to the
+(not-necessarily constructive) definitions using \<^verbatim>\<open>HOL-Algebra\<close>. A more direct approach, i.e.,
+instantiating the structures in the framework with effective operations fails. For example the
+structure records represent the domain of the algebraic structure as a set, which implies the
+evaluation of @{term "(\<oplus>\<^bsub>residue_ring (10^100)\<^esub>)"} requires the construction of
+@{term "{0..10^100-1}"}. This is technically constructive but very impractical.
+Moreover, the additive/multiplicative inverse is defined non-constructively using the
+description operator \<^verbatim>\<open>THE\<close> in \<^verbatim>\<open>HOL-Algebra\<close>.
+
+The above could be avoided, if it were possible to introduce code equations conditionally, e.g.,
+for example for @{term "a_inv (residue_ring n) x y"} (if @{term "x y"} are in the carrier of the
+structure, but this does not seem to be possible.
+
+Note that, the algebraic structures defined in \<^verbatim>\<open>HOL-Computational_Algebra\<close> are type-based,
+which prevents using them in some algorithmic settings. For example, choosing an
+irreducible polynomial dynamically and performing operations in the factoring ring with respect to
+it is not possible in the type-based approach.\<close>
+
+record 'a idx_ring =
+  idx_pred :: "'a \<Rightarrow> bool"
+  idx_uminus :: "'a \<Rightarrow> 'a"
+  idx_plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+  idx_udivide :: "'a \<Rightarrow> 'a"
+  idx_mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
+  idx_zero :: "'a"
+  idx_one :: "'a"
+
+record 'a idx_ring_enum = "'a idx_ring" +
+  idx_size :: nat
+  idx_enum :: "nat \<Rightarrow> 'a"
+  idx_enum_inv :: "'a \<Rightarrow> nat"
+
+fun idx_pow :: "('a,'b) idx_ring_scheme  \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
+  "idx_pow E x 0 = idx_one E" |
+  "idx_pow E x (Suc n) = idx_mult E (idx_pow E x n) x"
+
+bundle index_algebra_notation
+begin
+notation idx_zero ("0\<^sub>C\<index>")
+notation idx_one ("1\<^sub>C\<index>")
+notation idx_plus (infixl "+\<^sub>C\<index>" 65)
+notation idx_mult (infixl "*\<^sub>C\<index>" 70)
+notation idx_uminus ("-\<^sub>C\<index> _" [81] 80)
+notation idx_udivide ("_ \<inverse>\<^sub>C\<index>" [81] 80)
+notation idx_pow  (infixr "^\<^sub>C\<index>" 75)
+end
+unbundle index_algebra_notation
+
+bundle no_index_algebra_notation
+begin
+no_notation idx_zero ("0\<^sub>C\<index>")
+no_notation idx_one ("1\<^sub>C\<index>")
+no_notation idx_plus (infixl "+\<^sub>C\<index>" 65)
+no_notation idx_mult (infixl "*\<^sub>C\<index>" 70)
+no_notation idx_uminus ("-\<^sub>C\<index> _" [81] 80)
+no_notation idx_udivide ("_ \<inverse>\<^sub>C\<index>" [81] 80)
+no_notation idx_pow  (infixr "^\<^sub>C\<index>" 75)
+end
+
+definition ring_of :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a ring"
+  where "ring_of A = \<lparr>
+    carrier = {x. idx_pred A x},
+    mult = (\<lambda> x y. x *\<^sub>C\<^bsub>A\<^esub> y),
+    one = 1\<^sub>C\<^bsub>A\<^esub>,
+    zero = 0\<^sub>C\<^bsub>A\<^esub>,
+    add = (\<lambda> x y. x +\<^sub>C\<^bsub>A\<^esub> y) \<rparr>"
+
+definition ring\<^sub>C where
+  "ring\<^sub>C A = (ring (ring_of A) \<and> (\<forall>x. idx_pred A x \<longrightarrow> -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x) \<and>
+    (\<forall>x. x \<in> Units (ring_of A) \<longrightarrow> x \<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x))"
+
+lemma ring_cD_aux:
+  "x ^\<^sub>C\<^bsub>A\<^esub> n = x [^]\<^bsub>ring_of A\<^esub> n"
+  by (induction n) (auto simp:ring_of_def)
+
+lemma ring_cD:
+  assumes "ring\<^sub>C A"
+  shows
+    "0\<^sub>C\<^bsub>A\<^esub> = \<zero>\<^bsub>ring_of A\<^esub>"
+    "1\<^sub>C\<^bsub>A\<^esub> = \<one>\<^bsub>ring_of A\<^esub>"
+    "\<And>x y. x *\<^sub>C\<^bsub>A\<^esub> y = x \<otimes>\<^bsub>ring_of A\<^esub> y"
+    "\<And>x y. x +\<^sub>C\<^bsub>A\<^esub> y = x \<oplus>\<^bsub>ring_of A\<^esub> y"
+    "\<And>x. x \<in> carrier (ring_of A) \<Longrightarrow>  -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x"
+    "\<And>x. x \<in> Units (ring_of A) \<Longrightarrow>  x \<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x"
+    "\<And>x. x ^\<^sub>C\<^bsub>A\<^esub> n = x [^]\<^bsub>ring_of A\<^esub> n"
+  using assms ring_cD_aux unfolding ring\<^sub>C_def ring_of_def by auto
+
+lemma ring_cI:
+  assumes "ring (ring_of A)"
+  assumes "\<And>x. x \<in> carrier (ring_of A) \<Longrightarrow>  -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x"
+  assumes "\<And>x. x \<in> Units (ring_of A) \<Longrightarrow>  x\<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x"
+  shows "ring\<^sub>C A"
+proof -
+  have " x \<in> carrier (ring_of A) \<longleftrightarrow> idx_pred A x" for x unfolding ring_of_def by auto
+  thus ?thesis using assms unfolding ring\<^sub>C_def by auto
+qed
+
+definition cring\<^sub>C where "cring\<^sub>C A = (ring\<^sub>C A \<and> cring (ring_of A))"
+
+lemma cring_cI:
+  assumes "cring (ring_of A)"
+  assumes "\<And>x. x \<in> carrier (ring_of A) \<Longrightarrow>  -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x"
+  assumes "\<And>x. x \<in> Units (ring_of A) \<Longrightarrow> x\<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x"
+  shows "cring\<^sub>C A"
+  unfolding cring\<^sub>C_def by (intro ring_cI conjI assms cring.axioms(1))
+
+lemma cring_c_imp_ring: "cring\<^sub>C A \<Longrightarrow> ring\<^sub>C A"
+  unfolding cring\<^sub>C_def by simp
+
+lemmas cring_cD = ring_cD[OF cring_c_imp_ring]
+
+definition domain\<^sub>C where "domain\<^sub>C A = (cring\<^sub>C A \<and> domain (ring_of A))"
+
+lemma domain_cI:
+  assumes "domain (ring_of A)"
+  assumes "\<And>x. x \<in> carrier (ring_of A) \<Longrightarrow>  -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x"
+  assumes "\<And>x. x \<in> Units (ring_of A) \<Longrightarrow> x\<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x"
+  shows "domain\<^sub>C A"
+  unfolding domain\<^sub>C_def by (intro conjI cring_cI assms domain.axioms(1))
+
+lemma domain_c_imp_ring: "domain\<^sub>C A \<Longrightarrow> ring\<^sub>C A"
+  unfolding cring\<^sub>C_def domain\<^sub>C_def by simp
+
+lemmas domain_cD = ring_cD[OF domain_c_imp_ring]
+
+definition field\<^sub>C where "field\<^sub>C A = (domain\<^sub>C A \<and> field (ring_of A))"
+
+lemma field_cI:
+  assumes "field (ring_of A)"
+  assumes "\<And>x. x \<in> carrier (ring_of A) \<Longrightarrow>  -\<^sub>C\<^bsub>A\<^esub> x = \<ominus>\<^bsub>ring_of A\<^esub> x"
+  assumes "\<And>x. x \<in> Units (ring_of A) \<Longrightarrow>  x\<inverse>\<^sub>C\<^bsub>A\<^esub> = inv\<^bsub>ring_of A\<^esub> x"
+  shows "field\<^sub>C A"
+  unfolding field\<^sub>C_def by (intro conjI domain_cI assms field.axioms(1))
+
+lemma field_c_imp_ring: "field\<^sub>C A \<Longrightarrow> ring\<^sub>C A"
+  unfolding field\<^sub>C_def cring\<^sub>C_def domain\<^sub>C_def by simp
+
+lemmas field_cD = ring_cD[OF field_c_imp_ring]
+
+definition enum\<^sub>C where "enum\<^sub>C A = (
+  finite (carrier (ring_of A)) \<and>
+  idx_size A = order (ring_of A) \<and>
+  bij_betw (idx_enum A) {..<order (ring_of A)} (carrier (ring_of A)) \<and>
+  (\<forall>x < order (ring_of A). idx_enum_inv A (idx_enum A x) = x))"
+
+lemma enum_cI:
+  assumes "finite (carrier (ring_of A))"
+  assumes "idx_size A = order (ring_of A)"
+  assumes "bij_betw (idx_enum A) {..<order (ring_of A)} (carrier (ring_of A))"
+  assumes "\<And>x. x < order (ring_of A) \<Longrightarrow> idx_enum_inv A (idx_enum A x) = x"
+  shows "enum\<^sub>C A"
+  using assms unfolding enum\<^sub>C_def by auto
+
+lemma enum_cD:
+  assumes "enum\<^sub>C R"
+  shows "finite (carrier (ring_of R))"
+    and "idx_size R = order (ring_of R)"
+    and "bij_betw (idx_enum R) {..<order (ring_of R)} (carrier (ring_of R))"
+    and "bij_betw (idx_enum_inv R) (carrier (ring_of R)) {..<order (ring_of R)}"
+    and "\<And>x. x < order (ring_of R) \<Longrightarrow> idx_enum_inv R (idx_enum R x) = x"
+    and "\<And>x. x \<in> carrier (ring_of R) \<Longrightarrow> idx_enum R (idx_enum_inv R x) = x"
+  using assms
+proof -
+  let ?n = "order (ring_of R)"
+  have a:"idx_enum_inv R x = the_inv_into {..<?n} (idx_enum R) x"
+    if x_carr: "x \<in> carrier (ring_of R)" for x
+  proof -
+    have "idx_enum R ` {..<order (ring_of R)} = carrier (ring_of R)"
+      using assms unfolding bij_betw_def enum\<^sub>C_def by simp
+    then obtain y where y_carr: "y \<in> {..< order (ring_of R)}" and x_def: "x = idx_enum R y"
+      using x_carr by auto
+    have "idx_enum_inv R x = y" using assms y_carr unfolding x_def enum\<^sub>C_def by simp
+    also have "... = the_inv_into {..<?n} (idx_enum R) x"
+      using assms unfolding bij_betw_def enum\<^sub>C_def unfolding x_def
+      by (intro the_inv_into_f_f[symmetric] y_carr) auto
+    finally show ?thesis by simp
+  qed
+
+  have "bij_betw (the_inv_into {..<?n} (idx_enum R)) (carrier (ring_of R)) {..<?n}"
+    using assms unfolding enum\<^sub>C_def by (intro bij_betw_the_inv_into) auto
+  thus "bij_betw (idx_enum_inv R) (carrier (ring_of R)) {..<order (ring_of R)}"
+    by (subst bij_betw_cong[OF a]) auto
+  show "idx_enum R (idx_enum_inv R x) = x" if "x \<in> carrier (ring_of R)" for x
+    using that assms unfolding a[OF that] enum\<^sub>C_def bij_betw_def by (intro f_the_inv_into_f) auto
+qed (use assms enum\<^sub>C_def in auto)
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Isomorphic.thy b/thys/Finite_Fields/Finite_Fields_Isomorphic.thy
--- a/thys/Finite_Fields/Finite_Fields_Isomorphic.thy
+++ b/thys/Finite_Fields/Finite_Fields_Isomorphic.thy
@@ -1,367 +1,367 @@
 section \<open>Isomorphism between Finite Fields\label{sec:uniqueness}\<close>
 
 theory Finite_Fields_Isomorphic
   imports
     Card_Irreducible_Polynomials
 begin
 
 lemma (in finite_field) eval_on_root_is_iso:
   defines "p \<equiv> char R"
-  assumes "f \<in> carrier (poly_ring (ZFact p))" 
-  assumes "pirreducible\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f" 
+  assumes "f \<in> carrier (poly_ring (ZFact p))"
+  assumes "pirreducible\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f"
   assumes "order R = p^degree f"
-  assumes "x \<in> carrier R" 
+  assumes "x \<in> carrier R"
   assumes "eval (map (char_iso R) f) x = \<zero>"
-  shows "ring_hom_ring (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R 
+  shows "ring_hom_ring (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R
     (\<lambda>g. the_elem ((\<lambda>g'. eval (map (char_iso R) g') x) ` g))"
 proof -
   let ?P = "poly_ring (ZFact p)"
 
   have char_pos: "char R > 0"
     using finite_carr_imp_char_ge_0[OF finite_carrier] by simp
 
-  have p_prime: "Factorial_Ring.prime p" 
-    unfolding p_def 
+  have p_prime: "Factorial_Ring.prime p"
+    unfolding p_def
     using characteristic_is_prime[OF char_pos] by simp
 
   interpret zf: finite_field "ZFact p"
     using zfact_prime_is_finite_field p_prime by simp
   interpret pzf: principal_domain "poly_ring (ZFact p)"
     using zf.univ_poly_is_principal[OF zf.carrier_is_subfield] by simp
 
-  interpret i: ideal "(PIdl\<^bsub>?P\<^esub> f)" "?P" 
+  interpret i: ideal "(PIdl\<^bsub>?P\<^esub> f)" "?P"
     by (intro pzf.cgenideal_ideal assms(2))
   have rupt_carr: "y \<subseteq> carrier (poly_ring (ZFact p))"
     if "y \<in> carrier (Rupt\<^bsub>ZFact p\<^esub> (carrier (ZFact p)) f)" for y
     using that pzf.quot_carr i.ideal_axioms by (simp add:rupture_def)
 
   have rupt_is_ring: "ring (Rupt\<^bsub>ZFact p\<^esub> (carrier (ZFact p)) f)"
     unfolding rupture_def by (intro i.quotient_is_ring)
 
-  have "map (char_iso R) \<in> 
+  have "map (char_iso R) \<in>
     ring_iso ?P (poly_ring (R\<lparr>carrier := char_subring R\<rparr>))"
-    using lift_iso_to_poly_ring[OF char_iso] zf.domain_axioms 
+    using lift_iso_to_poly_ring[OF char_iso] zf.domain_axioms
     using char_ring_is_subdomain subdomain_is_domain
     by (simp add:p_def)
-  moreover have "(char_subring R)[X] = 
+  moreover have "(char_subring R)[X] =
     poly_ring (R \<lparr>carrier := char_subring R\<rparr>)"
     using univ_poly_consistent[OF char_ring_is_subring] by simp
-  ultimately have 
+  ultimately have
     "map (char_iso R) \<in> ring_hom ?P ((char_subring R)[X])"
     by (simp add:ring_iso_def)
   moreover have "(\<lambda>p. eval p x) \<in> ring_hom ((char_subring R)[X]) R"
     using eval_is_hom char_ring_is_subring assms(5) by simp
-  ultimately have 
+  ultimately have
     "(\<lambda>p. eval p x) \<circ> map (char_iso R) \<in> ring_hom ?P R"
     using ring_hom_trans by blast
   hence a:"(\<lambda>p. eval (map (char_iso R) p) x) \<in> ring_hom ?P R"
     by (simp add:comp_def)
   interpret h:ring_hom_ring "?P" "R" "(\<lambda>p. eval (map (char_iso R) p) x)"
     by (intro ring_hom_ringI2 pzf.ring_axioms a ring_axioms)
 
   let ?h = "(\<lambda>p. eval (map (char_iso R) p) x)"
   let ?J = "a_kernel (poly_ring (ZFact (int p))) R ?h"
 
   have "?h ` a_kernel (poly_ring (ZFact (int p))) R ?h \<subseteq> {\<zero>}"
     by auto
-  moreover have 
-    "\<zero>\<^bsub>?P\<^esub> \<in> a_kernel (poly_ring (ZFact (int p))) R ?h" 
-    "?h \<zero>\<^bsub>?P\<^esub> = \<zero>" 
+  moreover have
+    "\<zero>\<^bsub>?P\<^esub> \<in> a_kernel (poly_ring (ZFact (int p))) R ?h"
+    "?h \<zero>\<^bsub>?P\<^esub> = \<zero>"
     unfolding a_kernel_def' by simp_all
   hence "{\<zero>} \<subseteq> ?h ` a_kernel (poly_ring (ZFact (int p))) R ?h"
     by simp
   ultimately have c:
     "?h ` a_kernel (poly_ring (ZFact (int p))) R ?h = {\<zero>}"
     by auto
 
   have d: "PIdl\<^bsub>?P\<^esub> f \<subseteq> a_kernel ?P R ?h"
-  proof (rule subsetI) 
+  proof (rule subsetI)
     fix y assume "y \<in> PIdl\<^bsub>?P\<^esub> f"
-    then obtain y' where y'_def: "y' \<in> carrier ?P" "y = y' \<otimes>\<^bsub>?P\<^esub> f" 
+    then obtain y' where y'_def: "y' \<in> carrier ?P" "y = y' \<otimes>\<^bsub>?P\<^esub> f"
       unfolding cgenideal_def by auto
     have "?h y = ?h (y' \<otimes>\<^bsub>?P\<^esub> f)" by (simp add:y'_def)
     also have "... = ?h y' \<otimes> ?h f"
       using y'_def assms(2) by simp
     also have "... = ?h y' \<otimes> \<zero>"
       using assms(6) by simp
     also have "... = \<zero>"
       using y'_def by simp
     finally have "?h y = \<zero>" by simp
     moreover have "y \<in> carrier ?P" using y'_def assms(2) by simp
     ultimately show "y \<in> a_kernel ?P R ?h"
       unfolding a_kernel_def kernel_def by simp
   qed
 
-  have "(\<lambda>y. the_elem ((\<lambda>p. eval (map (char_iso R) p) x) ` y)) 
+  have "(\<lambda>y. the_elem ((\<lambda>p. eval (map (char_iso R) p) x) ` y))
     \<in> ring_hom (?P Quot ?J) R"
     using h.the_elem_hom by simp
-  moreover have "(\<lambda>y. ?J <+>\<^bsub>?P\<^esub> y) 
+  moreover have "(\<lambda>y. ?J <+>\<^bsub>?P\<^esub> y)
     \<in> ring_hom (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) (?P Quot ?J)"
     unfolding rupture_def using h.kernel_is_ideal d assms(2)
     by (intro pzf.quot_quot_hom pzf.cgenideal_ideal) auto
   ultimately have "(\<lambda>y. the_elem (?h ` y)) \<circ> (\<lambda>y. ?J <+>\<^bsub>?P\<^esub> y)
     \<in> ring_hom (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R"
     using ring_hom_trans by blast
-  hence b: "(\<lambda>y. the_elem (?h ` (?J <+>\<^bsub>?P\<^esub> y))) \<in> 
+  hence b: "(\<lambda>y. the_elem (?h ` (?J <+>\<^bsub>?P\<^esub> y))) \<in>
     ring_hom (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R"
     by (simp add:comp_def)
   have "?h ` y = ?h ` (?J <+>\<^bsub>?P\<^esub> y)"
     if "y \<in> carrier (Rupt\<^bsub>ZFact p\<^esub> (carrier (ZFact p)) f)"
     for y
   proof -
     have y_range: "y \<subseteq> carrier ?P"
       using rupt_carr that by simp
     have "?h ` y = {\<zero>} <+>\<^bsub>R\<^esub> ?h ` y"
       using y_range h.hom_closed by (subst set_add_zero, auto)
     also have "... = ?h ` ?J <+>\<^bsub>R\<^esub> ?h ` y"
       by (subst c, simp)
     also have "... = ?h ` (?J <+>\<^bsub>?P\<^esub> y)"
       by (subst set_add_hom[OF a _ y_range], subst a_kernel_def') auto
     finally show ?thesis by simp
   qed
-  hence "(\<lambda>y. the_elem (?h ` y)) \<in> 
+  hence "(\<lambda>y. the_elem (?h ` y)) \<in>
     ring_hom (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R"
     by (intro ring_hom_cong[OF _ rupt_is_ring b]) simp
   thus ?thesis
     by (intro ring_hom_ringI2 rupt_is_ring ring_axioms, simp)
 qed
 
 lemma (in domain) pdivides_consistent:
   assumes "subfield K R" "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
   shows "f pdivides g \<longleftrightarrow> f pdivides\<^bsub>R \<lparr> carrier := K \<rparr>\<^esub> g"
 proof -
-  have a:"subring K R" 
+  have a:"subring K R"
     using assms(1) subfieldE(1) by auto
   let ?S = "R \<lparr> carrier := K \<rparr>"
   have "f pdivides g \<longleftrightarrow> f divides\<^bsub>K[X]\<^esub> g"
     using pdivides_iff_shell[OF assms] by simp
   also have "... \<longleftrightarrow> (\<exists>x \<in> carrier (K[X]). f \<otimes>\<^bsub>K[X]\<^esub> x = g)"
     unfolding pdivides_def factor_def by auto
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (\<exists>x \<in> carrier (poly_ring ?S). f \<otimes>\<^bsub>poly_ring ?S\<^esub> x = g)"
     using univ_poly_consistent[OF a] by simp
   also have "... \<longleftrightarrow> f divides\<^bsub>poly_ring ?S\<^esub> g"
     unfolding pdivides_def factor_def by auto
   also have "... \<longleftrightarrow> f pdivides\<^bsub>?S\<^esub> g"
     unfolding pdivides_def by simp
   finally show ?thesis by simp
 qed
 
 lemma (in finite_field) find_root:
   assumes "subfield K R"
   assumes "monic_irreducible_poly (R \<lparr> carrier := K \<rparr>) f"
   assumes "order R = card K^degree f"
   obtains x where "eval f x = \<zero>" "x \<in> carrier R"
 proof -
   define \<tau> :: "'a list \<Rightarrow> 'a list" where "\<tau> = id"
   let ?K = "R \<lparr> carrier := K \<rparr>"
-  have "finite K" 
+  have "finite K"
     using assms(1) by (intro finite_subset[OF _ finite_carrier], simp)
-  hence fin_K: "finite (carrier (?K))" 
-    by simp 
+  hence fin_K: "finite (carrier (?K))"
+    by simp
   interpret f: finite_field "?K"
     using assms(1) subfield_iff fin_K finite_fieldI by blast
-  have b:"subring K R" 
+  have b:"subring K R"
     using assms(1) subfieldE(1) by blast
   interpret e: ring_hom_ring "(K[X])" "(poly_ring R)" "\<tau>"
     using embed_hom[OF b] by (simp add:\<tau>_def)
 
   have a: "card K^degree f > 1"
     using assms(3) finite_field_min_order by simp
   have "f \<in> carrier (poly_ring ?K)"
     using f.monic_poly_carr assms(2)
     unfolding monic_irreducible_poly_def by simp
   hence f_carr_2: "f \<in> carrier (K[X])"
     using univ_poly_consistent[OF b] by simp
   have f_carr: "f \<in> carrier (poly_ring R)"
     using e.hom_closed[OF f_carr_2] unfolding \<tau>_def by simp
 
   have gp_carr: "gauss_poly ?K (order ?K^degree f) \<in> carrier (K[X])"
     using f.gauss_poly_carr univ_poly_consistent[OF b] by simp
 
-  have "gauss_poly ?K (order ?K^degree f) = 
+  have "gauss_poly ?K (order ?K^degree f) =
     gauss_poly ?K (card K^degree f)"
     by (simp add:Coset.order_def)
-  also have "... = 
+  also have "... =
     X\<^bsub>?K\<^esub> [^]\<^bsub>poly_ring ?K\<^esub> card K ^ degree f \<ominus>\<^bsub>poly_ring ?K\<^esub> X\<^bsub>?K\<^esub>"
     unfolding gauss_poly_def by simp
   also have "... = X\<^bsub>R\<^esub> [^]\<^bsub>K[X]\<^esub> card K ^ degree f  \<ominus>\<^bsub>K[X]\<^esub> X\<^bsub>R\<^esub>"
     unfolding var_def using univ_poly_consistent[OF b] by simp
   also have "... = \<tau> (X\<^bsub>R\<^esub> [^]\<^bsub>K[X]\<^esub> card K ^ degree f  \<ominus>\<^bsub>K[X]\<^esub> X\<^bsub>R\<^esub>)"
     unfolding \<tau>_def by simp
   also have "... = gauss_poly R (card K^degree f)"
     unfolding gauss_poly_def a_minus_def using var_closed[OF b]
     by (simp add:e.hom_nat_pow, simp add:\<tau>_def)
-  finally have gp_consistent: "gauss_poly ?K (order ?K^degree f) = 
+  finally have gp_consistent: "gauss_poly ?K (order ?K^degree f) =
     gauss_poly R (card K^degree f)"
     by simp
 
-  have deg_f: "degree f > 0" 
+  have deg_f: "degree f > 0"
     using f.monic_poly_min_degree[OF assms(2)] by simp
 
   have "splitted f"
   proof (cases "degree f > 1")
     case True
-  
+
     have "f pdivides\<^bsub>?K\<^esub> gauss_poly ?K (order ?K^degree f)"
       using f.div_gauss_poly_iff[OF deg_f assms(2)] by simp
     hence "f pdivides gauss_poly ?K (order ?K^degree f)"
       using pdivides_consistent[OF assms(1)] f_carr_2 gp_carr by simp
     hence "f pdivides gauss_poly R (card K^degree f)"
       using gp_consistent by simp
-    moreover have "splitted (gauss_poly R (card K^degree f))" 
+    moreover have "splitted (gauss_poly R (card K^degree f))"
       unfolding assms(3)[symmetric] using gauss_poly_splitted by simp
-    moreover have "gauss_poly R (card K^degree f) \<noteq> []" 
+    moreover have "gauss_poly R (card K^degree f) \<noteq> []"
       using gauss_poly_not_zero a by (simp add: univ_poly_zero)
     ultimately show "splitted f"
       using pdivides_imp_splitted f_carr gauss_poly_carr by auto
   next
     case False
     hence "degree f = 1" using deg_f by simp
     thus ?thesis using f_carr degree_one_imp_splitted by auto
   qed
   hence "size (roots f) > 0"
     using deg_f unfolding splitted_def by simp
   then obtain x where x_def: "x \<in> carrier R" "is_root f x"
     using roots_mem_iff_is_root[OF f_carr]
     by (metis f_carr nonempty_has_size not_empty_rootsE)
   have "eval f x = \<zero>"
     using x_def is_root_def by blast
   thus ?thesis using x_def using that by simp
 qed
 
 lemma (in finite_field) find_iso_from_zfact:
   defines "p \<equiv> int (char R)"
   assumes "monic_irreducible_poly (ZFact p) f"
   assumes "order R = char R^degree f"
   shows "\<exists>\<phi>. \<phi> \<in> ring_iso (Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f) R"
 proof -
   have char_pos: "char R > 0"
     using finite_carr_imp_char_ge_0[OF finite_carrier] by simp
 
   interpret zf: finite_field "ZFact p"
-    unfolding p_def using zfact_prime_is_finite_field 
+    unfolding p_def using zfact_prime_is_finite_field
     using characteristic_is_prime[OF char_pos] by simp
 
   interpret zfp: polynomial_ring "ZFact p" "carrier (ZFact p)"
     unfolding polynomial_ring_def polynomial_ring_axioms_def
     using zf.field_axioms zf.carrier_is_subfield by simp
 
-  let ?f' = "map (char_iso R) f" 
+  let ?f' = "map (char_iso R) f"
   let ?F = "Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f"
 
   have "domain (R\<lparr>carrier := char_subring R\<rparr>)"
-    using char_ring_is_subdomain subdomain_is_domain by simp 
+    using char_ring_is_subdomain subdomain_is_domain by simp
 
-  hence "monic_irreducible_poly (R \<lparr> carrier := char_subring R \<rparr>) ?f'" 
+  hence "monic_irreducible_poly (R \<lparr> carrier := char_subring R \<rparr>) ?f'"
     using char_iso p_def zf.domain_axioms
     by (intro monic_irreducible_poly_hom[OF assms(2)]) auto
   moreover have "order R = card (char_subring R)^degree ?f'"
     using assms(3) unfolding char_def by simp
   ultimately obtain x where x_def: "eval ?f' x = \<zero>" "x \<in> carrier R"
     using find_root[OF char_ring_is_subfield[OF char_pos]] by blast
   let ?\<phi> = "(\<lambda>g. the_elem ((\<lambda>g'. eval (map (char_iso R) g') x) ` g))"
   interpret r: ring_hom_ring "?F" "R" "?\<phi>"
     using assms(2,3)
     unfolding monic_irreducible_poly_def monic_poly_def p_def
-    by (intro eval_on_root_is_iso x_def, auto) 
-  have a:"?\<phi> \<in> ring_hom ?F R" 
+    by (intro eval_on_root_is_iso x_def, auto)
+  have a:"?\<phi> \<in> ring_hom ?F R"
     using r.homh by auto
 
   have "field (Rupt\<^bsub>ZFact p\<^esub> (carrier (ZFact p)) f)"
     using assms(2)
     unfolding monic_irreducible_poly_def monic_poly_def
-    by (subst zfp.rupture_is_field_iff_pirreducible, simp_all) 
+    by (subst zfp.rupture_is_field_iff_pirreducible, simp_all)
   hence b:"inj_on ?\<phi> (carrier ?F)"
     using non_trivial_field_hom_is_inj[OF a _ field_axioms] by simp
 
   have "card (?\<phi> ` carrier ?F) = order ?F"
     using card_image[OF b] unfolding Coset.order_def by simp
   also have "... =  card (carrier (ZFact p))^degree f"
     using assms(2) zf.monic_poly_min_degree[OF assms(2)]
     unfolding monic_irreducible_poly_def monic_poly_def
     by (intro zf.rupture_order[OF zf.carrier_is_subfield]) auto
   also have "... = char R ^degree f"
     unfolding p_def by (subst card_zfact_carr[OF char_pos], simp)
   also have "... = card (carrier R)"
-    using assms(3) unfolding Coset.order_def by simp  
+    using assms(3) unfolding Coset.order_def by simp
   finally have "card (?\<phi> ` carrier ?F) = card (carrier R)" by simp
   moreover have "?\<phi> ` carrier ?F \<subseteq> carrier R"
     by (intro image_subsetI, simp)
   ultimately have "?\<phi> ` carrier ?F = carrier R"
-    by (intro card_seteq finite_carrier, auto) 
+    by (intro card_seteq finite_carrier, auto)
   hence "bij_betw ?\<phi> (carrier ?F) (carrier R)"
     using b bij_betw_imageI by auto
 
   thus ?thesis
     unfolding ring_iso_def using a b by auto
 qed
 
 theorem uniqueness:
   assumes "finite_field F\<^sub>1"
   assumes "finite_field F\<^sub>2"
   assumes "order F\<^sub>1 = order F\<^sub>2"
   shows "F\<^sub>1 \<simeq> F\<^sub>2"
 proof -
   obtain n where o1: "order F\<^sub>1 = char F\<^sub>1^n" "n > 0"
     using finite_field.finite_field_order[OF assms(1)] by auto
   obtain m where o2: "order F\<^sub>2 = char F\<^sub>2^m" "m > 0"
     using finite_field.finite_field_order[OF assms(2)] by auto
 
-  interpret f1: "finite_field" F\<^sub>1 using assms(1) by simp 
-  interpret f2: "finite_field" F\<^sub>2 using assms(2) by simp 
+  interpret f1: "finite_field" F\<^sub>1 using assms(1) by simp
+  interpret f2: "finite_field" F\<^sub>2 using assms(2) by simp
 
   have char_pos: "char F\<^sub>1 > 0" "char F\<^sub>2 > 0"
-    using f1.finite_carrier f1.finite_carr_imp_char_ge_0 
+    using f1.finite_carrier f1.finite_carr_imp_char_ge_0
     using f2.finite_carrier f2.finite_carr_imp_char_ge_0 by auto
-  hence char_prime: 
-    "Factorial_Ring.prime (char F\<^sub>1)" 
+  hence char_prime:
+    "Factorial_Ring.prime (char F\<^sub>1)"
     "Factorial_Ring.prime (char F\<^sub>2)"
     using f1.characteristic_is_prime f2.characteristic_is_prime
     by auto
 
-  have "char F\<^sub>1^n = char F\<^sub>2^m" 
+  have "char F\<^sub>1^n = char F\<^sub>2^m"
     using o1 o2 assms(3) by simp
   hence eq: "n = m" "char F\<^sub>1 = char F\<^sub>2"
     using char_prime char_pos o1(2) o2(2) prime_power_inj' by auto
 
-  obtain p where p_def: "p = char F\<^sub>1" "p = char F\<^sub>2" 
+  obtain p where p_def: "p = char F\<^sub>1" "p = char F\<^sub>2"
     using eq by simp
 
-  have p_prime: "Factorial_Ring.prime p" 
+  have p_prime: "Factorial_Ring.prime p"
     unfolding p_def(1)
     using f1.characteristic_is_prime char_pos by simp
 
   interpret zf: finite_field "ZFact (int p)"
-    using zfact_prime_is_finite_field p_prime o1(2) 
+    using zfact_prime_is_finite_field p_prime o1(2)
     using prime_nat_int_transfer by blast
 
   interpret zfp: polynomial_ring "ZFact p" "carrier (ZFact p)"
     unfolding polynomial_ring_def polynomial_ring_axioms_def
     using zf.field_axioms zf.carrier_is_subfield by simp
 
-  obtain f where f_def: 
+  obtain f where f_def:
     "monic_irreducible_poly (ZFact (int p)) f" "degree f = n"
     using zf.exist_irred o1(2) by auto
 
-  let ?F\<^sub>0  = "Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f" 
+  let ?F\<^sub>0  = "Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f"
 
   obtain \<phi>\<^sub>1 where \<phi>\<^sub>1_def: "\<phi>\<^sub>1 \<in> ring_iso ?F\<^sub>0 F\<^sub>1"
     using f1.find_iso_from_zfact f_def o1
     unfolding p_def by auto
 
   obtain \<phi>\<^sub>2 where \<phi>\<^sub>2_def: "\<phi>\<^sub>2 \<in> ring_iso ?F\<^sub>0 F\<^sub>2"
     using f2.find_iso_from_zfact f_def o2
     unfolding p_def(2) eq(1) by auto
 
   have "?F\<^sub>0 \<simeq> F\<^sub>1" using \<phi>\<^sub>1_def is_ring_iso_def by auto
   moreover have "?F\<^sub>0 \<simeq> F\<^sub>2" using \<phi>\<^sub>2_def is_ring_iso_def by auto
-  moreover have "field ?F\<^sub>0" 
+  moreover have "field ?F\<^sub>0"
     using f_def(1) zf.monic_poly_carr monic_irreducible_poly_def
     by (subst zfp.rupture_is_field_iff_pirreducible) auto
   hence "ring ?F\<^sub>0" using field.is_ring by auto
-  ultimately show ?thesis 
+  ultimately show ?thesis
     using ring_iso_trans ring_iso_sym by blast
 qed
 
 end
diff --git a/thys/Finite_Fields/Finite_Fields_Mod_Ring_Code.thy b/thys/Finite_Fields/Finite_Fields_Mod_Ring_Code.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Finite_Fields_Mod_Ring_Code.thy
@@ -0,0 +1,301 @@
+section \<open>Executable Factor Rings\<close>
+
+theory Finite_Fields_Mod_Ring_Code
+  imports Finite_Fields_Indexed_Algebra_Code Ring_Characteristic
+begin
+
+definition mod_ring :: "nat \<Rightarrow> nat idx_ring_enum"
+  where "mod_ring n = \<lparr>
+    idx_pred = (\<lambda>x. x < n),
+    idx_uminus = (\<lambda>x. (n-x) mod n),
+    idx_plus = (\<lambda>x y. (x+y) mod n),
+    idx_udivide = (\<lambda>x. nat (fst (bezout_coefficients (int x) (int n)) mod (int n))),
+    idx_mult = (\<lambda>x y. (x*y) mod n),
+    idx_zero = 0,
+    idx_one = 1,
+    idx_size = n,
+    idx_enum = id,
+    idx_enum_inv = id
+   \<rparr>"
+
+lemma zfact_iso_0:
+  assumes "n > 0"
+  shows "zfact_iso n 0 = \<zero>\<^bsub>ZFact (int n)\<^esub>"
+proof -
+  let ?I = "Idl\<^bsub>\<Z>\<^esub> {int n}"
+  have ideal_I: "ideal ?I \<Z>"
+    by (simp add: int.genideal_ideal)
+
+  interpret i:ideal "?I" "\<Z>" using ideal_I by simp
+  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) ?I"
+   using i.rcos_ring_hom_ring ZFact_def by auto
+
+  show ?thesis
+    by (simp add:zfact_iso_def ZFact_def)
+qed
+
+lemma zfact_prime_is_field:
+  assumes "Factorial_Ring.prime (p :: nat)"
+  shows "field (ZFact (int p))"
+  using zfact_prime_is_finite_field[OF assms] finite_field_def by auto
+
+definition zfact_iso_inv :: "nat \<Rightarrow> int set \<Rightarrow> nat" where
+  "zfact_iso_inv p = the_inv_into {..<p} (zfact_iso p)"
+
+lemma zfact_iso_inv_0:
+  assumes n_ge_0: "n > 0"
+  shows "zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> = 0"
+  unfolding zfact_iso_inv_def zfact_iso_0[OF n_ge_0, symmetric] using n_ge_0
+  by (rule the_inv_into_f_f[OF zfact_iso_inj], simp add:mod_ring_def)
+
+lemma zfact_coset:
+  assumes n_ge_0: "n > 0"
+  assumes "x \<in> carrier (ZFact (int n))"
+  defines "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
+  shows "x = I +>\<^bsub>\<Z>\<^esub> (int (zfact_iso_inv n x))"
+proof -
+  have "x \<in> zfact_iso n ` {..<n}"
+    using assms zfact_iso_ran by simp
+  hence "zfact_iso n (zfact_iso_inv n x) = x"
+    unfolding zfact_iso_inv_def by (intro f_the_inv_into_f zfact_iso_inj) auto
+  thus ?thesis unfolding zfact_iso_def I_def by blast
+qed
+
+lemma zfact_iso_inv_bij:
+  assumes "n > 0"
+  shows "bij_betw (zfact_iso_inv n) (carrier (ZFact (int n))) (carrier (ring_of (mod_ring n)))"
+proof -
+  have "bij_betw (the_inv_into {..<n} (zfact_iso n)) (carrier (ZFact (int n))) {..<n}"
+    by (intro bij_betw_the_inv_into zfact_iso_bij[OF assms])
+  thus ?thesis
+    unfolding zfact_iso_inv_def mod_ring_def ring_of_def lessThan_def by simp
+qed
+
+lemma zfact_iso_inv_is_ring_iso:
+  fixes n :: nat
+  assumes n_ge_1: "n > 1"
+  shows "zfact_iso_inv n \<in> ring_iso (ZFact (int n)) (ring_of (mod_ring n))" (is "?f \<in> _")
+proof (rule ring_iso_memI)
+  interpret r:cring "(ZFact (int n))"
+    using ZFact_is_cring by simp
+
+  define I where "I = Idl\<^bsub>\<Z>\<^esub> {int n}"
+
+  have n_ge_0: "n > 0" using n_ge_1 by simp
+
+  interpret i:ideal "I" "\<Z>"
+    unfolding I_def using int.genideal_ideal by simp
+
+  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) I"
+   using i.rcos_ring_hom_ring ZFact_def I_def by auto
+
+  show "zfact_iso_inv n x \<in> carrier (ring_of (mod_ring n))" if "x \<in> carrier (ZFact (int n))" for x
+  proof -
+    have "zfact_iso_inv n x \<in> {..<n}"
+      unfolding zfact_iso_inv_def using that zfact_iso_ran[OF n_ge_0]
+      by (intro the_inv_into_into zfact_iso_inj n_ge_0) auto
+    thus "zfact_iso_inv n x \<in> carrier (ring_of (mod_ring n))"
+      by (simp add:ring_of_def mod_ring_def)
+  qed
+
+  show "?f (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) = ?f x \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> ?f y"
+    if x_carr: "x \<in> carrier (ZFact (int n))" and y_carr: "y \<in> carrier (ZFact (int n))" for x y
+  proof -
+    define x' where "x' = zfact_iso_inv n x"
+    define y' where "y' = zfact_iso_inv n y"
+    have "x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<otimes>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
+      unfolding x'_def y'_def
+      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' * int y'))"
+      by simp
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' * y') mod n)))"
+      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y'))"
+      unfolding ring_of_def mod_ring_def by simp
+    also have "... = zfact_iso n (x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y')"
+      unfolding zfact_iso_def I_def by simp
+    finally have a:"x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y')"
+      by simp
+    have b:"x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y' \<in> {..<n}"
+      using mod_ring_def n_ge_0 by (auto simp:ring_of_def)
+    have "?f (zfact_iso n (x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y')) = x' \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y'"
+      unfolding zfact_iso_inv_def
+      by (rule the_inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
+    thus
+      "zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
+      zfact_iso_inv n x \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> zfact_iso_inv n y"
+      using a x'_def y'_def by simp
+  qed
+
+  show "zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
+    zfact_iso_inv n x \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> zfact_iso_inv n y"
+    if x_carr: "x \<in> carrier (ZFact (int n))" and y_carr: "y \<in> carrier (ZFact (int n))" for x y
+  proof -
+    define x' where "x' = zfact_iso_inv n x"
+    define y' where "y' = zfact_iso_inv n y"
+    have "x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<oplus>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
+      unfolding x'_def y'_def
+      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' + int y'))"
+      by simp
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' + y') mod n)))"
+      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
+    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y'))"
+      unfolding mod_ring_def ring_of_def by simp
+    also have "... = zfact_iso n (x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y')"
+      unfolding zfact_iso_def I_def by simp
+    finally have a:"x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y')"
+      by simp
+    have b:"x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y' \<in> {..<n}"
+      using mod_ring_def n_ge_0 by (auto simp:ring_of_def)
+    have "?f (zfact_iso n (x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y')) = x' \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> y'"
+      unfolding zfact_iso_inv_def
+      by (rule the_inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
+    thus "?f (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) = ?f x \<oplus>\<^bsub>ring_of (mod_ring n)\<^esub> ?f y"
+      using a x'_def y'_def by simp
+  qed
+
+  have "\<one>\<^bsub>ZFact (int n)\<^esub> = zfact_iso n (\<one>\<^bsub>ring_of (mod_ring n)\<^esub>)"
+    by (simp add:zfact_iso_def ZFact_def I_def[symmetric] ring_of_def mod_ring_def)
+
+  thus "zfact_iso_inv n \<one>\<^bsub>ZFact (int n)\<^esub> = \<one>\<^bsub>ring_of (mod_ring n)\<^esub>"
+    unfolding zfact_iso_inv_def mod_ring_def ring_of_def
+    using the_inv_into_f_f[OF zfact_iso_inj] n_ge_1 by simp
+
+  show "bij_betw (zfact_iso_inv n) (carrier (ZFact (int n))) (carrier (ring_of (mod_ring n)))"
+    by (intro zfact_iso_inv_bij n_ge_0)
+qed
+
+lemma mod_ring_finite:
+  "finite (carrier (ring_of (mod_ring n)))"
+  by (simp add:mod_ring_def ring_of_def)
+
+lemma mod_ring_carr:
+  "x \<in> carrier (ring_of (mod_ring n)) \<longleftrightarrow>  x < n"
+  by (simp add:mod_ring_def ring_of_def)
+
+lemma mod_ring_is_cring:
+  assumes n_ge_1: "n > 1"
+  shows "cring (ring_of (mod_ring n))"
+proof -
+  have n_ge_0: "n > 0" using n_ge_1 by simp
+
+  interpret cring "ZFact (int n)"
+    using ZFact_is_cring by simp
+
+  have "cring ((ring_of (mod_ring n)) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr>)"
+    by (rule ring_iso_imp_img_cring[OF zfact_iso_inv_is_ring_iso[OF n_ge_1]])
+  moreover have
+    "ring_of (mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr> = ring_of (mod_ring n)"
+    using zfact_iso_inv_0[OF n_ge_0] by (simp add:mod_ring_def ring_of_def)
+  ultimately show ?thesis by simp
+qed
+
+lemma zfact_iso_is_ring_iso:
+  assumes n_ge_1: "n > 1"
+  shows "zfact_iso n \<in> ring_iso (ring_of (mod_ring n)) (ZFact (int n))"
+proof -
+  have r:"ring (ZFact (int n))"
+    using ZFact_is_cring cring.axioms(1) by blast
+
+  interpret s: ring "(ring_of (mod_ring n))"
+    using mod_ring_is_cring cring.axioms(1) n_ge_1 by blast
+  have n_ge_0: "n > 0" using n_ge_1 by linarith
+
+  have "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n)
+      \<in> ring_iso (ring_of (mod_ring n)) (ZFact (int n))"
+    using ring_iso_set_sym[OF r zfact_iso_inv_is_ring_iso[OF n_ge_1]] by simp
+  moreover have "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
+    if "x \<in> carrier (ring_of (mod_ring n))" for x
+  proof -
+    have "x \<in> {..<n}" using that by (simp add:mod_ring_def ring_of_def)
+    thus "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
+      using zfact_iso_inv_bij[OF n_ge_0] zfact_iso_bij[OF n_ge_0] unfolding zfact_iso_inv_def
+      by (intro inv_into_f_eq bij_betw_apply[OF zfact_iso_inv_bij[OF n_ge_0]] the_inv_into_f_f)
+       (auto intro:bij_betw_imp_inj_on simp:bij_betwE)
+  qed
+
+  ultimately show ?thesis using s.ring_iso_restrict by blast
+qed
+
+text \<open>If @{term "p"} is a prime than @{term "mod_ring p"} is a field:\<close>
+
+lemma mod_ring_is_field:
+  assumes"Factorial_Ring.prime p"
+  shows "field (ring_of (mod_ring p))"
+proof -
+  have p_ge_0: "p > 0" using assms prime_gt_0_nat by blast
+  have p_ge_1: "p > 1" using assms prime_gt_1_nat by blast
+
+  interpret field "ZFact (int p)"
+    using zfact_prime_is_field[OF assms] by simp
+
+  have "field ((ring_of (mod_ring p)) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr>)"
+    by (rule ring_iso_imp_img_field[OF zfact_iso_inv_is_ring_iso[OF p_ge_1]])
+
+  moreover have
+    "(ring_of (mod_ring p)) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr> = ring_of (mod_ring p)"
+    using zfact_iso_inv_0[OF p_ge_0] by (simp add:mod_ring_def ring_of_def)
+  ultimately show ?thesis by simp
+qed
+
+lemma mod_ring_is_ring_c:
+  assumes "n > 1"
+  shows "cring\<^sub>C (mod_ring n)"
+proof (intro cring_cI mod_ring_is_cring assms)
+  fix x
+  assume a:"x \<in> carrier (ring_of (mod_ring n))"
+  hence x_le_n: "x < n" unfolding mod_ring_def ring_of_def by simp
+
+  interpret cring "(ring_of (mod_ring n))" by (intro mod_ring_is_cring assms)
+
+  show "-\<^sub>C\<^bsub>mod_ring n\<^esub> x = \<ominus>\<^bsub>ring_of (mod_ring n)\<^esub> x" using x_le_n
+    by (intro minus_equality[symmetric] a) (simp_all add:ring_of_def mod_ring_def mod_simps)
+next
+  fix x
+  assume a:"x \<in> Units (ring_of (mod_ring n))"
+
+  let ?l = "fst (bezout_coefficients (int x) (int n))"
+  let ?r = "snd (bezout_coefficients (int x) (int n))"
+
+  interpret cring "ring_of (mod_ring n)" by (intro mod_ring_is_cring assms)
+
+  obtain y where "x \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> y = \<one>\<^bsub>ring_of (mod_ring n)\<^esub>"
+    using a by (meson Units_r_inv_ex)
+  hence "x * y mod n = 1" by (simp_all add:mod_ring_def ring_of_def)
+  hence "gcd x n = 1" by (metis dvd_triv_left gcd.assoc gcd_1_nat gcd_nat.absorb_iff1 gcd_red_nat)
+  hence 0:"gcd (int x) (int n) = 1" unfolding gcd_int_int_eq by simp
+
+  have "int x * ?l mod int n = (?l * int x + ?r * int n) mod int n"
+    using assms by (simp add:mod_simps algebra_simps)
+  also have "... = (gcd (int x) (int n)) mod int n"
+    by (intro arg_cong2[where f="(mod)"] refl bezout_coefficients) simp
+  also have "... = 1" unfolding 0 using assms by simp
+  finally have "int x * ?l mod int n = 1" by simp
+  hence "int x * nat (fst (bezout_coefficients (int x) (int n)) mod int n) mod n = 1"
+    using assms by (simp add:mod_simps)
+  hence "x * nat (fst (bezout_coefficients (int x) (int n)) mod int n) mod n = 1"
+    by (metis nat_mod_as_int nat_one_as_int of_nat_mult)
+  hence "x \<otimes>\<^bsub>ring_of (mod_ring n)\<^esub> x \<inverse>\<^sub>C\<^bsub>mod_ring n\<^esub> = \<one>\<^bsub>ring_of (mod_ring n)\<^esub>"
+    using assms unfolding mod_ring_def ring_of_def by simp
+  moreover have "nat (fst (bezout_coefficients (int x) (int n)) mod int n) < n"
+    using assms by (subst nat_less_iff) auto
+  hence "x \<inverse>\<^sub>C\<^bsub>mod_ring n\<^esub> \<in> carrier (ring_of (mod_ring n))"
+    using assms unfolding mod_ring_def ring_of_def by simp
+  moreover have "x \<in> carrier (ring_of (mod_ring n))" using a by auto
+  ultimately show "x \<inverse>\<^sub>C\<^bsub>mod_ring n\<^esub> = inv\<^bsub>ring_of (mod_ring n)\<^esub> x"
+    by (intro comm_inv_char[symmetric])
+qed
+
+lemma mod_ring_is_field_c:
+  assumes"Factorial_Ring.prime p"
+  shows "field\<^sub>C (mod_ring p)"
+  unfolding field\<^sub>C_def domain\<^sub>C_def
+  by (intro conjI mod_ring_is_ring_c mod_ring_is_field assms prime_gt_1_nat
+      domain.axioms(1) field.axioms(1))
+
+lemma mod_ring_is_enum_c:
+  shows "enum\<^sub>C (mod_ring n)"
+  by (intro enum_cI) (simp_all add:mod_ring_def ring_of_def Coset.order_def lessThan_def)
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_More_Bijections.thy b/thys/Finite_Fields/Finite_Fields_More_Bijections.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Finite_Fields_More_Bijections.thy
@@ -0,0 +1,192 @@
+section \<open>Additional results about Bijections and Digit Representations\<close>
+
+theory Finite_Fields_More_Bijections
+  imports "HOL-Library.FuncSet" Digit_Expansions.Bits_Digits
+begin
+
+lemma nth_digit_0:
+  assumes "x < b^k"
+  shows "nth_digit x k b = 0"
+  using assms unfolding nth_digit_def by auto
+
+lemma nth_digit_bounded':
+  assumes "b > 0"
+  shows "nth_digit v x b < b"
+  using assms by (simp add: nth_digit_def)
+
+lemma digit_gen_sum_repr':
+  assumes "n < b^c"
+  shows "n = (\<Sum>k<c. nth_digit n k b * b ^ k)"
+proof -
+  consider (a) "b = 0" "c = 0" | (b) "b = 0" "c > 0" | (c) "b = 1" | (d) "b>1" by linarith
+  thus ?thesis
+  proof (cases)
+    case a thus ?thesis using assms by simp
+  next
+    case b thus ?thesis using assms by (simp add: zero_power)
+  next
+    case c thus ?thesis using assms by (simp add:nth_digit_def)
+  next
+    case d thus ?thesis by (intro digit_gen_sum_repr assms d)
+  qed
+qed
+
+lemma
+  assumes "\<And>x. x \<in> A \<Longrightarrow> f (g x) = x"
+  shows "\<And>y. y \<in> g ` A \<Longrightarrow> g (f y) = y"
+proof -
+  show "g (f y) = y" if 0:"y\<in> g`A" for y
+  proof -
+    obtain x where x_dom: "x \<in> A" and y_def: "y = g x"  using 0 by auto
+    hence "g (f y) = g (f (g x))" by simp
+    also have "... = g x" by (intro arg_cong[where f="g"] assms(1) x_dom)
+    also have "... = y" unfolding y_def by simp
+    finally show ?thesis by simp
+  qed
+qed
+
+lemma nth_digit_bij:
+  "bij_betw (\<lambda>v. (\<lambda>x\<in>{..<n}. nth_digit v x b)) {..<b^n} ({..<n} \<rightarrow>\<^sub>E {..<b})"
+  (is "bij_betw ?f ?A ?B")
+proof -
+  have inj_f: "inj_on ?f ?A"
+    using digit_gen_sum_repr' by (intro inj_on_inverseI[where g="(\<lambda>x. (\<Sum>k<n. x k * b^k))"]) auto
+
+  consider (a) "b = 0" "n= 0" | (b) "b = 0" "n>0" | (c) "b > 0" by linarith
+  hence "nth_digit x i b \<in> {..<b}" if "i < n" "x < b^n" for i x
+  proof (cases)
+    case a then show ?thesis using that by auto
+  next
+    case b thus ?thesis using that by (simp add:zero_power)
+  next
+    case c thus ?thesis using that by (simp add:nth_digit_def)
+  qed
+  hence "?f x \<in> ?B" if "x \<in> ?A" for x using that unfolding restrict_PiE_iff by auto
+  hence "?f ` ?A = ?B"
+    using card_image[OF inj_f] by (intro card_seteq finite_PiE image_subsetI) (auto simp:card_PiE)
+  thus ?thesis using inj_f unfolding bij_betw_def by auto
+qed
+
+lemma nth_digit_sum:
+  assumes "\<And>i. i < l \<Longrightarrow> f i < b"
+  shows "\<And>k. k < l \<Longrightarrow> nth_digit (\<Sum>i< l. f i * b^i) k b = f k"
+    and "(\<Sum>i<l. f i * b^i) < b^l"
+proof -
+  define n where "n = (\<Sum>i< l. f i * b^i)"
+
+  have "restrict f {..<l} \<in> {..<l} \<rightarrow>\<^sub>E {..<b}" using assms(1) by auto
+  then obtain m where a:"(\<lambda>x\<in>{..<l}. nth_digit m x b) = restrict f {..<l}" and b:"m \<in> {..<b^l}"
+    using bij_betw_imp_surj_on[OF nth_digit_bij[where n="l" and b="b"]]
+    by (metis (no_types, lifting) image_iff)
+
+  have "m = (\<Sum>i< l. nth_digit m i b * b^i)"
+    using b by (intro digit_gen_sum_repr') auto
+  also have "... = (\<Sum>i< l. f i * b^i)"
+    using a by (intro sum.cong arg_cong2[where f="(*)"] refl) (metis restrict_apply')
+  also have "... = n" unfolding n_def by simp
+  finally have c:"n = m"  by simp
+  show "(\<Sum>i<l. f i * b^i) < b^l" unfolding n_def[symmetric] c using b by auto
+  show "nth_digit (\<Sum>i< l. f i * b^i) k b = f k" if "k < l" for k
+  proof -
+    have "nth_digit (\<Sum>i< l. f i * b^i) k b = nth_digit m k b" unfolding n_def[symmetric] c by simp
+    also have "... = f k" using a that by (metis lessThan_iff restrict_apply')
+    finally show ?thesis by simp
+  qed
+qed
+
+lemma bij_betw_reindex:
+  assumes "bij_betw f I J"
+  shows "bij_betw (\<lambda>x. \<lambda>i\<in>I. x (f i)) (J \<rightarrow>\<^sub>E S) (I \<rightarrow>\<^sub>E S)"
+proof (rule bij_betwI[where g="(\<lambda>x. \<lambda>i\<in>J. x (the_inv_into I f i))"])
+  have 0:"bij_betw (the_inv_into I f) J I"
+    using assms bij_betw_the_inv_into by auto
+
+  show "(\<lambda>x. \<lambda>i\<in>I. x (f i)) \<in> (J \<rightarrow>\<^sub>E S) \<rightarrow> I \<rightarrow>\<^sub>E S"
+    using bij_betw_apply[OF assms] by auto
+  show "(\<lambda>x. \<lambda>i\<in>J. x (the_inv_into I f i)) \<in> (I \<rightarrow>\<^sub>E S) \<rightarrow> J \<rightarrow>\<^sub>E S"
+    using bij_betw_apply[OF 0] by auto
+  show "(\<lambda>j\<in>J. (\<lambda>i\<in>I. x (f i)) (the_inv_into I f j)) = x" if "x \<in> J \<rightarrow>\<^sub>E S" for x
+  proof -
+    have "(\<lambda>i\<in>I. x (f i)) (the_inv_into I f j) = x j" if "j \<in> J" for j
+      using 0 assms f_the_inv_into_f_bij_betw bij_betw_apply that by fastforce
+    thus ?thesis using PiE_arb[OF that] by auto
+  qed
+  show " (\<lambda>i\<in>I. (\<lambda>j\<in>J. y (the_inv_into I f j)) (f i)) = y" if "y \<in> I \<rightarrow>\<^sub>E S" for y
+  proof -
+    have "(\<lambda>j\<in>J. y (the_inv_into I f j)) (f i) = y i" if "i \<in> I" for i
+      using assms 0 that the_inv_into_f_f[OF bij_betw_imp_inj_on[OF assms]] bij_betw_apply by force
+    thus ?thesis using PiE_arb[OF that] by auto
+  qed
+qed
+
+lemma lift_bij_betw:
+  assumes "bij_betw f S T"
+  shows "bij_betw (\<lambda>x. \<lambda>i\<in>I. f (x i)) (I \<rightarrow>\<^sub>E S) (I \<rightarrow>\<^sub>E T)"
+proof -
+  let ?g = "the_inv_into S f"
+
+  have bij_g: "bij_betw ?g T S" using bij_betw_the_inv_into[OF assms] by simp
+  have 0:"?g(f x)=x" if "x \<in> S" for x by (intro the_inv_into_f_f that bij_betw_imp_inj_on[OF assms])
+  have 1:"f(?g x)=x" if "x \<in> T" for x by (intro f_the_inv_into_f_bij_betw[OF assms] that)
+
+  have "(\<lambda>i\<in>I. f (x i)) \<in> I \<rightarrow>\<^sub>E T" if "x \<in> (I \<rightarrow>\<^sub>E S)" for x
+    using bij_betw_apply[OF assms] that by (auto simp: Pi_def)
+  moreover have "(\<lambda>i\<in>I. ?g (x i)) \<in> I \<rightarrow>\<^sub>E S" if "x \<in> (I \<rightarrow>\<^sub>E T)" for x
+    using bij_betw_apply[OF bij_g] that by (auto simp: Pi_def)
+  moreover have "(\<lambda>i\<in>I. ?g ((\<lambda>i\<in>I. f (x i)) i)) = x" if "x \<in> (I \<rightarrow>\<^sub>E S)" for x
+  proof -
+    have "(\<lambda>i\<in>I. ?g ((\<lambda>i\<in>I. f (x i)) i)) i = x i" for i
+      using PiE_mem[OF that] using PiE_arb[OF that]  by (cases "i \<in> I")  (simp add:0)+
+    thus ?thesis by auto
+  qed
+  moreover have "(\<lambda>i\<in>I. f ((\<lambda>i\<in>I. ?g (x i)) i)) = x" if "x \<in> (I \<rightarrow>\<^sub>E T)" for x
+  proof -
+    have "(\<lambda>i\<in>I. f ((\<lambda>i\<in>I. ?g (x i)) i)) i = x i" for i
+      using PiE_mem[OF that] using PiE_arb[OF that]  by (cases "i \<in> I")  (simp add:1)+
+    thus ?thesis by auto
+  qed
+  ultimately show ?thesis
+    by (intro bij_betwI[where g="(\<lambda>x. \<lambda>i\<in>I. ?g (x i))"]) simp_all
+qed
+
+lemma lists_bij:
+    "bij_betw (\<lambda>x. map x [ 0..<d] ) ({..<d} \<rightarrow>\<^sub>E S) {x. set x \<subseteq> S \<and> length x = d}"
+proof (intro bij_betwI[where g="(\<lambda>x. \<lambda>i\<in>{..<d}. x ! i)"] funcsetI CollectI, goal_cases)
+  case (1 x)
+  hence " x ` {0..<d} \<subseteq> S" by (intro image_subsetI) auto
+  thus ?case by simp
+next
+  case (2 x) thus ?case by auto
+next
+  case (3 x)
+  have "restrict ((!) (map x [ 0..<d] )) {..<d} j = x j" for j
+    using PiE_arb[OF 3] by (cases "j \<in> {..<d}") auto
+  thus ?case by auto
+next
+  case (4 y)
+  have "map (restrict ((!) y) {..<d}) [ 0..<d ] = map (((!) y)) [ 0..<d]" by (intro map_cong) auto
+  also have "... = y" using 4 map_nth by blast
+  finally show ?case by auto
+qed
+
+lemma bij_betw_prod: "bij_betw (\<lambda>x. (x mod s, x div s)) {..<s * t} ({..<(s::nat)} \<times> {..<t})"
+proof -
+  have bij_betw_aux: "x + s * y < s * t" if "x < s" "y < t" for x y :: nat
+  proof -
+    have "x + s * y < s + s * y" using that by simp
+    also have "... = s * (y+1)" by simp
+    also have "... \<le> s * t" using that by (intro mult_left_mono) auto
+    finally show ?thesis by simp
+  qed
+
+  show ?thesis
+  proof (cases "s > 0 \<and> t > 0")
+    case True
+    then show ?thesis using less_mult_imp_div_less bij_betw_aux
+      by (intro bij_betwI[where g="(\<lambda>x. fst x + s * snd x)"]) (auto simp:mult.commute)
+  next
+    case False then show ?thesis by (auto simp:bij_betw_def)
+  qed
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Poly_Factor_Ring_Code.thy b/thys/Finite_Fields/Finite_Fields_Poly_Factor_Ring_Code.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Finite_Fields_Poly_Factor_Ring_Code.thy
@@ -0,0 +1,663 @@
+section \<open>Executable Polynomial Factor Rings\<close>
+
+theory Finite_Fields_Poly_Factor_Ring_Code
+  imports
+    Finite_Fields_Poly_Ring_Code
+    Rabin_Irreducibility_Test_Code
+    Finite_Fields_More_Bijections
+begin
+
+text \<open>Enumeration of the polynomials with a given degree:\<close>
+
+definition poly_enum :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
+  where "poly_enum R l n =
+    dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) (map (\<lambda>p. idx_enum R (nth_digit n (l-1-p) (idx_size R))) [0..<l])"
+
+lemma replicate_drop_while_cancel:
+  assumes "k = length (takeWhile ((=) x) y)"
+  shows  "replicate k x @ dropWhile ((=) x) y = y" (is "?L = ?R")
+proof -
+  have "replicate k x = takeWhile ((=) x) y"
+    using assms by (metis (full_types) replicate_length_same set_takeWhileD)
+  thus ?thesis by simp
+qed
+
+lemma arg_cong3:
+  assumes "x = u" "y = v" "z = w"
+  shows "f x y z = f u v w"
+  using assms by simp
+
+lemma list_all_dropwhile: "list_all p xs \<Longrightarrow> list_all p (dropWhile q xs)"
+  by (induction xs) auto
+
+lemma bij_betw_poly_enum:
+  assumes "enum\<^sub>C R" "ring\<^sub>C R"
+  shows "bij_betw (poly_enum R l) {..<idx_size R^l}
+  {xs. xs \<in> carrier (poly_ring (ring_of R)) \<and> length xs \<le> l}"
+proof -
+  let ?b = "idx_size R"
+  let ?S0 = "{..<l} \<rightarrow>\<^sub>E {..<order (ring_of R)}"
+  let ?S1 = "{..<l} \<rightarrow>\<^sub>E {x. idx_pred R x}"
+  let ?S2 = "{xs. list_all (idx_pred R) xs \<and> length xs = l}"
+  let ?S3 = "{xs. (xs = [] \<or> hd xs \<noteq> 0\<^sub>C\<^bsub>R\<^esub>) \<and> list_all (idx_pred R) xs \<and> length xs \<le> l}"
+  let ?S4 = "{xs. xs \<in> carrier (poly_ring (ring_of R)) \<and> length xs \<le> l}"
+
+  interpret ring "ring_of R" using assms(2) unfolding ring\<^sub>C_def by simp
+
+  have "0 < order (ring_of R)" using enum_cD(1)[OF assms(1)] order_gt_0_iff_finite by metis
+  also have "... = ?b" using enum_cD[OF assms(1)] by auto
+  finally have b_gt_0: "?b > 0" by simp
+
+  note bij0 = lift_bij_betw[OF enum_cD(3)[OF assms(1)], where I="{..<l}"]
+  note bij1 = lists_bij[where d="l" and S="{x. idx_pred R x}"]
+
+  have "bij_betw (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>)) ?S2 ?S3"
+  proof (rule bij_betwI[where g="\<lambda>xs. replicate (l - length xs) 0\<^sub>C\<^bsub>R\<^esub> @ xs"])
+    have "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) xs \<in> ?S3" if "xs \<in> ?S2" for xs
+    proof -
+      have "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) xs = [] \<or> hd (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) xs) \<noteq> 0\<^sub>C\<^bsub>R\<^esub>"
+        using hd_dropWhile by (metis (full_types))
+      moreover have "length (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) xs) \<le> l"
+        by (metis (mono_tags, lifting) mem_Collect_eq length_dropWhile_le that)
+      ultimately show ?thesis using that by (auto simp:list_all_dropwhile)
+    qed
+    thus "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) \<in> ?S2 \<rightarrow> ?S3"  by auto
+    have "replicate (l - length xs) 0\<^sub>C\<^bsub>R\<^esub> @ xs \<in> ?S2" if "xs \<in> ?S3" for xs
+    proof -
+      have "idx_pred R 0\<^sub>C\<^bsub>R\<^esub>" using add.one_closed by (simp add:ring_of_def)
+      moreover have "length (replicate (l - length xs) 0\<^sub>C\<^bsub>R\<^esub> @ xs) = l" using that by auto
+      ultimately show ?thesis using that by (auto simp:list_all_iff)
+    qed
+    thus "(\<lambda>xs. replicate (l - length xs) 0\<^sub>C\<^bsub>R\<^esub> @ xs) \<in> ?S3 \<rightarrow> ?S2" by auto
+
+    show "replicate (l - length (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) x)) 0\<^sub>C\<^bsub>R\<^esub> @ dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) x = x"
+      if "x \<in> ?S2" for x
+    proof -
+      have "length (takeWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) x) + length (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) x) = length x"
+        unfolding length_append[symmetric] by simp
+      thus ?thesis using that by (intro replicate_drop_while_cancel) auto
+    qed
+    show "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) (replicate (l - length y) 0\<^sub>C\<^bsub>R\<^esub> @ y) = y"
+      if "y \<in> ?S3" for y
+    proof -
+      have "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) (replicate (l - length y) 0\<^sub>C\<^bsub>R\<^esub> @ y) = dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>) y"
+        by (intro dropWhile_append2) simp
+      also have "... = y" using that by (intro iffD2[OF dropWhile_eq_self_iff]) auto
+      finally show ?thesis by simp
+    qed
+  qed
+  moreover have "?S3 = ?S4"
+    unfolding ring_of_poly[OF assms(2),symmetric] by (simp add:ring_of_def poly_def)
+  ultimately have bij2: "bij_betw (dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>)) ?S2 ?S4" by simp
+
+  have bij3: "bij_betw (\<lambda>x. l-1-x) {..<l}  {..<l}"
+    by (intro bij_betwI[where g="\<lambda>x. l-1-x"]) auto
+  note bij4 = bij_betw_reindex[OF bij3, where S="{..<order (ring_of R)}"]
+  have bij5: "bij_betw (\<lambda>n. (\<lambda>p\<in>{..<l}. nth_digit n p ?b)) {..<?b^l} ?S0"
+    using nth_digit_bij[where n="l"] enum_cD[OF assms(1)] by simp
+  have bij6: "bij_betw (\<lambda>n. (\<lambda>p\<in>{..<l}. nth_digit n (l-1-p) ?b)) {..<?b^l} ?S0"
+    by (intro iffD2[OF arg_cong3[where f="bij_betw"] bij_betw_trans[OF bij5 bij4]]) force+
+
+  have "carrier (ring_of R) = {x. idx_pred R x}" unfolding ring_of_def by auto
+  hence bij7: "bij_betw (\<lambda>n. (\<lambda>p\<in>{..<l}. idx_enum R (nth_digit n (l-1-p) ?b))) {..<?b^l} ?S1"
+    by (intro iffD2[OF arg_cong3[where f="bij_betw"] bij_betw_trans[OF bij6 bij0]]) fastforce+
+
+  have bij8: "bij_betw (\<lambda>n. map (\<lambda>p. idx_enum R (nth_digit n (l-1-p) ?b)) [0..<l]) {..<?b^l} ?S2"
+    by (intro iffD2[OF arg_cong3[where f="bij_betw"] bij_betw_trans[OF bij7 bij1]])
+       (auto simp:comp_def list_all_iff atLeast0LessThan[symmetric])
+
+  thus "bij_betw (poly_enum R l) {..<idx_size R ^ l} ?S4"
+    using bij_betw_trans[OF bij8 bij2] unfolding poly_enum_def comp_def by simp
+qed
+
+
+definition poly_enum_inv :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> nat"
+  where "poly_enum_inv R l f =
+    (let f' = replicate (l - length f) 0\<^sub>C\<^bsub>R\<^esub> @ f in
+    (\<Sum>i<l. idx_enum_inv R (f' ! (l - 1 - i)) * idx_size R ^i ))"
+
+find_theorems "(\<Sum>i<?l. ?f i * ?x^i) < ?x^?l"
+
+lemma poly_enum_inv:
+  assumes "enum\<^sub>C R" "ring\<^sub>C R"
+  assumes "x \<in>  {xs. xs \<in> carrier (poly_ring (ring_of R)) \<and> length xs \<le> l}"
+  shows "the_inv_into {..<idx_size R^l} (poly_enum R l) x = poly_enum_inv R l x"
+proof -
+  define f where "f = replicate (l- length x) 0\<^sub>C\<^bsub>R\<^esub> @ x"
+  let ?b = "idx_size R"
+  let ?d = "dropWhile ((=) 0\<^sub>C\<^bsub>R\<^esub>)"
+
+  have len_f: "length f = l" using assms(3) unfolding f_def by auto
+  note enum_c = enum_cD[OF assms(1)]
+
+  interpret ring "ring_of R" using assms(2) unfolding ring\<^sub>C_def by simp
+
+  have 0: "idx_enum_inv R y < ?b" if "y \<in> carrier (ring_of R)" for y
+    using bij_betw_imp_surj_on[OF enum_c(4)] enum_c(2) that by auto
+  have 1: "(x = [] \<or> lead_coeff x \<noteq> 0\<^sub>C\<^bsub>R\<^esub>) \<and> list_all (idx_pred R) x \<and> length x \<le> l"
+    using assms(3) unfolding ring_of_poly[OF assms(2),symmetric] by (simp add:ring_of_def poly_def)
+  moreover have "\<zero>\<^bsub>ring_of R\<^esub> \<in> carrier (ring_of R)" by simp
+  hence "idx_pred R 0\<^sub>C\<^bsub>R\<^esub>" unfolding ring_of_def by simp
+  ultimately have 2: "set f \<subseteq> carrier (ring_of R)"
+    unfolding f_def by (auto simp add:ring_of_def list_all_iff)
+
+  have "poly_enum R l(poly_enum_inv R l x)= poly_enum R l (\<Sum>i<l. idx_enum_inv R (f ! (l-1-i))*?b^i)"
+    unfolding poly_enum_inv_def f_def[symmetric] by simp
+  also have "... = ?d (map (\<lambda>p. idx_enum R (idx_enum_inv R (f ! (l - 1 - (l - 1 - p))))) [0..<l])"
+    unfolding poly_enum_def using 2 len_f by (intro arg_cong[where f="?d"]
+        arg_cong[where f="idx_enum R"] map_cong refl nth_digit_sum 0) auto
+  also have "... =?d (map (\<lambda>p. (f ! (l-1 - (l-1-p)))) [0..<l])"
+    using 2 len_f by (intro arg_cong[where f="?d"] map_cong refl enum_c) auto
+  also have "... =?d (map (\<lambda>p. (f ! p)) [0..<l])"
+    by (intro arg_cong[where f="?d"] map_cong) auto
+  also have "... = ?d f" using len_f map_nth by (intro arg_cong[where f="?d"]) auto
+  also have "... = ?d x" unfolding f_def by (intro dropWhile_append2) auto
+  also have "... = x" using 1 by (intro iffD2[OF dropWhile_eq_self_iff]) auto
+  finally have "poly_enum R l (poly_enum_inv R l x) = x" by simp
+  moreover have "poly_enum_inv R l x < idx_size R^l"
+    unfolding poly_enum_inv_def Let_def f_def[symmetric] using len_f 2
+    by (intro nth_digit_sum(2) 0) auto
+  ultimately show ?thesis
+    by (intro the_inv_into_f_eq bij_betw_imp_inj_on[OF bij_betw_poly_enum[OF assms(1,2)]]) auto
+qed
+
+definition poly_mod_ring :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> 'a list => 'a list idx_ring_enum"
+  where "poly_mod_ring R f = \<lparr>
+    idx_pred = (\<lambda>xs. idx_pred (poly R) xs \<and> length xs \<le> degree f),
+    idx_uminus = idx_uminus (poly R),
+    idx_plus = (\<lambda>x y. pmod\<^sub>C R (x +\<^sub>C\<^bsub>poly R\<^esub> y) f),
+    idx_udivide = (\<lambda>x. let ((u,v),r) = ext_euclidean R x f in pmod\<^sub>C R (r\<inverse>\<^sub>C\<^bsub>poly R\<^esub> *\<^sub>C\<^bsub>poly R\<^esub> u) f),
+    idx_mult = (\<lambda>x y. pmod\<^sub>C R (x *\<^sub>C\<^bsub>poly R\<^esub> y) f),
+    idx_zero = 0\<^sub>C\<^bsub>poly R\<^esub>,
+    idx_one = 1\<^sub>C\<^bsub>poly R\<^esub>,
+    idx_size = idx_size R ^ degree f,
+    idx_enum = poly_enum R (degree f),
+    idx_enum_inv = poly_enum_inv R (degree f) \<rparr>"
+
+definition poly_mod_ring_iso :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set"
+  where "poly_mod_ring_iso R f x = PIdl\<^bsub>poly_ring (ring_of R)\<^esub> f +>\<^bsub>poly_ring (ring_of R)\<^esub> x"
+
+definition poly_mod_ring_iso_inv :: "('a,'b) idx_ring_enum_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list"
+  where "poly_mod_ring_iso_inv R f =
+    the_inv_into (carrier (ring_of (poly_mod_ring R f))) (poly_mod_ring_iso R f)"
+
+context
+  fixes f
+  fixes R :: "('a,'b) idx_ring_enum_scheme"
+  assumes field_R: "field\<^sub>C R"
+  assumes f_carr: "f \<in> carrier (poly_ring (ring_of R))"
+  assumes deg_f: "degree f > 0"
+begin
+
+private abbreviation P where "P \<equiv> poly_ring (ring_of R)"
+private abbreviation I where "I \<equiv> PIdl\<^bsub>poly_ring (ring_of R)\<^esub> f"
+
+interpretation field "ring_of R"
+  using field_R unfolding field\<^sub>C_def by auto
+
+interpretation d: domain "P"
+  by (intro univ_poly_is_domain carrier_is_subring)
+
+interpretation i: ideal I P
+  using f_carr by (intro d.cgenideal_ideal) auto
+
+interpretation s: ring_hom_ring P "P Quot I"  "(+>\<^bsub>P\<^esub>) I"
+  using i.rcos_ring_hom_ring by auto
+
+interpretation cr: cring "P Quot I"
+    by (intro i.quotient_is_cring d.cring_axioms)
+
+lemma ring_c: "ring\<^sub>C R"
+  using field_R unfolding field\<^sub>C_def domain\<^sub>C_def cring\<^sub>C_def by auto
+
+lemma d_poly: "domain\<^sub>C (poly R)" using field_R unfolding field\<^sub>C_def by (intro poly_domain) auto
+
+lemma ideal_mod:
+  assumes "y \<in> carrier P"
+  shows "I +>\<^bsub>P\<^esub> (pmod y f) = I +>\<^bsub>P\<^esub> y"
+proof -
+  have "f \<in> I" by (intro d.cgenideal_self f_carr)
+  hence "(f \<otimes>\<^bsub>P\<^esub> (pdiv y f)) \<in> I"
+    using long_division_closed[OF carrier_is_subfield] assms f_carr
+    by (intro i.I_r_closed) (simp_all)
+  hence "y \<in> I +>\<^bsub>P\<^esub> (pmod y f)"
+    using assms f_carr unfolding a_r_coset_def'
+    by (subst pdiv_pmod[OF carrier_is_subfield, where q="f"]) auto
+  thus ?thesis
+    by (intro i.a_repr_independence' assms long_division_closed[OF carrier_is_subfield] f_carr)
+qed
+
+lemma poly_mod_ring_carr_1:
+  "carrier (ring_of (poly_mod_ring R f)) = {xs. xs \<in> carrier P \<and> degree xs < degree f}"
+  (is "?L = ?R")
+proof -
+  have "?L = {xs. xs \<in> carrier (ring_of (poly R)) \<and> degree xs < degree f}"
+    using deg_f unfolding poly_mod_ring_def ring_of_def by auto
+  also have "... = ?R" unfolding ring_of_poly[OF ring_c] by simp
+  finally show ?thesis by simp
+qed
+
+lemma poly_mod_ring_carr:
+  assumes "y \<in> carrier P"
+  shows "pmod y f \<in> carrier (ring_of (poly_mod_ring R f))"
+proof -
+  have "f \<noteq> []" using deg_f by auto
+  hence "pmod y f = [] \<or> degree (pmod y f) < degree f"
+    by (intro pmod_degree[OF carrier_is_subfield] assms f_carr)
+  hence "degree (pmod y f) < degree f" using deg_f by auto
+  moreover have "pmod y f \<in> carrier P"
+    using f_carr assms long_division_closed[OF carrier_is_subfield] by auto
+  ultimately show ?thesis unfolding poly_mod_ring_carr_1 by auto
+qed
+
+lemma poly_mod_ring_iso_ran:
+  "poly_mod_ring_iso R f ` carrier (ring_of (poly_mod_ring R f)) = carrier (P Quot I)"
+proof -
+  have "poly_mod_ring_iso R f x \<in> carrier (P Quot I)"
+    if "x \<in> carrier (ring_of (poly_mod_ring R f))" for x
+  proof -
+    have "I \<subseteq> carrier P" by auto
+    moreover have "x \<in> carrier P" using that unfolding poly_mod_ring_carr_1 by auto
+    ultimately have "poly_mod_ring_iso R f x \<in> a_rcosets\<^bsub>P\<^esub> I"
+      using that f_carr unfolding  poly_mod_ring_iso_def by (intro d.a_rcosetsI) auto
+    thus ?thesis unfolding FactRing_def by simp
+  qed
+  moreover have "x \<in> poly_mod_ring_iso R f ` carrier (ring_of (poly_mod_ring R f))"
+    if "x \<in> carrier (P Quot I)" for x
+  proof -
+    have "x \<in> a_rcosets\<^bsub>P\<^esub> I" using that unfolding FactRing_def by auto
+    then obtain y where y_def: "x = I +>\<^bsub>P\<^esub> y" "y \<in> carrier P"
+      using that unfolding A_RCOSETS_def' by auto
+    define z where "z = pmod y f"
+    have "I +>\<^bsub>P\<^esub> z = I +>\<^bsub>P\<^esub> y" unfolding z_def by (intro ideal_mod y_def)
+    hence "poly_mod_ring_iso R f z = x" unfolding poly_mod_ring_iso_def y_def by simp
+    moreover have "z \<in> carrier (ring_of (poly_mod_ring R f))"
+      unfolding z_def by (intro poly_mod_ring_carr y_def)
+    ultimately show ?thesis by auto
+  qed
+  ultimately show ?thesis by auto
+qed
+
+lemma poly_mod_ring_iso_inj:
+  "inj_on (poly_mod_ring_iso R f) (carrier (ring_of (poly_mod_ring R f)))"
+proof (rule inj_onI)
+  fix x y
+  assume "x \<in> carrier (ring_of (poly_mod_ring R f))"
+  hence x:"x \<in> carrier P" "degree x < degree f" unfolding poly_mod_ring_carr_1 by auto
+  assume "y \<in> carrier (ring_of (poly_mod_ring R f))"
+  hence y:"y \<in> carrier P" "degree y < degree f" unfolding poly_mod_ring_carr_1 by auto
+
+  have "degree (x \<ominus>\<^bsub>P\<^esub> y) \<le> max (degree x) (degree (\<ominus>\<^bsub>P\<^esub>y))"
+    unfolding a_minus_def by (intro degree_add)
+  also have "... = max (degree x) (degree y)"
+    unfolding univ_poly_a_inv_degree[OF carrier_is_subring y(1)] by simp
+  also have "... < degree f" using x(2) y(2) by simp
+  finally have d:"degree (x \<ominus>\<^bsub>P\<^esub> y) < degree f" by simp
+
+  assume "poly_mod_ring_iso R f x = poly_mod_ring_iso R f y"
+  hence "I +>\<^bsub>P\<^esub> x = I +>\<^bsub>P\<^esub> y" unfolding poly_mod_ring_iso_def by simp
+  hence "x \<ominus>\<^bsub>P\<^esub> y \<in> I" using x y by (subst d.quotient_eq_iff_same_a_r_cos[OF i.ideal_axioms]) auto
+  hence "f pdivides\<^bsub>ring_of R\<^esub> (x \<ominus>\<^bsub>P\<^esub> y)"
+    using f_carr x(1) y d.m_comm unfolding cgenideal_def pdivides_def factor_def by auto
+  hence "(x \<ominus>\<^bsub>P\<^esub> y) = [] \<or> degree (x \<ominus>\<^bsub>P\<^esub> y) \<ge> degree f"
+    using x(1) y(1) f_carr pdivides_imp_degree_le[OF carrier_is_subring] by (meson d.minus_closed)
+  hence "(x \<ominus>\<^bsub>P\<^esub> y) = \<zero>\<^bsub>P\<^esub>" unfolding univ_poly_zero using d by simp
+  thus "x = y" using x(1) y(1) by simp
+qed
+
+lemma poly_mod_iso_ring_bij:
+  "bij_betw (poly_mod_ring_iso R f) (carrier (ring_of (poly_mod_ring R f))) (carrier (P Quot I))"
+  using poly_mod_ring_iso_ran poly_mod_ring_iso_inj unfolding bij_betw_def by simp
+
+lemma poly_mod_iso_ring_bij_2:
+  "bij_betw (poly_mod_ring_iso_inv R f) (carrier (P Quot I)) (carrier (ring_of (poly_mod_ring R f)))"
+  unfolding poly_mod_ring_iso_inv_def using poly_mod_iso_ring_bij bij_betw_the_inv_into by blast
+
+lemma poly_mod_ring_iso_inv_1:
+  assumes "x \<in> carrier (P Quot I)"
+  shows "poly_mod_ring_iso R f (poly_mod_ring_iso_inv R f x) = x"
+  unfolding poly_mod_ring_iso_inv_def using assms poly_mod_iso_ring_bij
+  by (intro f_the_inv_into_f_bij_betw) auto
+
+lemma poly_mod_ring_iso_inv_2:
+  assumes "x \<in> carrier (ring_of (poly_mod_ring R f))"
+  shows "poly_mod_ring_iso_inv R f (poly_mod_ring_iso R f x) = x"
+  unfolding poly_mod_ring_iso_inv_def using assms
+  by (intro the_inv_into_f_f poly_mod_ring_iso_inj)
+
+lemma poly_mod_ring_add:
+  assumes "x \<in> carrier P"
+  assumes "y \<in> carrier P"
+  shows "x \<oplus>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> y = pmod (x \<oplus>\<^bsub>P\<^esub> y) f" (is "?L = ?R")
+proof -
+  have "?L = pmod\<^sub>C R (x \<oplus>\<^bsub>ring_of (poly R)\<^esub> y) f"
+    unfolding poly_mod_ring_def ring_of_def using domain_cD[OF d_poly] by simp
+  also have "... = ?R"
+    using assms unfolding ring_of_poly[OF ring_c] by (intro pmod_c[OF field_R] f_carr) auto
+  finally show ?thesis
+    by simp
+qed
+
+lemma poly_mod_ring_zero: "\<zero>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<zero>\<^bsub>P\<^esub>"
+proof-
+  have "\<zero>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<zero>\<^bsub>ring_of (poly R)\<^esub>"
+    using domain_cD[OF d_poly] unfolding ring_of_def poly_mod_ring_def by simp
+  also have "... = \<zero>\<^bsub>P\<^esub>" unfolding ring_of_poly[OF ring_c] by simp
+  finally show ?thesis by simp
+qed
+
+lemma poly_mod_ring_one: "\<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<one>\<^bsub>P\<^esub>"
+proof-
+  have "\<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<one>\<^bsub>ring_of (poly R)\<^esub>"
+    using domain_cD[OF d_poly] unfolding ring_of_def poly_mod_ring_def by simp
+  also have "... = \<one>\<^bsub>P\<^esub>" unfolding ring_of_poly[OF ring_c] by simp
+  finally show "\<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<one>\<^bsub>P\<^esub>" by simp
+qed
+
+lemma poly_mod_ring_mult:
+  assumes "x \<in> carrier P"
+  assumes "y \<in> carrier P"
+  shows "x \<otimes>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> y = pmod (x \<otimes>\<^bsub>P\<^esub> y) f" (is "?L = ?R")
+proof -
+  have "?L = pmod\<^sub>C R (x \<otimes>\<^bsub>ring_of (poly R)\<^esub> y) f"
+    unfolding poly_mod_ring_def ring_of_def using domain_cD[OF d_poly] by simp
+  also have "... = ?R"
+    using assms unfolding poly_mod_ring_carr_1 ring_of_poly[OF ring_c]
+    by (intro pmod_c[OF field_R] f_carr) auto
+  finally show ?thesis
+    by simp
+qed
+
+lemma poly_mod_ring_iso_inv:
+  "poly_mod_ring_iso_inv R f \<in> ring_iso (P Quot I) (ring_of (poly_mod_ring R f))"
+  (is "?f \<in> ring_iso ?S ?T")
+proof (rule ring_iso_memI)
+  fix x assume "x \<in> carrier ?S"
+  thus "?f x \<in> carrier ?T" using bij_betw_apply[OF poly_mod_iso_ring_bij_2] by auto
+next
+  fix x y assume x:"x \<in> carrier ?S" and y: "y \<in> carrier ?S"
+  have "?f x \<in> carrier (ring_of (poly_mod_ring R f))"
+    by (rule bij_betw_apply[OF poly_mod_iso_ring_bij_2 x])
+  hence x':"?f x \<in> carrier P" unfolding poly_mod_ring_carr_1 by simp
+  have "?f y \<in> carrier (ring_of (poly_mod_ring R f))"
+    by (rule bij_betw_apply[OF poly_mod_iso_ring_bij_2 y])
+  hence y':"?f y \<in> carrier P" unfolding poly_mod_ring_carr_1 by simp
+
+  have 0:"?f x \<otimes>\<^bsub>?T\<^esub> ?f y = pmod (?f x \<otimes>\<^bsub>P\<^esub> ?f y) f"
+    by (intro poly_mod_ring_mult x' y')
+  also have "... \<in> carrier (ring_of (poly_mod_ring R f))"
+    using x' y' by (intro poly_mod_ring_carr) auto
+  finally have xy: "?f x \<otimes>\<^bsub>?T\<^esub> ?f y \<in> carrier (ring_of (poly_mod_ring R f))" by simp
+
+  have "?f (x \<otimes>\<^bsub>?S\<^esub> y) = ?f (poly_mod_ring_iso R f (?f x) \<otimes>\<^bsub>?S\<^esub> poly_mod_ring_iso R f (?f y))"
+    using x y by (simp add:poly_mod_ring_iso_inv_1)
+  also have "... = ?f ((I +>\<^bsub>P\<^esub> (?f x)) \<otimes>\<^bsub>?S\<^esub> (I +>\<^bsub>P\<^esub> (?f y)))"
+    unfolding poly_mod_ring_iso_def by simp
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (?f x \<otimes>\<^bsub>P\<^esub> ?f y))"
+    using x' y' by simp
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (pmod (?f x \<otimes>\<^bsub>P\<^esub> ?f y) f))"
+    using x' y' by (subst ideal_mod) auto
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (?f x \<otimes>\<^bsub>?T\<^esub> ?f y))"
+    unfolding 0 by simp
+  also have "... = ?f (poly_mod_ring_iso R f (?f x \<otimes>\<^bsub>?T\<^esub> ?f y))"
+    unfolding poly_mod_ring_iso_def by simp
+  also have "... = ?f x \<otimes>\<^bsub>?T\<^esub> ?f y"
+    using xy by (intro poly_mod_ring_iso_inv_2)
+  finally show "?f (x \<otimes>\<^bsub>?S\<^esub> y) = ?f x \<otimes>\<^bsub>?T\<^esub> ?f y" by simp
+next
+  fix x y assume x:"x \<in> carrier ?S" and y: "y \<in> carrier ?S"
+  have "?f x \<in> carrier (ring_of (poly_mod_ring R f))"
+    by (rule bij_betw_apply[OF poly_mod_iso_ring_bij_2 x])
+  hence x':"?f x \<in> carrier P" unfolding poly_mod_ring_carr_1 by simp
+  have "?f y \<in> carrier (ring_of (poly_mod_ring R f))"
+    by (rule bij_betw_apply[OF poly_mod_iso_ring_bij_2 y])
+  hence y':"?f y \<in> carrier P" unfolding poly_mod_ring_carr_1 by simp
+
+  have 0:"?f x \<oplus>\<^bsub>?T\<^esub> ?f y = pmod (?f x \<oplus>\<^bsub>P\<^esub> ?f y) f"  by (intro poly_mod_ring_add x' y')
+  also have "... \<in> carrier (ring_of (poly_mod_ring R f))"
+    using x' y' by (intro poly_mod_ring_carr) auto
+  finally have xy: "?f x \<oplus>\<^bsub>?T\<^esub> ?f y \<in> carrier (ring_of (poly_mod_ring R f))" by simp
+
+  have "?f (x \<oplus>\<^bsub>?S\<^esub> y) = ?f (poly_mod_ring_iso R f (?f x) \<oplus>\<^bsub>?S\<^esub> poly_mod_ring_iso R f (?f y))"
+    using x y by (simp add:poly_mod_ring_iso_inv_1)
+  also have "... = ?f ((I +>\<^bsub>P\<^esub> (?f x)) \<oplus>\<^bsub>?S\<^esub> (I +>\<^bsub>P\<^esub> (?f y)))"
+    unfolding poly_mod_ring_iso_def by simp
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (?f x \<oplus>\<^bsub>P\<^esub> ?f y))"
+    using x' y' by simp
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (pmod (?f x \<oplus>\<^bsub>P\<^esub> ?f y) f))"
+    using x' y' by (subst ideal_mod) auto
+  also have "... = ?f (I +>\<^bsub>P\<^esub> (?f x \<oplus>\<^bsub>?T\<^esub> ?f y))"
+    unfolding 0 by simp
+  also have "... = ?f (poly_mod_ring_iso R f (?f x \<oplus>\<^bsub>?T\<^esub> ?f y))"
+    unfolding poly_mod_ring_iso_def by simp
+  also have "... = ?f x \<oplus>\<^bsub>?T\<^esub> ?f y"
+    using xy by (intro poly_mod_ring_iso_inv_2)
+  finally show "?f (x \<oplus>\<^bsub>?S\<^esub> y) = ?f x \<oplus>\<^bsub>?T\<^esub> ?f y" by simp
+next
+  have "poly_mod_ring_iso R f \<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = (I +>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
+    unfolding poly_mod_ring_one poly_mod_ring_iso_def by simp
+  also have "... = \<one>\<^bsub>P Quot I\<^esub>" using s.hom_one by simp
+  finally have "poly_mod_ring_iso R f \<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> = \<one>\<^bsub>P Quot I\<^esub>" by simp
+  moreover have "degree \<one>\<^bsub>P\<^esub> < degree f"
+    using deg_f unfolding univ_poly_one by simp
+  hence "\<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> \<in> carrier (ring_of (poly_mod_ring R f))"
+    unfolding poly_mod_ring_one poly_mod_ring_carr_1 by simp
+  ultimately show "?f (\<one>\<^bsub>?S\<^esub>) = \<one>\<^bsub>?T\<^esub>"
+    unfolding poly_mod_ring_iso_inv_def by (intro the_inv_into_f_eq poly_mod_ring_iso_inj)
+next
+  show "bij_betw ?f (carrier ?S) (carrier ?T)" by (rule poly_mod_iso_ring_bij_2)
+qed
+
+lemma cring_poly_mod_ring_1:
+  shows "ring_of (poly_mod_ring R f)\<lparr>zero := poly_mod_ring_iso_inv R f \<zero>\<^bsub>P Quot I\<^esub>\<rparr> =
+    ring_of (poly_mod_ring R f)"
+    and  "cring (ring_of (poly_mod_ring R f))"
+proof -
+  let ?f = "poly_mod_ring_iso_inv R f"
+
+  have "poly_mod_ring_iso R f \<zero>\<^bsub>P\<^esub> = \<zero>\<^bsub>P Quot PIdl\<^bsub>P\<^esub> f\<^esub>"
+    unfolding poly_mod_ring_iso_def by simp
+  moreover have "[] \<in> carrier P" using univ_poly_zero[where K="carrier (ring_of R)"] by auto
+  ultimately have "?f \<zero>\<^bsub>P Quot I\<^esub> = \<zero>\<^bsub>P\<^esub>"
+    unfolding univ_poly_zero poly_mod_ring_iso_inv_def using deg_f
+    by (intro the_inv_into_f_eq bij_betw_imp_inj_on[OF poly_mod_iso_ring_bij])
+      (simp_all add:add:poly_mod_ring_carr_1)
+  also have "... = 0\<^sub>C\<^bsub>poly R\<^esub>" using ring_of_poly[OF ring_c] domain_cD[OF d_poly] by auto
+  finally have "?f \<zero>\<^bsub>P Quot I\<^esub> = 0\<^sub>C\<^bsub>poly R\<^esub>" by simp
+  thus "ring_of (poly_mod_ring R f)\<lparr>zero := ?f \<zero>\<^bsub>P Quot I\<^esub>\<rparr> = ring_of (poly_mod_ring R f)"
+    unfolding ring_of_def poly_mod_ring_def by auto
+  thus "cring (ring_of (poly_mod_ring R f))"
+    using cr.ring_iso_imp_img_cring[OF poly_mod_ring_iso_inv] by simp
+qed
+
+interpretation cr_p: cring "(ring_of (poly_mod_ring R f))"
+  by (rule cring_poly_mod_ring_1)
+
+lemma cring_c_poly_mod_ring: "cring\<^sub>C (poly_mod_ring R f)"
+proof -
+  let ?P = "ring_of (poly_mod_ring R f)"
+  have "-\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x = \<ominus>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> x" (is "?L = ?R")
+    if "x \<in> carrier (ring_of (poly_mod_ring R f))" for x
+  proof (rule cr_p.minus_equality[symmetric, OF _ that])
+    have "-\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x = -\<^sub>C\<^bsub>poly R\<^esub> x" unfolding poly_mod_ring_def by simp
+    also have "... = \<ominus>\<^bsub>P\<^esub> x" using that unfolding poly_mod_ring_carr_1
+      by (subst domain_cD[OF d_poly]) (simp_all add:ring_of_poly[OF ring_c])
+    finally have 0:"-\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x = \<ominus>\<^bsub>P\<^esub> x" by simp
+
+    have 1:"\<ominus>\<^bsub>P\<^esub> x \<in>  carrier (ring_of (poly_mod_ring R f))"
+      using that univ_poly_a_inv_degree[OF carrier_is_subring] unfolding poly_mod_ring_carr_1
+      by auto
+
+    have "-\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x \<oplus>\<^bsub>?P\<^esub> x = pmod (\<ominus>\<^bsub>P\<^esub> x \<oplus>\<^bsub>P\<^esub> x) f"
+      using that 1 unfolding 0 poly_mod_ring_carr_1 by (intro poly_mod_ring_add) auto
+    also have "... = pmod \<zero>\<^bsub>P\<^esub> f"
+      using that unfolding poly_mod_ring_carr_1 by simp algebra
+    also have "... = []"
+      unfolding univ_poly_zero using carrier_is_subfield f_carr long_division_zero(2) by presburger
+    also have "... =  \<zero>\<^bsub>?P\<^esub>" by (simp add:poly_mod_ring_def ring_of_def poly_def)
+    finally show "-\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x \<oplus>\<^bsub>?P\<^esub> x = \<zero>\<^bsub>?P\<^esub>" by simp
+
+    show " -\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> x \<in> carrier (ring_of (poly_mod_ring R f))"
+      unfolding 0 by (rule 1)
+  qed
+  moreover have "x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> = inv\<^bsub>ring_of (poly_mod_ring R f)\<^esub> x"
+    if x_unit: "x \<in> Units (ring_of (poly_mod_ring R f))" for x
+  proof (rule cr_p.comm_inv_char[symmetric])
+    show x_carr: "x \<in> carrier (ring_of (poly_mod_ring R f))"
+      using that unfolding Units_def by auto
+
+    obtain y where y:"x \<otimes>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> y = \<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub>"
+       and y_carr: "y \<in> carrier (ring_of (poly_mod_ring R f))"
+      using x_unit unfolding Units_def by auto
+
+    have "pmod (x \<otimes>\<^bsub>P\<^esub> y) f =x \<otimes>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> y"
+      using x_carr y_carr by (intro poly_mod_ring_mult[symmetric]) (auto simp:poly_mod_ring_carr_1)
+    also have "... = \<one>\<^bsub>P\<^esub>"
+      unfolding y poly_mod_ring_one by simp
+    finally have 1:"pmod (x \<otimes>\<^bsub>P\<^esub> y) f = \<one>\<^bsub>P\<^esub>" by simp
+
+    have "pcoprime\<^bsub>ring_of R\<^esub> (x \<otimes>\<^bsub>P\<^esub> y) f = pcoprime\<^bsub>ring_of R\<^esub> f (pmod (x \<otimes>\<^bsub>P\<^esub> y) f)"
+      using x_carr y_carr f_carr unfolding poly_mod_ring_carr_1 by (intro pcoprime_step) auto
+    also have "... = pcoprime \<^bsub>ring_of R\<^esub> f  \<one>\<^bsub>P\<^esub>" unfolding 1 by simp
+    also have "... = True" using pcoprime_one by simp
+    finally have "pcoprime\<^bsub>ring_of R\<^esub> (x \<otimes>\<^bsub>P\<^esub> y) f" by simp
+    hence "pcoprime\<^bsub>ring_of R\<^esub> x f"
+      using x_carr y_carr f_carr pcoprime_left_factor unfolding poly_mod_ring_carr_1 by blast
+    hence 2:"length (snd ( ext_euclidean R x f)) = 1"
+      using f_carr x_carr pcoprime_c[OF field_R] unfolding poly_mod_ring_carr_1 pcoprime\<^sub>C.simps
+      by auto
+
+    obtain u v r where uvr_def: "((u,v),r) = ext_euclidean R x f"  by (metis surj_pair)
+
+    have x_carr': "x \<in> carrier P" using x_carr unfolding poly_mod_ring_carr_1 by auto
+    have r_eq:"r = x \<otimes>\<^bsub>P\<^esub> u \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v" and ruv_carr: "{r, u, v} \<subseteq> carrier P"
+      using uvr_def[symmetric] ext_euclidean[OF field_R x_carr' f_carr] by auto
+
+    have "length r = 1" using 2 uvr_def[symmetric] by simp
+    hence 3:"r = [hd r]" by (cases r) auto
+    hence "r \<noteq> \<zero>\<^bsub>P\<^esub>" unfolding univ_poly_zero by auto
+    hence "hd r \<in> carrier (ring_of R) - {\<zero>\<^bsub>ring_of R\<^esub>}"
+      using ruv_carr by (intro lead_coeff_carr) auto
+    hence r_unit: "r \<in> Units P" using 3 univ_poly_units[OF carrier_is_subfield] by auto
+    hence inv_r_carr: "inv\<^bsub>P\<^esub> r \<in> carrier P" by simp
+
+    have 0: "x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> = pmod\<^sub>C R (r \<inverse>\<^sub>C\<^bsub>poly R\<^esub> *\<^sub>C\<^bsub>poly R\<^esub> u) f"
+      by (simp add:poly_mod_ring_def uvr_def[symmetric])
+    also have "... = pmod\<^sub>C R (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> u) f"
+      using r_unit unfolding domain_cD[OF d_poly]
+      by (subst domain_cD[OF d_poly]) (simp_all add:ring_of_poly[OF ring_c])
+    also have "... = pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> u) f"
+      using ruv_carr inv_r_carr by (intro pmod_c[OF field_R] f_carr) simp
+    finally have 0: "x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> = pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> u) f"
+      by simp
+
+    show "x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> \<in> carrier (ring_of (poly_mod_ring R f))"
+      using ruv_carr r_unit unfolding 0 by (intro poly_mod_ring_carr) simp
+
+    have 4: "degree \<one>\<^bsub>P\<^esub> < degree f" unfolding univ_poly_one using deg_f by auto
+
+    have "f divides\<^bsub>P\<^esub> inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v"
+      using inv_r_carr ruv_carr  f_carr
+      by (intro dividesI[where c="inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> v"]) (simp_all, algebra)
+    hence 5: "pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v) f = []"
+      using f_carr ruv_carr inv_r_carr
+      by (intro  iffD2[OF pmod_zero_iff_pdivides[OF carrier_is_subfield]]) (auto simp:pdivides_def)
+
+    have "x \<otimes>\<^bsub>?P\<^esub> x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> = pmod (x \<otimes>\<^bsub>P\<^esub> pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> u) f) f"
+      using ruv_carr inv_r_carr f_carr unfolding 0
+      by (intro poly_mod_ring_mult x_carr' long_division_closed[OF carrier_is_subfield]) simp_all
+    also have "... = pmod (x \<otimes>\<^bsub>P\<^esub> (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> u)) f"
+      using ruv_carr inv_r_carr f_carr by (intro pmod_mult_right[symmetric] x_carr') auto
+    also have "... = pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> (x \<otimes>\<^bsub>P\<^esub> u)) f"
+      using x_carr' ruv_carr inv_r_carr by (intro arg_cong2[where f="pmod"] refl) (simp, algebra)
+    also have "... = pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> (r \<ominus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v)) f" using ruv_carr f_carr x_carr'
+      by (intro arg_cong2[where f="pmod"] arg_cong2[where f="(\<otimes>\<^bsub>P\<^esub>)"] refl) (simp add:r_eq, algebra)
+    also have "... = pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v) f"
+      using ruv_carr inv_r_carr f_carr by (intro arg_cong2[where f="pmod"] refl) (simp, algebra)
+    also have "... = pmod \<one>\<^bsub>P\<^esub> f \<oplus>\<^bsub>P\<^esub> pmod (\<ominus>\<^bsub>P\<^esub> (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v)) f"
+      using ruv_carr inv_r_carr f_carr  unfolding d.Units_l_inv[OF r_unit] a_minus_def
+      by (intro long_division_add[OF carrier_is_subfield]) simp_all
+    also have "... = \<one>\<^bsub>P\<^esub> \<ominus>\<^bsub>P\<^esub> pmod (inv\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> v) f"
+      using ruv_carr f_carr inv_r_carr unfolding a_minus_def
+      by (intro arg_cong2[where f="(\<oplus>\<^bsub>P\<^esub>)"] pmod_const[OF carrier_is_subfield]
+          long_division_a_inv[OF carrier_is_subfield] 4) simp_all
+    also have "... = \<one>\<^bsub>P\<^esub> \<ominus>\<^bsub>P\<^esub> \<zero>\<^bsub>P\<^esub>" unfolding 5 univ_poly_zero by simp
+    also have "... =  \<one>\<^bsub>ring_of (poly_mod_ring R f)\<^esub>" unfolding poly_mod_ring_one by algebra
+    finally show "x \<otimes>\<^bsub>ring_of (poly_mod_ring R f)\<^esub> x \<inverse>\<^sub>C\<^bsub>poly_mod_ring R f\<^esub> = \<one>\<^bsub>?P\<^esub>" by simp
+  qed
+  ultimately show ?thesis using cring_poly_mod_ring_1 by (intro cring_cI)
+qed
+
+
+end
+
+lemma field_c_poly_mod_ring:
+  assumes field_R: "field\<^sub>C R"
+  assumes "monic_irreducible_poly (ring_of R) f"
+  shows "field\<^sub>C (poly_mod_ring R f)"
+proof -
+  interpret field "ring_of R" using field_R unfolding field\<^sub>C_def by auto
+
+  have f_carr: "f \<in> carrier (poly_ring (ring_of R))"
+    using assms(2) monic_poly_carr unfolding monic_irreducible_poly_def by auto
+
+  have deg_f: "degree f > 0" using monic_poly_min_degree assms(2) by fastforce
+
+  have f_irred: "pirreducible\<^bsub>ring_of R\<^esub> (carrier (ring_of R)) f"
+    using assms(2) unfolding monic_irreducible_poly_def by auto
+
+  interpret r:field "poly_ring (ring_of R) Quot (PIdl\<^bsub>poly_ring (ring_of R)\<^esub> f)"
+    using f_irred f_carr iffD2[OF rupture_is_field_iff_pirreducible[OF carrier_is_subfield]]
+    unfolding rupture_def by blast
+
+  have "field (ring_of (poly_mod_ring R f))"
+    using r.ring_iso_imp_img_field[OF poly_mod_ring_iso_inv[OF field_R f_carr deg_f]]
+    using cring_poly_mod_ring_1(1)[OF field_R f_carr deg_f] by simp
+  moreover have "cring\<^sub>C (poly_mod_ring R f)"
+    by (rule cring_c_poly_mod_ring[OF field_R f_carr deg_f])
+  ultimately show ?thesis unfolding field\<^sub>C_def domain\<^sub>C_def using field.axioms(1) by blast
+qed
+
+
+lemma enum_c_poly_mod_ring:
+  assumes "enum\<^sub>C R" "ring\<^sub>C R"
+  shows "enum\<^sub>C (poly_mod_ring R f)"
+proof (rule enum_cI)
+  let ?l = "degree f"
+  let ?b = "idx_size R"
+  let ?S = "carrier (ring_of (poly_mod_ring R f))"
+
+  note bij_0 = bij_betw_poly_enum[where l="degree f", OF assms(1,2)]
+  have "?S = {xs \<in> carrier (poly_ring (ring_of R)). length xs \<le> ?l}"
+    unfolding ring_of_poly[OF assms(2),symmetric] poly_mod_ring_def by (simp add:ring_of_def)
+  hence bij_1:"bij_betw (poly_enum R (degree f)) {..<idx_size R ^ degree f} ?S"
+    using bij_0 by simp
+  hence bij_2:"bij_betw (idx_enum (poly_mod_ring R f)) {..<idx_size R^degree f} ?S"
+    unfolding poly_mod_ring_def by simp
+
+  have "order (ring_of (poly_mod_ring R f)) = card ?S"
+    unfolding Coset.order_def by simp
+  also have "... = card {..<idx_size R ^ degree f}" using bij_2 by (metis bij_betw_same_card)
+  finally have ord_poly_mod_ring: "order (ring_of (poly_mod_ring R f)) = idx_size R^degree f"
+    by simp
+
+  show "finite ?S" using bij_2 bij_betw_finite by blast
+  show "idx_size (poly_mod_ring R f) = order (ring_of (poly_mod_ring R f))"
+    unfolding ord_poly_mod_ring by (simp add:poly_mod_ring_def)
+  show "bij_betw (idx_enum (poly_mod_ring R f)) {..<order (ring_of (poly_mod_ring R f))} ?S"
+    using bij_2 ord_poly_mod_ring by auto
+  show "idx_enum_inv (poly_mod_ring R f) (idx_enum (poly_mod_ring R f) x) = x" (is "?L = _ ")
+    if "x < order (ring_of (poly_mod_ring R f))" for x
+  proof -
+    have "?L = poly_enum_inv R (degree f) (poly_enum R (degree f) x)"
+      unfolding poly_mod_ring_def by simp
+    also have "... = the_inv_into {..<?b ^ ?l} (poly_enum R ?l) (poly_enum R ?l x)"
+      using that ord_poly_mod_ring
+      by (intro poly_enum_inv[OF assms(1,2),symmetric] bij_betw_apply[OF bij_0]) auto
+    also have "... = x"
+      using that ord_poly_mod_ring by (intro the_inv_into_f_f bij_betw_imp_inj_on[OF bij_0]) auto
+    finally show ?thesis by simp
+  qed
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Poly_Ring_Code.thy b/thys/Finite_Fields/Finite_Fields_Poly_Ring_Code.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Finite_Fields_Poly_Ring_Code.thy
@@ -0,0 +1,666 @@
+section \<open>Executable Polynomial Rings\<close>
+
+theory Finite_Fields_Poly_Ring_Code
+  imports
+    Finite_Fields_Indexed_Algebra_Code
+    "HOL-Algebra.Polynomials"
+    Finite_Fields.Card_Irreducible_Polynomials_Aux
+begin
+
+fun o_normalize :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list"
+  where
+    "o_normalize E [] = []"
+  | "o_normalize E p = (if lead_coeff p \<noteq> 0\<^sub>C\<^bsub>E\<^esub> then p else o_normalize E (tl p))"
+
+fun o_poly_add :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "o_poly_add E p1 p2 = (
+    if length p1 \<ge> length p2
+      then o_normalize E (map2 (idx_plus E) p1 ((replicate (length p1 - length p2) 0\<^sub>C\<^bsub>E\<^esub> ) @ p2))
+      else o_poly_add E p2 p1)"
+
+fun o_poly_mult :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
+  where
+    "o_poly_mult E [] p2 = []"
+  | "o_poly_mult E p1 p2 =
+       o_poly_add E ((map (idx_mult E (hd p1)) p2) @
+      (replicate (degree p1) 0\<^sub>C\<^bsub>E\<^esub> )) (o_poly_mult E (tl p1) p2)"
+
+definition poly :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list idx_ring"
+  where "poly E = \<lparr>
+    idx_pred = (\<lambda>x. (x = [] \<or> hd x \<noteq> 0\<^sub>C\<^bsub>E\<^esub>) \<and> list_all (idx_pred E) x),
+    idx_uminus = (\<lambda>x. map (idx_uminus E) x),
+    idx_plus = o_poly_add E,
+    idx_udivide = (\<lambda>x. [idx_udivide E (hd x)]),
+    idx_mult = o_poly_mult E,
+    idx_zero = [],
+    idx_one = [idx_one E] \<rparr>"
+
+definition poly_var :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list"  ("X\<^sub>C\<index>")
+  where "poly_var E = [idx_one E, idx_zero E]"
+
+lemma poly_var: "poly_var R = X\<^bsub>ring_of R\<^esub>"
+  unfolding var_def poly_var_def by (simp add:ring_of_def)
+
+fun poly_eval :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a"
+  where "poly_eval R fs x = fold (\<lambda>a b. b *\<^sub>C\<^bsub>R\<^esub> x +\<^sub>C\<^bsub>R\<^esub> a) fs 0\<^sub>C\<^bsub>R\<^esub>"
+
+
+
+lemma ring_of_poly:
+  assumes "ring\<^sub>C A"
+  shows "ring_of (poly A) = poly_ring (ring_of A)"
+proof (intro ring.equality)
+  interpret ring "ring_of A" using assms unfolding ring\<^sub>C_def by auto
+
+  have b: "\<zero>\<^bsub>ring_of A\<^esub> = 0\<^sub>C\<^bsub>A\<^esub>" unfolding ring_of_def by simp
+  have c: "(\<otimes>\<^bsub>ring_of A\<^esub>) = (*\<^sub>C\<^bsub>A\<^esub>)" unfolding ring_of_def by simp
+  have d: "(\<oplus>\<^bsub>ring_of A\<^esub>) = (+\<^sub>C\<^bsub>A\<^esub>)" unfolding ring_of_def by simp
+
+  have " o_normalize A  x = normalize x" for x
+    using b by (induction x) simp_all
+
+  hence "o_poly_add A x y = poly_add x y" if "length y \<le> length x" for x y
+    using that by (subst o_poly_add.simps, subst poly_add.simps) (simp add: b d)
+  hence a:"o_poly_add A x y = poly_add x y" for x y
+    by (subst o_poly_add.simps, subst poly_add.simps) simp
+
+  hence "x \<oplus>\<^bsub>ring_of (poly A)\<^esub> y = x \<oplus>\<^bsub>poly_ring (ring_of A)\<^esub> y" for x y
+    by (simp add:univ_poly_def poly_def ring_of_def)
+
+  thus "(\<oplus>\<^bsub>ring_of (poly A)\<^esub>) = (\<oplus>\<^bsub>poly_ring (ring_of A)\<^esub>)" by (intro ext)
+
+  show "carrier (ring_of (poly A)) = carrier (poly_ring (ring_of A))"
+    by (auto simp add: ring_of_def poly_def univ_poly_def polynomial_def list_all_iff)
+
+  have "o_poly_mult A x y = poly_mult x y" for x y
+  proof (induction x)
+    case Nil then show ?case by simp
+  next
+    case (Cons a x) then show ?case
+      by (subst o_poly_mult.simps,subst poly_mult.simps)
+        (simp add:a b c del:poly_add.simps o_poly_add.simps)
+  qed
+  hence "x \<otimes>\<^bsub>ring_of (poly A)\<^esub> y = x \<otimes>\<^bsub>poly_ring (ring_of A)\<^esub> y" for x y
+    by (simp add:  univ_poly_def poly_def ring_of_def)
+  thus "(\<otimes>\<^bsub>ring_of (poly A)\<^esub>) = (\<otimes>\<^bsub>poly_ring (ring_of A)\<^esub>)" by (intro ext)
+
+qed (simp_all add:ring_of_def poly_def univ_poly_def)
+
+lemma poly_eval:
+  assumes "ring\<^sub>C R"
+  assumes fsc:"fs \<in> carrier (ring_of (poly R))" and xc:"x \<in> carrier (ring_of R)"
+  shows "poly_eval R fs x = ring.eval (ring_of R) fs x"
+proof -
+  interpret ring "ring_of R" using assms unfolding ring\<^sub>C_def by auto
+
+  have fs_carr:"fs \<in> carrier (poly_ring (ring_of R))" using ring_of_poly[OF assms(1)] fsc by auto
+  hence "set fs \<subseteq> carrier (ring_of R)" by (simp add: polynomial_incl univ_poly_carrier)
+  thus ?thesis
+  proof (induction rule:rev_induct)
+    case Nil thus ?case by simp (simp add:ring_of_def)
+  next
+    case (snoc ft fh)
+    have "poly_eval R (fh @ [ft]) x = poly_eval R fh x *\<^sub>C\<^bsub>R\<^esub> x +\<^sub>C\<^bsub>R\<^esub> ft" by simp
+    also have "... = eval fh x *\<^sub>C\<^bsub>R\<^esub> x +\<^sub>C\<^bsub>R\<^esub> ft" using snoc by (subst snoc) auto
+    also have "... = eval fh x \<otimes>\<^bsub>ring_of R\<^esub> x \<oplus>\<^bsub>ring_of R\<^esub> ft " by (simp add:ring_of_def)
+    also have " ... = eval (fh@[ft]) x" using snoc by (intro eval_append_aux[symmetric] xc) auto
+    finally show ?case by auto
+  qed
+qed
+
+lemma poly_domain:
+  assumes "domain\<^sub>C A"
+  shows "domain\<^sub>C (poly A)"
+proof -
+  interpret domain "ring_of A" using assms unfolding domain\<^sub>C_def by auto
+
+  have a:"\<ominus>\<^bsub>ring_of A\<^esub> x = -\<^sub>C\<^bsub>A\<^esub> x" if "x \<in> carrier (ring_of A)" for x
+    using that by (intro domain_cD[symmetric] assms)
+  have "ring\<^sub>C A"
+    using assms unfolding domain\<^sub>C_def cring\<^sub>C_def by auto
+  hence b:"ring_of (poly A) = poly_ring (ring_of A)"
+    by (subst ring_of_poly) auto
+
+  have c:"domain (ring_of (poly A))"
+    unfolding b by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  interpret d: domain "poly_ring (ring_of A)"
+    using c unfolding b by simp
+
+  have "-\<^sub>C\<^bsub>poly A\<^esub> x = \<ominus>\<^bsub>ring_of (poly A)\<^esub> x" if "x \<in> carrier (ring_of (poly A))" for x
+  proof -
+    have "\<ominus>\<^bsub>ring_of (poly A)\<^esub> x =  map (a_inv (ring_of A)) x"
+      using that unfolding b by (subst univ_poly_a_inv_def'[OF carrier_is_subring]) auto
+    also have "... = map (\<lambda>r. -\<^sub>C\<^bsub>A\<^esub> r) x"
+      using that  unfolding b univ_poly_carrier[symmetric] polynomial_def
+      by (intro map_cong refl a) auto
+    also have "... = -\<^sub>C\<^bsub>poly A\<^esub> x"
+      unfolding poly_def by simp
+    finally show ?thesis by simp
+  qed
+  moreover have "x \<inverse>\<^sub>C\<^bsub>poly A\<^esub> = inv\<^bsub>ring_of (poly A)\<^esub> x" if "x \<in> Units (ring_of (poly A))" for x
+  proof -
+    have "x \<in> {[k] |k. k \<in> carrier (ring_of A) - {\<zero>\<^bsub>ring_of A\<^esub>}}"
+      using that univ_poly_carrier_units_incl unfolding b by auto
+    then obtain k where x_eq: "k \<in> carrier (ring_of A) - {\<zero>\<^bsub>ring_of A\<^esub>}" "x = [k]" by auto
+    have "inv\<^bsub>ring_of (poly A)\<^esub> x \<in> Units (poly_ring (ring_of A))"
+      using that unfolding b by simp
+    hence "inv\<^bsub>ring_of (poly A)\<^esub> x \<in> {[k] |k. k \<in> carrier (ring_of A) - {\<zero>\<^bsub>ring_of A\<^esub>}}"
+      using that univ_poly_carrier_units_incl unfolding b by auto
+    then obtain v where x_inv_eq: "v\<in> carrier (ring_of A) - {\<zero>\<^bsub>ring_of A\<^esub>}"
+      "inv\<^bsub>ring_of (poly A)\<^esub> x = [v]" by auto
+
+    have "poly_mult [k] [v] = [k] \<otimes>\<^bsub>ring_of (poly A)\<^esub> [v]" unfolding b univ_poly_mult by simp
+    also have "... = x \<otimes>\<^bsub>ring_of (poly A)\<^esub> inv\<^bsub>ring_of (poly A)\<^esub> x" using x_inv_eq x_eq by auto
+    also have "... = \<one>\<^bsub>ring_of (poly A)\<^esub>" using that unfolding b by simp
+    also have "... = [\<one>\<^bsub>ring_of A\<^esub>]" unfolding b univ_poly_one by (simp add:ring_of_def)
+    finally have "poly_mult [k] [v] = [\<one>\<^bsub>ring_of A\<^esub>]" by simp
+    hence "k \<otimes>\<^bsub>ring_of A\<^esub> v \<oplus>\<^bsub>ring_of A\<^esub> \<zero>\<^bsub>ring_of A\<^esub> =  \<one>\<^bsub>ring_of A\<^esub>"
+      by (simp add:if_distribR if_distrib) (simp cong:if_cong, metis)
+    hence e: "k \<otimes>\<^bsub>ring_of A\<^esub> v = \<one>\<^bsub>ring_of A\<^esub>" using x_eq(1) x_inv_eq(1) by simp
+    hence f: "v \<otimes>\<^bsub>ring_of A\<^esub> k = \<one>\<^bsub>ring_of A\<^esub>" using x_eq(1) x_inv_eq(1) m_comm by simp
+    have g: "v = inv\<^bsub>ring_of A\<^esub> k"
+      using e x_eq(1) x_inv_eq(1) by (intro comm_inv_char[symmetric]) auto
+    hence h: "k \<in> Units (ring_of A)" unfolding Units_def using e f x_eq(1) x_inv_eq(1) by blast
+
+    have "x \<inverse>\<^sub>C\<^bsub>poly A\<^esub> = [k] \<inverse>\<^sub>C\<^bsub>poly A\<^esub>" unfolding x_eq by simp
+    also have "... = [k \<inverse>\<^sub>C\<^bsub>A\<^esub>]" unfolding poly_def by simp
+    also have "... = [v]"
+      unfolding g by (intro domain_cD[OF assms(1)] arg_cong2[where f="(#)"] h refl)
+    also have "... = inv\<^bsub>ring_of (poly A)\<^esub> x" unfolding x_inv_eq by simp
+    finally show ?thesis by simp
+  qed
+  ultimately show ?thesis using c by (intro domain_cI)
+qed
+
+function long_division\<^sub>C :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list"
+  where "long_division\<^sub>C F f g = (
+    if (length g = 0 \<or> length f < length g)
+      then ([], f)
+      else (
+        let k = length f - length g;
+            \<alpha> = -\<^sub>C\<^bsub>F\<^esub> (hd f *\<^sub>C\<^bsub>F\<^esub>  (hd g) \<inverse>\<^sub>C\<^bsub>F\<^esub>);
+            h = [\<alpha>] *\<^sub>C\<^bsub>poly F\<^esub> X\<^sub>C\<^bsub>F\<^esub> ^\<^sub>C\<^bsub>poly F\<^esub> k;
+            f' = f +\<^sub>C\<^bsub>poly F\<^esub> (h *\<^sub>C\<^bsub>poly F\<^esub> g);
+            f'' = take (length f - 1) f'
+        in apfst (\<lambda>x. x +\<^sub>C\<^bsub>poly F\<^esub> -\<^sub>C\<^bsub>poly F\<^esub> h) (long_division\<^sub>C F f'' g)))"
+  by pat_completeness auto
+
+lemma pmod_termination_helper:
+  "g \<noteq> [] \<Longrightarrow> \<not>length f < length g \<Longrightarrow> min x (length f - 1) < length f"
+  by (metis diff_less length_greater_0_conv list.size(3) min.strict_coboundedI2 zero_less_one)
+
+termination by (relation "measure (\<lambda>(_, f, _). length f)") (use pmod_termination_helper in auto)
+
+declare long_division\<^sub>C.simps[simp del]
+
+lemma long_division_c_length:
+  assumes "length g > 0"
+  shows "length (snd (long_division\<^sub>C R f g)) < length g"
+proof (induction "length f" arbitrary:f rule:nat_less_induct)
+  case 1
+  have 0:"length (snd (long_division\<^sub>C R x g)) < length g"
+    if "length x < length f" for x using 1 that by blast
+
+  show "length (snd (long_division\<^sub>C R f g)) < length g"
+  proof (cases "length f < length g")
+    case True then show ?thesis by (subst long_division\<^sub>C.simps) simp
+  next
+    case False
+    hence "length f > 0" using assms by auto
+    thus ?thesis using assms by (subst long_division\<^sub>C.simps)
+       (auto intro!:0 simp: min.commute min.strict_coboundedI1 Let_def)
+  qed
+qed
+
+
+context field
+begin
+
+interpretation r:polynomial_ring R "(carrier R)"
+    unfolding polynomial_ring_def polynomial_ring_axioms_def
+    using carrier_is_subfield field_axioms by force
+
+lemma poly_length_from_coeff:
+  assumes "p \<in> carrier (poly_ring R)"
+  assumes "\<And>i. i \<ge> k \<Longrightarrow> coeff p i = \<zero>"
+  shows "length p \<le> k"
+proof (rule ccontr)
+  assume a:"\<not>length p \<le> k"
+  hence p_nz: "p \<noteq> []" by auto
+  have "k < length p" using a by simp
+  hence "k \<le> length p - 1" by simp
+  hence "\<zero> = coeff p (degree p)" by (intro assms(2)[symmetric])
+  also have "... = lead_coeff p" by (intro lead_coeff_simp[OF p_nz])
+  finally have "\<zero> = lead_coeff p" by simp
+  thus "False"
+    using p_nz assms(1) unfolding univ_poly_def polynomial_def by simp
+qed
+
+lemma  poly_add_cancel_len:
+  assumes "f \<in> carrier (poly_ring R) - {\<zero>\<^bsub>poly_ring R\<^esub>}"
+  assumes "g \<in> carrier (poly_ring R) - {\<zero>\<^bsub>poly_ring R\<^esub>}"
+  assumes "hd f = \<ominus> hd g" "degree f = degree g"
+  shows "length (f \<oplus>\<^bsub>poly_ring R\<^esub> g) < length f"
+proof -
+  have f_ne: "f \<noteq> []" using assms(1) unfolding univ_poly_zero by simp
+  have g_ne: "g \<noteq> []" using assms(2) unfolding univ_poly_zero by simp
+
+  have "coeff f i = \<ominus>coeff g i" if "i \<ge> degree f" for i
+  proof (cases "i = degree f")
+    case True
+    have "coeff f i = hd f" unfolding True by (subst lead_coeff_simp[OF f_ne]) simp
+    also have "... = \<ominus>hd g" using assms(3) by simp
+    also have "... = \<ominus>coeff g i" unfolding True assms(4) by (subst lead_coeff_simp[OF g_ne]) simp
+    finally show ?thesis by simp
+  next
+    case False
+    hence "i > degree f" "i > degree g" using  assms(4) that by auto
+    thus "coeff f i = \<ominus> coeff g i" using coeff_degree by simp
+  qed
+  hence "coeff (f \<oplus>\<^bsub>poly_ring R\<^esub> g) i = \<zero>" if "i \<ge> degree f" for i
+    using assms(1,2) that by (subst r.coeff_add) (auto intro:l_neg simp:  r.coeff_range)
+
+  hence "length (f \<oplus>\<^bsub>poly_ring R\<^esub> g) \<le> length f - 1"
+    using assms(1,2) by (intro poly_length_from_coeff) auto
+  also have "... < length f" using f_ne by simp
+  finally show ?thesis by simp
+qed
+
+lemma pmod_mult_left:
+  assumes "f \<in> carrier (poly_ring R)"
+  assumes "g \<in> carrier (poly_ring R)"
+  assumes "h \<in> carrier (poly_ring R)"
+  shows "(f \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h = ((f pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h" (is "?L = ?R")
+proof -
+  have "h pdivides (h \<otimes>\<^bsub>poly_ring R\<^esub> (f pdiv h)) \<otimes>\<^bsub>poly_ring R\<^esub> g"
+    using assms long_division_closed[OF carrier_is_subfield]
+    by (simp add: dividesI' pdivides_def r.p.m_assoc)
+  hence 0:"(h \<otimes>\<^bsub>poly_ring R\<^esub> (f pdiv h)) \<otimes>\<^bsub>poly_ring R\<^esub> g pmod h = \<zero>\<^bsub>poly_ring R\<^esub>"
+    using pmod_zero_iff_pdivides[OF carrier_is_subfield] assms
+      long_division_closed[OF carrier_is_subfield] univ_poly_zero
+    by (metis (no_types, opaque_lifting) r.p.m_closed)
+
+  have "?L = (h \<otimes>\<^bsub>poly_ring R\<^esub> (f pdiv h) \<oplus>\<^bsub>poly_ring R\<^esub> (f pmod h)) \<otimes>\<^bsub>poly_ring R\<^esub> g pmod h"
+    using assms by (intro arg_cong2[where f="(\<otimes>\<^bsub>poly_ring R\<^esub>)"] arg_cong2[where f="(pmod)"]
+     pdiv_pmod[OF carrier_is_subfield]) auto
+  also have "... = ((h \<otimes>\<^bsub>poly_ring R\<^esub> (f pdiv h)) \<otimes>\<^bsub>poly_ring R\<^esub> g \<oplus>\<^bsub>poly_ring R\<^esub>
+    (f pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h"
+    using assms long_division_closed[OF carrier_is_subfield]
+    by (intro r.p.l_distr arg_cong2[where f="(pmod)"]) auto
+  also have "... = ((h \<otimes>\<^bsub>poly_ring R\<^esub> (f pdiv h)) \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h \<oplus>\<^bsub>poly_ring R\<^esub>
+    ((f pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> g pmod h)"
+    using assms long_division_closed[OF carrier_is_subfield]
+    by (intro long_division_add[OF carrier_is_subfield]) auto
+  also have "... = ?R"
+    using assms long_division_closed[OF carrier_is_subfield] unfolding 0 by auto
+  finally show ?thesis
+    by simp
+qed
+
+lemma pmod_mult_right:
+  assumes "f \<in> carrier (poly_ring R)"
+  assumes "g \<in> carrier (poly_ring R)"
+  assumes "h \<in> carrier (poly_ring R)"
+  shows "(f \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h = (f \<otimes>\<^bsub>poly_ring R\<^esub> (g pmod h)) pmod h" (is "?L = ?R")
+proof -
+  have "?L = (g \<otimes>\<^bsub>poly_ring R\<^esub> f) pmod h" using assms by algebra
+  also have "... = ((g pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> f) pmod h" by (intro pmod_mult_left assms)
+  also have "... = ?R" using assms long_division_closed[OF carrier_is_subfield] by algebra
+  finally show ?thesis by simp
+qed
+
+lemma pmod_mult_both:
+  assumes "f \<in> carrier (poly_ring R)"
+  assumes "g \<in> carrier (poly_ring R)"
+  assumes "h \<in> carrier (poly_ring R)"
+  shows "(f \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h = ((f pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> (g pmod h)) pmod h"
+    (is "?L = ?R")
+proof -
+  have "(f \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h = ((f pmod h) \<otimes>\<^bsub>poly_ring R\<^esub> g) pmod h"
+    by (intro pmod_mult_left assms)
+  also have "... = ?R"
+    using assms long_division_closed[OF carrier_is_subfield] by (intro pmod_mult_right) auto
+  finally show ?thesis by simp
+qed
+
+lemma field_Unit_minus_closed:
+  assumes "x \<in> Units R"
+  shows "\<ominus> x \<in> Units R"
+  using assms mult_of.Units_eq by auto
+
+end
+
+lemma long_division_c:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  shows "long_division\<^sub>C R f g = (ring.pdiv (ring_of R) f g, ring.pmod (ring_of R) f g)"
+proof -
+  let ?P = "poly_ring (ring_of R)"
+  let ?result = "(\<lambda>f r. f = snd r \<oplus>\<^bsub>poly_ring (ring_of R)\<^esub> (fst r \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g))"
+
+  define r where "r = long_division\<^sub>C R f g"
+
+  interpret field "ring_of R" using assms(1) unfolding field\<^sub>C_def by auto
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  have ring_c: "ring\<^sub>C R" using assms(1) unfolding field\<^sub>C_def domain\<^sub>C_def cring\<^sub>C_def by auto
+  have d_poly: "domain\<^sub>C (poly R)" using assms (1) unfolding field\<^sub>C_def by (intro poly_domain) auto
+
+  have "r = long_division\<^sub>C R f g \<Longrightarrow> ?result f r \<and> {fst r, snd r} \<subseteq> carrier (poly_ring (ring_of R))"
+    using assms(2)
+  proof (induction "length f" arbitrary: f r rule:nat_less_induct)
+    case 1
+
+    have ind: "x = snd q \<oplus>\<^bsub>?P\<^esub> fst q \<otimes>\<^bsub>?P\<^esub> g" "{fst q, snd q} \<subseteq> carrier (poly_ring (ring_of R))"
+      if "length x < length f " "q = long_division\<^sub>C R x g" "x \<in> carrier (poly_ring (ring_of R)) "
+      for x q using 1(1) that by auto
+
+    show ?case
+    proof (cases "length g = 0 \<or> length f < length g")
+      case True
+      hence "r = (\<zero>\<^bsub>poly_ring (ring_of R)\<^esub>, f)"
+        unfolding 1(2) univ_poly_zero by (subst long_division\<^sub>C.simps) simp
+      then show ?thesis using assms(3) 1(3) by simp
+    next
+      case False
+      hence "length g > 0" "length f \<ge> length g" by auto
+      hence "f \<noteq> []" "g \<noteq> []" by auto
+      hence f_carr: "f \<in> carrier ?P - {\<zero>\<^bsub>?P\<^esub>}" and g_carr: "g \<in> carrier ?P - {\<zero>\<^bsub>?P\<^esub>}"
+         using 1(3) assms(3) univ_poly_zero by auto
+
+      define k where "k = length f - length g"
+      define \<alpha> where "\<alpha> = -\<^sub>C\<^bsub>R\<^esub> (hd f *\<^sub>C\<^bsub>R\<^esub>  (hd g) \<inverse>\<^sub>C\<^bsub>R\<^esub>)"
+      define h where "h = [\<alpha>] *\<^sub>C\<^bsub>poly R\<^esub> X\<^sub>C\<^bsub>R\<^esub> ^\<^sub>C\<^bsub>poly R\<^esub> k"
+      define f' where "f' = f +\<^sub>C\<^bsub>poly R\<^esub> (h *\<^sub>C\<^bsub>poly R\<^esub> g)"
+      define f'' where "f'' = take (length f - 1) f'"
+      obtain s t where st_def: "(s,t) = long_division\<^sub>C R f'' g" by (metis surj_pair)
+
+      have "r = apfst (\<lambda>x. x +\<^sub>C\<^bsub>poly R\<^esub> -\<^sub>C\<^bsub>poly R\<^esub> h) (long_division\<^sub>C R f'' g)"
+        using False unfolding 1(2)
+        by (subst long_division\<^sub>C.simps) (simp add:Let_def f''_def f'_def h_def \<alpha>_def k_def)
+
+      hence r_def: "r = (s +\<^sub>C\<^bsub>poly R\<^esub> -\<^sub>C\<^bsub>poly R\<^esub> h, t)"
+        unfolding st_def[symmetric] by simp
+
+      have "monic_poly (ring_of R) (X\<^bsub>ring_of R\<^esub> [^]\<^bsub>poly_ring (ring_of R)\<^esub> k)"
+        by (intro monic_poly_pow monic_poly_var)
+      hence [simp]: "lead_coeff (X\<^bsub>ring_of R\<^esub> [^]\<^bsub>poly_ring (ring_of R)\<^esub> k) = \<one>\<^bsub>ring_of R\<^esub>"
+        unfolding monic_poly_def by simp
+
+      have hd_f_unit: "hd f \<in> Units (ring_of R)" and hd_g_unit: "hd g \<in> Units (ring_of R)"
+        using f_carr g_carr lead_coeff_carr field_Units by auto
+      hence hd_f_carr: "hd f \<in> carrier (ring_of R)" and hd_g_carr: "hd g \<in> carrier (ring_of R)"
+        by auto
+
+      have k_def': "k = degree f - degree g" using False unfolding k_def by auto
+      have \<alpha>_def': "\<alpha> = \<ominus>\<^bsub>ring_of R\<^esub> (hd f \<otimes>\<^bsub>ring_of R\<^esub> inv\<^bsub>ring_of R\<^esub> hd g)"
+        unfolding \<alpha>_def using hd_g_unit hd_f_carr field_cD[OF assms(1)] by simp
+
+      have \<alpha>_unit: "\<alpha> \<in> Units (ring_of R)" unfolding \<alpha>_def' using hd_f_unit hd_g_unit
+        by (intro field_Unit_minus_closed) simp
+      hence \<alpha>_carr: "\<alpha> \<in> carrier (ring_of R) - {\<zero>\<^bsub>ring_of R\<^esub>}" unfolding field_Units by simp
+      hence \<alpha>_poly_carr: "[\<alpha>] \<in> carrier (poly_ring (ring_of R)) - {\<zero>\<^bsub>poly_ring (ring_of R)\<^esub>}"
+        by (simp add: univ_poly_carrier[symmetric] univ_poly_zero polynomial_def)
+
+      have h_def': "h = [\<alpha>] \<otimes>\<^bsub>?P\<^esub> X\<^bsub>ring_of R\<^esub> [^]\<^bsub>?P\<^esub> k"
+        unfolding h_def poly_var domain_cD[OF d_poly] by (simp add:ring_of_poly[OF ring_c])
+      have f'_def': "f' = f \<oplus>\<^bsub>?P\<^esub> (h \<otimes>\<^bsub>?P\<^esub> g)"
+        unfolding f'_def domain_cD[OF d_poly] by (simp add:ring_of_poly[OF ring_c])
+
+      have h_carr: "h \<in> carrier (poly_ring (ring_of R)) - {\<zero>\<^bsub>poly_ring (ring_of R)\<^esub>}"
+        using d_poly_ring.mult_of.m_closed \<alpha>_poly_carr var_pow_carr[OF carrier_is_subring]
+        unfolding h_def' by auto
+
+      have "degree f = k + degree g" using False unfolding k_def by linarith
+      also have "... = degree [\<alpha>] + degree (X\<^bsub>ring_of R\<^esub> [^]\<^bsub>?P\<^esub> k) + degree g"
+        unfolding var_pow_degree[OF carrier_is_subring] by simp
+      also have "... = degree h + degree g" unfolding h_def'
+        by (intro arg_cong2[where f="(+)"] degree_mult[symmetric]
+            carrier_is_subring \<alpha>_poly_carr var_pow_carr refl)
+      also have "... = degree (h \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g)"
+        by (intro degree_mult[symmetric] carrier_is_subring h_carr g_carr)
+      finally have deg_f: "degree f = degree (h \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g)" by simp
+
+      have f'_carr: "f' \<in> carrier (poly_ring (ring_of R))"
+        using f_carr h_carr g_carr unfolding f'_def' by auto
+
+      have "hd f = \<ominus>\<^bsub>ring_of R\<^esub> (\<alpha> \<otimes>\<^bsub>ring_of R\<^esub> lead_coeff g)"
+        using hd_g_unit hd_f_carr hd_g_carr \<alpha>_unit \<alpha>_carr unfolding \<alpha>_def'
+        by (simp add: m_assoc l_minus)
+      also have "... = \<ominus>\<^bsub>ring_of R\<^esub> (hd h \<otimes>\<^bsub>ring_of R\<^esub> hd g)"
+        using hd_f_carr \<alpha>_carr \<alpha>_poly_carr var_pow_carr[OF carrier_is_subring] unfolding h_def'
+        by (subst lead_coeff_mult) (simp_all add:algebra_simps)
+      also have "... = \<ominus>\<^bsub>ring_of R\<^esub> hd (h \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g)"
+        using h_carr g_carr by (subst lead_coeff_mult) auto
+      finally have "hd f = \<ominus>\<^bsub>ring_of R\<^esub> hd (h \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g)"
+        by simp
+      hence len_f': "length f' < length f" using deg_f h_carr g_carr d_poly_ring.integral
+        unfolding f'_def' by (intro poly_add_cancel_len f_carr) auto
+      hence f''_def': "f'' = f'" unfolding f''_def by simp
+
+      have "{fst (s,t),snd (s,t)} \<subseteq> carrier (poly_ring (ring_of R))"
+        using len_f' f''_def' f'_carr by (intro ind(2)[where x="f''"] st_def) auto
+      hence s_carr: "s \<in> carrier ?P" and t_carr: "t \<in> carrier ?P" by auto
+
+      have r_def': "r = (s \<ominus>\<^bsub>poly_ring (ring_of R)\<^esub> h, t)"
+        using h_carr domain_cD[OF d_poly] unfolding r_def a_minus_def
+        using ring_of_poly[OF ring_c,symmetric] by simp
+
+      have r_carr: "{fst r, snd r} \<subseteq> carrier (poly_ring (ring_of R))"
+        using s_carr t_carr h_carr unfolding r_def' by auto
+      have "f = f'' \<ominus>\<^bsub>?P\<^esub> h \<otimes>\<^bsub>?P\<^esub> g"
+        using h_carr g_carr f_carr unfolding f''_def' f'_def' by simp algebra
+      also have "... = (snd (s,t) \<oplus>\<^bsub>?P\<^esub> fst (s,t) \<otimes>\<^bsub>?P\<^esub> g) \<ominus>\<^bsub>?P\<^esub> h \<otimes>\<^bsub>?P\<^esub> g"
+        using f'_carr f''_def' len_f'
+        by (intro arg_cong2[where f="\<lambda>x y. x \<ominus>\<^bsub>?P\<^esub> y"] ind(1) st_def) auto
+      also have "... = t \<oplus>\<^bsub>?P\<^esub> (s \<ominus>\<^bsub>?P\<^esub> h) \<otimes>\<^bsub>?P\<^esub> g"
+        using s_carr t_carr h_carr g_carr by simp algebra
+      also have "... = snd r \<oplus>\<^bsub>poly_ring (ring_of R)\<^esub> fst r \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g"
+        unfolding r_def' by simp
+      finally have "f = snd r \<oplus>\<^bsub>poly_ring (ring_of R)\<^esub> fst r \<otimes>\<^bsub>poly_ring (ring_of R)\<^esub> g" by simp
+      thus ?thesis using r_carr by auto
+    qed
+  qed
+  hence result: "?result f r" "{fst r, snd r} \<subseteq> carrier (poly_ring (ring_of R))"
+    using r_def by auto
+  show ?thesis
+  proof (cases "g = []")
+    case True then show ?thesis by (simp add:long_division\<^sub>C.simps pmod_def pdiv_def)
+  next
+    case False
+    hence "snd r = [] \<or> degree (snd r) < degree g"
+      using long_division_c_length unfolding r_def
+      by (metis One_nat_def Suc_pred length_greater_0_conv not_less_eq)
+    moreover have "f = g \<otimes>\<^bsub>?P\<^esub> (fst r) \<oplus>\<^bsub>poly_ring (ring_of R)\<^esub> (snd r)"
+      using result(1,2) assms(2,3) by simp algebra
+    ultimately have "long_divides f g (fst r, snd r)"
+      using result(2) unfolding long_divides_def by (auto simp:mem_Times_iff)
+    hence "(fst r, snd r) = (pdiv f g, pmod f g)"
+      by (intro long_divisionI[OF carrier_is_subfield] False assms)
+    then show ?thesis unfolding r_def by simp
+  qed
+qed
+
+definition pdiv\<^sub>C :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "pdiv\<^sub>C R f g = fst (long_division\<^sub>C R f g)"
+
+lemma pdiv_c:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  shows "pdiv\<^sub>C R f g = ring.pdiv (ring_of R) f g"
+  unfolding pdiv\<^sub>C_def long_division_c[OF assms] by simp
+
+definition pmod\<^sub>C :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+  "pmod\<^sub>C R f g = snd (long_division\<^sub>C R f g)"
+
+lemma pmod_c:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  shows "pmod\<^sub>C R f g = ring.pmod (ring_of R) f g"
+  unfolding pmod\<^sub>C_def long_division_c[OF assms] by simp
+
+function ext_euclidean ::
+  "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list) \<times> 'a list"
+  where "ext_euclidean F f g = (
+    if f = [] \<or> g = [] then
+      ((1\<^sub>C\<^bsub>poly F\<^esub>, 1\<^sub>C\<^bsub>poly F\<^esub>),f +\<^sub>C\<^bsub>poly F\<^esub> g)
+    else (
+      let (p,q) = long_division\<^sub>C F f g;
+          ((u,v),r) = ext_euclidean F g q
+       in ((v,u +\<^sub>C\<^bsub>poly F\<^esub> (-\<^sub>C\<^bsub>poly F\<^esub> (p *\<^sub>C\<^bsub>poly F\<^esub> v))),r)))"
+  by pat_completeness auto
+
+termination
+  apply (relation "measure (\<lambda>(_, _, f). length f)")
+  subgoal by simp
+  by (metis case_prod_conv in_measure length_greater_0_conv long_division_c_length prod.sel(2))
+
+(* TODO MOVE *)
+lemma (in domain) pdivides_self:
+  assumes "x \<in> carrier (poly_ring R)"
+  shows "x pdivides x"
+proof -
+  interpret d:domain "poly_ring R" by (rule univ_poly_is_domain[OF carrier_is_subring])
+  show ?thesis
+    using assms unfolding pdivides_def
+    by (intro dividesI[where c="\<one>\<^bsub>poly_ring R\<^esub>"]) simp_all
+qed
+
+declare ext_euclidean.simps[simp del]
+
+lemma ext_euclidean:
+  assumes "field\<^sub>C R"
+  defines "P \<equiv> poly_ring (ring_of R)"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  defines "r \<equiv> ext_euclidean R f g"
+  shows "snd r = f \<otimes>\<^bsub>P\<^esub> (fst (fst r)) \<oplus>\<^bsub>P\<^esub> g \<otimes>\<^bsub>P\<^esub> (snd (fst r))" (is "?T1")
+    and "snd r pdivides\<^bsub>ring_of R\<^esub> f" (is "?T2") "snd r pdivides\<^bsub>ring_of R\<^esub> g" (is "?T3")
+    and "{snd r, fst (fst r), snd (fst r)} \<subseteq> carrier P" (is "?T4")
+    and "snd r = [] \<longrightarrow> f = [] \<and> g = []" (is "?T5")
+proof -
+  let ?P= "poly_ring (ring_of R)"
+
+  interpret field "ring_of R" using assms(1) unfolding field\<^sub>C_def by auto
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  have ring_c: "ring\<^sub>C R" using assms(1) unfolding field\<^sub>C_def domain\<^sub>C_def cring\<^sub>C_def by auto
+  have d_poly: "domain\<^sub>C (poly R)" using assms (1) unfolding field\<^sub>C_def by (intro poly_domain) auto
+
+  have pdiv_zero: "x pdivides\<^bsub>ring_of R\<^esub> \<zero>\<^bsub>?P\<^esub>" if "x \<in> carrier ?P" for x
+    using that unfolding univ_poly_zero by (intro pdivides_zero[OF carrier_is_subring])
+
+  have "snd r = f \<otimes>\<^bsub>?P\<^esub> (fst (fst r)) \<oplus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> (snd (fst r)) \<and>
+    snd r pdivides\<^bsub>ring_of R\<^esub> f \<and> snd r pdivides\<^bsub>ring_of R\<^esub> g \<and>
+    {snd r, fst (fst r), snd (fst r)} \<subseteq> carrier ?P \<and>
+    (snd r = [] \<longrightarrow> f = [] \<and> g = [])"
+    if "r = ext_euclidean R f g" "{f,g} \<subseteq> carrier ?P"
+    using that
+  proof (induction "length g" arbitrary: f g r rule:nat_less_induct)
+    case 1
+    have ind:
+      "snd s = x \<otimes>\<^bsub>?P\<^esub> fst (fst s) \<oplus>\<^bsub>?P\<^esub> y \<otimes>\<^bsub>?P\<^esub> snd (fst s)"
+      "snd s pdivides\<^bsub>ring_of R\<^esub> x" "snd s pdivides\<^bsub>ring_of R\<^esub> y"
+      "{snd s, fst (fst s), snd (fst s)} \<subseteq> carrier ?P"
+      "(snd s = [] \<longrightarrow> x = [] \<and> y = [])"
+      if "length y < length g" "s = ext_euclidean R x y" "{x, y} \<subseteq> carrier ?P"
+      for x y s using that 1(1) by metis+
+    show ?case
+    proof (cases "f = [] \<or> g = []")
+      case True
+      hence r_def: "r = ((\<one>\<^bsub>?P\<^esub>, \<one>\<^bsub>?P\<^esub>), f \<oplus>\<^bsub>?P\<^esub> g)" unfolding 1(2)
+        by (simp add:ext_euclidean.simps domain_cD[OF d_poly] ring_of_poly[OF ring_c])
+
+      consider "f = \<zero>\<^bsub>?P\<^esub>" |  "g = \<zero>\<^bsub>?P\<^esub>"
+        using True unfolding univ_poly_zero by auto
+      hence "snd r pdivides\<^bsub>ring_of R\<^esub> f \<and> snd r pdivides\<^bsub>ring_of R\<^esub> g"
+        using 1(3) pdiv_zero pdivides_self unfolding r_def by cases auto
+      moreover have "snd r = f \<otimes>\<^bsub>?P\<^esub> fst (fst r) \<oplus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> snd (fst r)"
+        using 1(3) unfolding r_def by simp
+      moreover have "{snd r, fst (fst r), snd (fst r)} \<subseteq> carrier ?P"
+        using 1(3) unfolding r_def by auto
+      moreover have "snd r = [] \<longrightarrow> f = [] \<and> g = []"
+        using 1(3) True unfolding r_def by (auto simp:univ_poly_zero)
+      ultimately show ?thesis by (intro conjI) metis+
+    next
+      case False
+      obtain p q where pq_def: "(p,q) = long_division\<^sub>C R f g"
+        by (metis surj_pair)
+      obtain u v s where uvs_def: "((u,v),s) = ext_euclidean R g q"
+        by (metis surj_pair)
+
+      have "(p,q) = (pdiv f g, pmod f g)"
+        using 1(3) unfolding pq_def by (intro long_division_c[OF assms(1)]) auto
+      hence p_def: "p = pdiv f g" and q_def: "q = pmod f g" by auto
+      have p_carr: "p \<in> carrier ?P" and q_carr: "q \<in> carrier ?P"
+        using 1(3) long_division_closed[OF carrier_is_subfield] unfolding p_def q_def by auto
+
+      have "length g > 0" using False by auto
+      hence len_q: "length q < length g" using long_division_c_length pq_def by (metis snd_conv)
+      have s_eq: "s = g \<otimes>\<^bsub>?P\<^esub> u \<oplus>\<^bsub>?P\<^esub> q \<otimes>\<^bsub>?P\<^esub> v"
+        and s_div_g: "s pdivides\<^bsub>ring_of R\<^esub> g"
+        and s_div_q: "s pdivides\<^bsub>ring_of R\<^esub> q"
+        and suv_carr: "{s,u,v} \<subseteq> carrier ?P"
+        and s_zero_iff: "s = [] \<longrightarrow> g = [] \<and> q = []"
+        using ind[OF len_q uvs_def _] q_carr 1(3) by auto
+
+      have "r = ((v,u +\<^sub>C\<^bsub>poly R\<^esub> (-\<^sub>C\<^bsub>poly R\<^esub> (p *\<^sub>C\<^bsub>poly R\<^esub> v))),s)" unfolding 1(2) using False
+        by (subst ext_euclidean.simps) (simp add: pq_def[symmetric] uvs_def[symmetric])
+      also have "... = ((v, u \<ominus>\<^bsub>?P\<^esub> (p \<otimes>\<^bsub>?P\<^esub> v)), s)" using p_carr suv_carr domain_cD[OF d_poly]
+        unfolding a_minus_def ring_of_poly[OF ring_c] by (intro arg_cong2[where f="Pair"] refl) simp
+      finally have r_def: "r = ((v, u \<ominus>\<^bsub>?P\<^esub> (p \<otimes>\<^bsub>?P\<^esub> v)), s)" by simp
+
+      have "snd r = g \<otimes>\<^bsub>?P\<^esub> u \<oplus>\<^bsub>?P\<^esub> q \<otimes>\<^bsub>?P\<^esub> v" unfolding r_def s_eq by simp
+      also have "... = g \<otimes>\<^bsub>?P\<^esub> u \<oplus>\<^bsub>?P\<^esub> (f \<ominus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> p) \<otimes>\<^bsub>?P\<^esub> v"
+        using 1(3) p_carr q_carr suv_carr
+        by (subst pdiv_pmod[OF carrier_is_subfield, of "f" "g"])
+         (simp_all add:p_def[symmetric] q_def[symmetric], algebra)
+      also have "... = f \<otimes>\<^bsub>?P\<^esub> v \<oplus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> (u \<ominus>\<^bsub>?P\<^esub> ((p \<otimes>\<^bsub>?P\<^esub> v)))"
+        using 1(3) p_carr q_carr suv_carr  by simp algebra
+      finally have r1: "snd r = f \<otimes>\<^bsub>?P\<^esub> fst (fst r) \<oplus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> snd (fst r)"
+        unfolding r_def by simp
+      have "pmod f s = pmod (g \<otimes>\<^bsub>?P\<^esub> p \<oplus>\<^bsub>?P\<^esub> q) s" using 1(3)
+        by (subst pdiv_pmod[OF carrier_is_subfield, of "f" "g"])
+          (simp_all add:p_def[symmetric] q_def[symmetric])
+      also have "... = pmod (g \<otimes>\<^bsub>?P\<^esub> p) s \<oplus>\<^bsub>?P\<^esub> pmod q s"
+        using 1(3) p_carr q_carr suv_carr
+        by (subst long_division_add[OF carrier_is_subfield]) simp_all
+      also have "... = pmod (pmod g s \<otimes>\<^bsub>?P\<^esub> p) s \<oplus>\<^bsub>?P\<^esub> []"
+        using 1(3) p_carr q_carr suv_carr s_div_q
+        by (intro arg_cong2[where f="(\<oplus>\<^bsub>?P\<^esub>)"] pmod_mult_left)
+          (simp_all add: pmod_zero_iff_pdivides[OF carrier_is_subfield])
+      also have "... = pmod (\<zero>\<^bsub>?P\<^esub> \<otimes>\<^bsub>?P\<^esub> p) s \<oplus>\<^bsub>?P\<^esub> \<zero>\<^bsub>?P\<^esub>" unfolding univ_poly_zero
+        using 1(3) p_carr q_carr suv_carr s_div_g by (intro arg_cong2[where f="(\<oplus>\<^bsub>?P\<^esub>)"]
+            arg_cong2[where f="(\<otimes>\<^bsub>?P\<^esub>)"] arg_cong2[where f="pmod"])
+          (simp_all add: pmod_zero_iff_pdivides[OF carrier_is_subfield])
+      also have "... = pmod \<zero>\<^bsub>?P\<^esub> s"
+        using p_carr suv_carr long_division_closed[OF carrier_is_subfield] by simp
+      also have "... = []" unfolding univ_poly_zero
+        using suv_carr long_division_zero(2)[OF carrier_is_subfield] by simp
+      finally have "pmod f s = []" by simp
+      hence r2: "snd r pdivides\<^bsub>ring_of R\<^esub> f" using suv_carr 1(3)  unfolding r_def
+        by (subst pmod_zero_iff_pdivides[OF carrier_is_subfield,symmetric]) simp_all
+      have r3: "snd r pdivides\<^bsub>ring_of R\<^esub> g" unfolding r_def using s_div_g by auto
+      have r4: "{snd r, fst (fst r), snd (fst r)} \<subseteq> carrier ?P"
+        using suv_carr p_carr unfolding r_def by simp_all
+      have r5: "f = [] \<and> g = []" if "snd r = []"
+      proof -
+        have r5_a: "g = [] \<and> q = []" using that s_zero_iff unfolding r_def by simp
+        hence "pmod f [] = []" unfolding q_def by auto
+        hence "f = []" using pmod_def by simp
+        thus ?thesis using r5_a by auto
+      qed
+
+      show ?thesis using r1 r2 r3 r4 r5  by (intro conjI) metis+
+    qed
+  qed
+  thus ?T1 ?T2 ?T3 ?T4 ?T5 using assms by auto
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Finite_Fields_Preliminary_Results.thy b/thys/Finite_Fields/Finite_Fields_Preliminary_Results.thy
--- a/thys/Finite_Fields/Finite_Fields_Preliminary_Results.thy
+++ b/thys/Finite_Fields/Finite_Fields_Preliminary_Results.thy
@@ -1,1010 +1,1041 @@
 section \<open>Introduction\<close>
 
 text \<open>The following section starts with preliminary results. Section~\ref{sec:ring_char} introduces
 the characteristic of rings with the Frobenius endomorphism. Whenever it makes sense,
 the definitions and facts do not assume the finiteness of the fields or rings. For example the
-characteristic is defined over arbitrary rings (and also fields). 
+characteristic is defined over arbitrary rings (and also fields).
 
 While formal derivatives do exist for type-class based structures in
 \verb|HOL-Computational_Algebra|, as far as I can tell, they do not exist for the structure based
 polynomials in \verb|HOL-Algebra|. These are introduced in Section~\ref{sec:pderiv}.
 
 A cornerstone of the proof is the derivation of Gauss' formula for the number of monic irreducible
 polynomials over a finite field $R$ in Section~\ref{sec:card_irred}. The proof follows the
 derivation by Ireland and Rosen~\<^cite>\<open>\<open>\textsection 7\<close> in "ireland1982"\<close> closely, with the caveat that it
 does not assume that $R$ is a simple prime field, but that it is just a finite field.
-This works by adjusting a proof step with the information that the order of a finite field must be 
+This works by adjusting a proof step with the information that the order of a finite field must be
 of the form $p^n$, where $p$ is the characteristic of the field, derived in Section~\ref{sec:ring_char}.
 The final step relies on the M\"obius inversion theorem formalized by
 Eberl~\<^cite>\<open>"Dirichlet_Series-AFP"\<close>.\footnote{Thanks to Katharina Kreuzer for discovering that
 formalization.}
 
-With Gauss' formula it is possible to show the existence of the finite fields of order $p^n$ 
+With Gauss' formula it is possible to show the existence of the finite fields of order $p^n$
 where $p$ is a prime and $n > 0$. During the proof the fact that the polynomial $X^n - X$ splits
 in a field of order $n$ is also derived, which is necessary for the uniqueness result as well.
 
 The uniqueness proof is inspired by the derivation of the same result in
-Lidl and Niederreiter~\<^cite>\<open>"lidl1986"\<close>, but because of the already derived existence proof for 
+Lidl and Niederreiter~\<^cite>\<open>"lidl1986"\<close>, but because of the already derived existence proof for
 irreducible polynomials, it was possible to reduce its complexity.
 
 The classification consists of three theorems:
 \begin{itemize}
-\item \emph{Existence}: For each prime power $p^n$ there exists a finite field of that size. 
+\item \emph{Existence}: For each prime power $p^n$ there exists a finite field of that size.
   This is shown at the conclusion of Section~\ref{sec:card_irred}.
-\item \emph{Uniqueness}: Any two finite fields of the same size are isomorphic. 
+\item \emph{Uniqueness}: Any two finite fields of the same size are isomorphic.
   This is shown at the conclusion of Section~\ref{sec:uniqueness}.
-\item \emph{Completeness}: Any finite fields' size must be a prime power. 
+\item \emph{Completeness}: Any finite fields' size must be a prime power.
   This is shown at the conclusion of Section~\ref{sec:ring_char}.
 \end{itemize}
 \<close>
 
 section \<open>Preliminary Results\<close>
 
 theory Finite_Fields_Preliminary_Results
   imports "HOL-Algebra.Polynomial_Divisibility"
 begin
 
 subsection \<open>Summation in the discrete topology\<close>
 
 text \<open>The following lemmas transfer the corresponding result from the summation over finite sets
 to summation over functions which vanish outside of a finite set.\<close>
 
 lemma sum'_subtractf_nat:
   fixes f :: "'a \<Rightarrow> nat"
   assumes "finite {i \<in> A. f i \<noteq> 0}"
   assumes "\<And>i. i \<in> A \<Longrightarrow> g i \<le> f i"
   shows "sum' (\<lambda>i. f i - g i) A = sum' f A - sum' g A"
     (is "?lhs = ?rhs")
 proof -
   have c:"finite {i \<in> A. g i \<noteq> 0}"
     using assms(2)
-    by (intro finite_subset[OF _ assms(1)] subsetI, force) 
+    by (intro finite_subset[OF _ assms(1)] subsetI, force)
   let ?B = "{i \<in> A. f i \<noteq> 0 \<or> g i \<noteq> 0}"
 
   have b:"?B = {i \<in> A. f i \<noteq> 0} \<union> {i \<in> A. g i \<noteq> 0}"
     by (auto simp add:set_eq_iff)
   have a:"finite ?B"
     using assms(1) c by (subst b, simp)
   have "?lhs = sum' (\<lambda>i. f i - g i) ?B"
     by (intro sum.mono_neutral_cong_right', simp_all)
   also have "... = sum (\<lambda>i. f i - g i) ?B"
-    by (intro sum.eq_sum a) 
+    by (intro sum.eq_sum a)
   also have "... = sum f ?B - sum g ?B"
     using assms(2) by (subst sum_subtractf_nat, auto)
   also have "... = sum' f ?B - sum' g ?B"
     by (intro arg_cong2[where f="(-)"] sum.eq_sum[symmetric] a)
   also have "... = ?rhs"
     by (intro arg_cong2[where f="(-)"] sum.mono_neutral_cong_left')
       simp_all
   finally show ?thesis
     by simp
 qed
 
 lemma sum'_nat_eq_0_iff:
   fixes f :: "'a \<Rightarrow> nat"
   assumes "finite {i \<in> A. f i \<noteq> 0}"
   assumes "sum' f A = 0"
   shows "\<And>i. i \<in> A \<Longrightarrow> f i = 0"
 proof -
   let ?B = "{i \<in> A. f i \<noteq> 0}"
 
   have "sum f ?B = sum' f ?B"
     by (intro sum.eq_sum[symmetric] assms(1))
   also have "... = sum' f A"
     by (intro sum.non_neutral')
   also have "... = 0" using assms(2) by simp
   finally have a:"sum f ?B = 0" by simp
   have "\<And>i. i \<in> ?B \<Longrightarrow> f i = 0"
     using sum_nonneg_0[OF assms(1) _ a] by blast
   thus "\<And>i. i \<in> A \<Longrightarrow> f i = 0"
     by blast
 qed
 
 lemma sum'_eq_iff:
   fixes f :: "'a \<Rightarrow> nat"
   assumes "finite {i \<in> A. f i \<noteq> 0}"
   assumes "\<And>i. i \<in> A \<Longrightarrow> f i \<ge> g i"
   assumes "sum' f A \<le> sum' g A"
   shows "\<forall>i \<in> A. f i = g i"
 proof -
   have "{i \<in> A. g i \<noteq> 0} \<subseteq> {i \<in> A. f i \<noteq> 0}"
-    using assms(2) order_less_le_trans 
-    by (intro subsetI, auto) 
+    using assms(2) order_less_le_trans
+    by (intro subsetI, auto)
   hence a:"finite {i \<in> A. g i \<noteq> 0}"
     by (rule finite_subset, intro assms(1))
-  have " {i \<in> A. f i - g i \<noteq> 0} \<subseteq> {i \<in> A. f i \<noteq> 0}" 
+  have " {i \<in> A. f i - g i \<noteq> 0} \<subseteq> {i \<in> A. f i \<noteq> 0}"
     by (intro subsetI, simp_all)
-  hence b: "finite {i \<in> A. f i - g i \<noteq> 0}" 
+  hence b: "finite {i \<in> A. f i - g i \<noteq> 0}"
     by (rule finite_subset, intro assms(1))
   have "sum' (\<lambda>i. f i - g i) A = sum' f A - sum' g A"
-    using assms(1,2) a by (subst sum'_subtractf_nat, auto) 
+    using assms(1,2) a by (subst sum'_subtractf_nat, auto)
   also have "... = 0"
     using assms(3) by simp
   finally have "sum' (\<lambda>i. f i - g i) A = 0" by simp
   hence "\<And>i. i \<in> A \<Longrightarrow> f i - g i = 0"
     using sum'_nat_eq_0_iff[OF b] by simp
   thus ?thesis
     using assms(2) diff_is_0_eq' diffs0_imp_equal by blast
 qed
 
 subsection \<open>Polynomials\<close>
 
 text \<open>The embedding of the constant polynomials into the polynomials is injective:\<close>
 
 lemma (in ring) poly_of_const_inj:
   "inj poly_of_const"
 proof -
-  have "coeff (poly_of_const x) 0 = x" for x 
+  have "coeff (poly_of_const x) 0 = x" for x
     unfolding poly_of_const_def normalize_coeff[symmetric]
     by simp
   thus ?thesis by (metis injI)
 qed
 
 lemma (in domain) embed_hom:
   assumes "subring K R"
   shows "ring_hom_ring (K[X]) (poly_ring R) id"
 proof (rule ring_hom_ringI)
   show "ring (K[X])"
     using univ_poly_is_ring[OF assms(1)] by simp
   show "ring (poly_ring R)"
     using univ_poly_is_ring[OF carrier_is_subring] by simp
-  have "K \<subseteq> carrier R" 
+  have "K \<subseteq> carrier R"
     using subringE(1)[OF assms(1)] by simp
   thus "\<And>x. x \<in> carrier (K [X]) \<Longrightarrow> id x \<in> carrier (poly_ring R)"
     unfolding univ_poly_carrier[symmetric] polynomial_def by auto
-  show "id (x \<otimes>\<^bsub>K [X]\<^esub> y) = id x \<otimes>\<^bsub>poly_ring R\<^esub> id y" 
+  show "id (x \<otimes>\<^bsub>K [X]\<^esub> y) = id x \<otimes>\<^bsub>poly_ring R\<^esub> id y"
     if "x \<in> carrier (K [X])" "y \<in> carrier (K [X])" for x y
     unfolding univ_poly_mult by simp
   show "id (x \<oplus>\<^bsub>K [X]\<^esub> y) = id x \<oplus>\<^bsub>poly_ring R\<^esub> id y"
     if "x \<in> carrier (K [X])" "y \<in> carrier (K [X])" for x y
     unfolding univ_poly_add by simp
   show "id \<one>\<^bsub>K [X]\<^esub> = \<one>\<^bsub>poly_ring R\<^esub>"
     unfolding univ_poly_one by simp
 qed
 
 text \<open>The following are versions of the properties of the degrees of polynomials, that abstract
 over the definition of the polynomial ring structure. In the theories
 @{theory "HOL-Algebra.Polynomials"} and also @{theory "HOL-Algebra.Polynomial_Divisibility"}
 these abstract version are usually indicated with the suffix ``shell'', consider for example:
 @{thm [source] "domain.pdivides_iff_shell"}.\<close>
 
 lemma (in ring) degree_add_distinct:
-  assumes "subring K R" 
+  assumes "subring K R"
   assumes "f \<in> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   assumes "g \<in> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   assumes "degree f \<noteq> degree g"
   shows "degree (f \<oplus>\<^bsub>K[X]\<^esub> g) = max (degree f) (degree g)"
-  unfolding univ_poly_add using assms(2,3,4) 
+  unfolding univ_poly_add using assms(2,3,4)
   by (subst poly_add_degree_eq[OF assms(1)])
     (auto simp:univ_poly_carrier univ_poly_zero)
 
+lemma (in ring) degree_add:
+  "degree (f \<oplus>\<^bsub>K[X]\<^esub> g) \<le> max (degree f) (degree g)"
+  unfolding univ_poly_add by (intro poly_add_degree)
+
 lemma (in domain) degree_mult:
-  assumes "subring K R" 
+  assumes "subring K R"
   assumes "f \<in> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   assumes "g \<in> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   shows "degree (f \<otimes>\<^bsub>K[X]\<^esub> g) = degree f + degree g"
-  unfolding univ_poly_mult using assms(2,3) 
+  unfolding univ_poly_mult using assms(2,3)
   by (subst poly_mult_degree_eq[OF assms(1)])
     (auto simp:univ_poly_carrier univ_poly_zero)
 
 lemma (in ring) degree_one:
   "degree (\<one>\<^bsub>K[X]\<^esub>) = 0"
   unfolding univ_poly_one by simp
 
-lemma (in domain) pow_non_zero: 
+lemma (in domain) pow_non_zero:
   "x \<in> carrier R \<Longrightarrow> x \<noteq> \<zero> \<Longrightarrow> x [^] (n :: nat) \<noteq> \<zero>"
-  using integral by (induction n, auto) 
+  using integral by (induction n, auto)
 
 lemma (in domain) degree_pow:
-  assumes "subring K R" 
+  assumes "subring K R"
   assumes "f \<in> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   shows "degree (f [^]\<^bsub>K[X]\<^esub> n) = degree f * n"
 proof -
   interpret p:domain "K[X]"
     using univ_poly_is_domain[OF assms(1)] by simp
 
   show ?thesis
   proof (induction n)
     case 0
     then show ?case by (simp add:univ_poly_one)
   next
     case (Suc n)
     have "degree (f [^]\<^bsub>K [X]\<^esub> Suc n) = degree (f [^]\<^bsub>K [X]\<^esub> n \<otimes>\<^bsub>K[X]\<^esub> f)"
       by simp
     also have "... = degree (f [^]\<^bsub>K [X]\<^esub> n) + degree f"
       using p.pow_non_zero assms(2)
       by (subst degree_mult[OF assms(1)], auto)
     also have "... = degree f * Suc n"
       by (subst Suc, simp)
     finally show ?case by simp
   qed
 qed
 
 lemma (in ring) degree_var:
   "degree (X\<^bsub>R\<^esub>) = 1"
   unfolding var_def by simp
 
 lemma (in domain) var_carr:
   fixes n :: nat
   assumes "subring K R"
   shows "X\<^bsub>R\<^esub> \<in> carrier (K[X]) - {\<zero>\<^bsub>K [X]\<^esub>}"
 proof -
-  have "X\<^bsub>R\<^esub> \<in> carrier (K[X])" 
+  have "X\<^bsub>R\<^esub> \<in> carrier (K[X])"
     using var_closed[OF assms(1)] by simp
   moreover have "X \<noteq> \<zero>\<^bsub>K [X]\<^esub>"
     unfolding var_def univ_poly_zero by simp
   ultimately show ?thesis by simp
 qed
 
 lemma (in domain) var_pow_carr:
   fixes n :: nat
   assumes "subring K R"
   shows "X\<^bsub>R\<^esub> [^]\<^bsub>K [X]\<^esub> n \<in> carrier (K[X]) - {\<zero>\<^bsub>K [X]\<^esub>}"
 proof -
   interpret p:domain "K[X]"
     using univ_poly_is_domain[OF assms(1)] by simp
 
-  have "X\<^bsub>R\<^esub> [^]\<^bsub>K [X]\<^esub> n \<in> carrier (K[X])" 
+  have "X\<^bsub>R\<^esub> [^]\<^bsub>K [X]\<^esub> n \<in> carrier (K[X])"
     using var_pow_closed[OF assms(1)] by simp
   moreover have "X \<noteq> \<zero>\<^bsub>K [X]\<^esub>"
     unfolding var_def univ_poly_zero by simp
   hence "X\<^bsub>R\<^esub> [^]\<^bsub>K [X]\<^esub> n \<noteq> \<zero>\<^bsub>K [X]\<^esub>"
     using var_closed(1)[OF assms(1)]
     by (intro p.pow_non_zero, auto)
   ultimately show ?thesis by simp
 qed
 
 lemma (in domain) var_pow_degree:
   fixes n :: nat
   assumes "subring K R"
   shows "degree (X\<^bsub>R\<^esub> [^]\<^bsub>K [X]\<^esub> n) = n"
   using var_carr[OF assms(1)] degree_var
   by (subst degree_pow[OF assms(1)], auto)
 
 lemma (in domain) finprod_non_zero:
   assumes "finite A"
   assumes "f \<in> A \<rightarrow> carrier R - {\<zero>}"
   shows "(\<Otimes>i \<in> A. f i) \<in> carrier R - {\<zero>}"
   using assms
 proof (induction A rule:finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   have "finprod R f (insert x F) = f x \<otimes> finprod R f F"
     using insert by (subst finprod_insert, simp_all add:Pi_def)
   also have "... \<in> carrier R-{\<zero>}"
     using integral insert by auto
   finally show ?case by simp
 qed
 
 lemma (in domain) degree_prod:
   assumes "finite A"
-  assumes "subring K R" 
+  assumes "subring K R"
   assumes "f \<in> A \<rightarrow> carrier (K[X]) - {\<zero>\<^bsub>K[X]\<^esub>}"
   shows "degree (\<Otimes>\<^bsub>K[X]\<^esub>i \<in> A. f i) = (\<Sum>i \<in> A. degree (f i))"
   using assms
 proof -
   interpret p:domain "K[X]"
     using univ_poly_is_domain[OF assms(2)] by simp
 
   show ?thesis
     using assms(1,3)
   proof (induction A rule: finite_induct)
     case empty
     then show ?case by (simp add:univ_poly_one)
   next
     case (insert x F)
-    have "degree (finprod (K[X]) f (insert x F)) = 
+    have "degree (finprod (K[X]) f (insert x F)) =
       degree (f x \<otimes>\<^bsub>K[X]\<^esub> finprod (K[X]) f F)"
       using insert by (subst p.finprod_insert, auto)
     also have "... = degree (f x) + degree (finprod (K[X]) f F)"
       using insert p.finprod_non_zero[OF insert(1)]
-      by (subst degree_mult[OF assms(2)], simp_all) 
+      by (subst degree_mult[OF assms(2)], simp_all)
     also have "... = degree (f x) + (\<Sum>i \<in> F. degree (f i))"
-      using insert by (subst insert(3), auto) 
+      using insert by (subst insert(3), auto)
     also have "... = (\<Sum>i \<in> insert x F. degree (f i))"
       using insert by simp
     finally show ?case by simp
   qed
 qed
 
 lemma (in ring) coeff_add:
   assumes "subring K R"
   assumes "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
   shows "coeff (f \<oplus>\<^bsub>K[X]\<^esub> g) i = coeff f i \<oplus>\<^bsub>R\<^esub> coeff g i"
 proof -
   have a:"set f \<subseteq> carrier R"
-    using assms(1,2) univ_poly_carrier 
+    using assms(1,2) univ_poly_carrier
     using subringE(1)[OF assms(1)] polynomial_incl
     by blast
-  have b:"set g \<subseteq> carrier R" 
+  have b:"set g \<subseteq> carrier R"
     using assms(1,3) univ_poly_carrier
     using subringE(1)[OF assms(1)] polynomial_incl
     by blast
   show ?thesis
     unfolding univ_poly_add poly_add_coeff[OF a b] by simp
 qed
 
+
+lemma (in domain) coeff_a_inv:
+  assumes "subring K R"
+  assumes "f \<in> carrier (K[X])"
+  shows "coeff (\<ominus>\<^bsub>K[X]\<^esub> f) i = \<ominus> (coeff f i)" (is "?L = ?R")
+proof -
+  have "?L = coeff (map (a_inv R) f) i"
+    unfolding univ_poly_a_inv_def'[OF assms(1,2)] by simp
+  also have "... = ?R" by (induction f) auto
+  finally show ?thesis by simp
+qed
+
 text \<open>This is a version of geometric sums for commutative rings:\<close>
 
 lemma (in cring) geom:
   fixes q:: nat
   assumes [simp]: "a \<in> carrier R"
   shows "(a \<ominus> \<one>) \<otimes> (\<Oplus>i\<in>{..<q}. a [^] i) = (a [^] q \<ominus> \<one>)"
     (is "?lhs = ?rhs")
 proof -
   have [simp]: "a [^] i \<in> carrier R" for i :: nat
     by (intro nat_pow_closed assms)
   have [simp]: "\<ominus> \<one> \<otimes> x = \<ominus> x" if "x \<in> carrier R" for x
     using l_minus l_one one_closed that by presburger
 
   let ?cterm = "(\<Oplus>i\<in>{1..<q}. a [^] i)"
 
   have "?lhs = a \<otimes> (\<Oplus>i\<in>{..<q}. a [^] i)  \<ominus> (\<Oplus>i\<in>{..<q}. a [^] i)"
     unfolding a_minus_def by (subst l_distr, simp_all add:Pi_def)
   also have "... = (\<Oplus>i\<in>{..<q}. a \<otimes> a [^] i) \<ominus> (\<Oplus>i\<in>{..<q}. a [^] i)"
     by (subst finsum_rdistr, simp_all add:Pi_def)
   also have "... = (\<Oplus>i\<in>{..<q}. a [^] (Suc i)) \<ominus> (\<Oplus>i\<in>{..<q}. a [^] i)"
     by (subst nat_pow_Suc, simp_all add:m_comm)
   also have "... = (\<Oplus>i\<in>Suc ` {..<q}. a [^] i) \<ominus> (\<Oplus>i\<in>{..<q}. a [^] i)"
     by (subst finsum_reindex, simp_all)
-  also have "... = 
-    (\<Oplus>i\<in> insert q {1..<q}. a [^] i) \<ominus> 
+  also have "... =
+    (\<Oplus>i\<in> insert q {1..<q}. a [^] i) \<ominus>
     (\<Oplus>i\<in> insert 0 {1..<q}. a [^] i)"
   proof (cases "q > 0")
     case True
-    moreover have "Suc ` {..<q} = insert q {Suc 0..<q}" 
-      using True lessThan_atLeast0 by fastforce 
+    moreover have "Suc ` {..<q} = insert q {Suc 0..<q}"
+      using True lessThan_atLeast0 by fastforce
     moreover have "{..<q} = insert 0 {Suc 0..<q}"
-      using True by (auto simp add:set_eq_iff) 
-    ultimately show ?thesis 
+      using True by (auto simp add:set_eq_iff)
+    ultimately show ?thesis
       by (intro arg_cong2[where f="\<lambda>x y. x \<ominus> y"] finsum_cong)
         simp_all
   next
     case False
     then show ?thesis by (simp, algebra)
   qed
   also have "... = (a [^] q \<oplus> ?cterm) \<ominus> (\<one> \<oplus> ?cterm)"
     by simp
   also have "... = a [^] q \<oplus> ?cterm \<oplus> (\<ominus> \<one> \<oplus> \<ominus> ?cterm)"
     unfolding a_minus_def by (subst minus_add, simp_all)
   also have "... = a [^] q \<oplus> (?cterm \<oplus> (\<ominus> \<one> \<oplus> \<ominus> ?cterm))"
     by (subst a_assoc, simp_all)
   also have "... = a [^] q \<oplus> (?cterm \<oplus> (\<ominus> ?cterm \<oplus> \<ominus> \<one>))"
     by (subst a_comm[where x="\<ominus> \<one>"], simp_all)
   also have "... = a [^] q \<oplus> ((?cterm \<oplus> (\<ominus> ?cterm)) \<oplus> \<ominus> \<one>)"
     by (subst a_assoc, simp_all)
   also have "... = a [^] q \<oplus> (\<zero> \<oplus> \<ominus> \<one>)"
     by (subst r_neg, simp_all)
-  also have "... = a [^] q \<ominus> \<one>" 
+  also have "... = a [^] q \<ominus> \<one>"
     unfolding a_minus_def by simp
   finally show ?thesis by simp
 qed
 
 lemma (in domain) rupture_eq_0_iff:
   assumes "subfield K R" "p \<in> carrier (K[X])" "q \<in> carrier (K[X])"
   shows "rupture_surj K p q = \<zero>\<^bsub>Rupt K p\<^esub> \<longleftrightarrow> p pdivides q"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   interpret h:ring_hom_ring "K[X]" "(Rupt K p)" "(rupture_surj K p)"
     using assms subfieldE by (intro rupture_surj_hom) auto
 
-  have a: "q pmod p \<in> (\<lambda>q. q pmod p) ` carrier (K [X])" 
+  have a: "q pmod p \<in> (\<lambda>q. q pmod p) ` carrier (K [X])"
     using assms(3) by simp
-  have "\<zero>\<^bsub>K[X]\<^esub> = \<zero>\<^bsub>K[X]\<^esub> pmod p" 
+  have "\<zero>\<^bsub>K[X]\<^esub> = \<zero>\<^bsub>K[X]\<^esub> pmod p"
     using assms(1,2) long_division_zero(2)
     by (simp add:univ_poly_zero)
-  hence b: "\<zero>\<^bsub>K[X]\<^esub> \<in> (\<lambda>q. q pmod p) ` carrier (K[X])" 
+  hence b: "\<zero>\<^bsub>K[X]\<^esub> \<in> (\<lambda>q. q pmod p) ` carrier (K[X])"
     by (simp add:image_iff) auto
 
-  have "?lhs \<longleftrightarrow> rupture_surj K p (q pmod p) = 
-    rupture_surj K p (\<zero>\<^bsub>K[X]\<^esub>)" 
+  have "?lhs \<longleftrightarrow> rupture_surj K p (q pmod p) =
+    rupture_surj K p (\<zero>\<^bsub>K[X]\<^esub>)"
     by (subst rupture_surj_composed_with_pmod[OF assms]) simp
   also have "... \<longleftrightarrow> q pmod p = \<zero>\<^bsub>K[X]\<^esub>"
     using assms(3)
     by (intro inj_on_eq_iff[OF rupture_surj_inj_on[OF assms(1,2)]] a b)
   also have "... \<longleftrightarrow> ?rhs"
     unfolding univ_poly_zero
     by (intro pmod_zero_iff_pdivides[OF assms(1)] assms(2,3))
   finally show "?thesis" by simp
 qed
 
 subsection \<open>Ring Isomorphisms\<close>
 
 text \<open>The following lemma shows that an isomorphism between domains also induces an isomorphism
 between the corresponding polynomial rings.\<close>
 
 lemma lift_iso_to_poly_ring:
   assumes "h \<in> ring_iso R S" "domain R" "domain S"
   shows "map h \<in> ring_iso (poly_ring R) (poly_ring S)"
 proof (rule ring_iso_memI)
   interpret dr: domain "R" using assms(2) by blast
   interpret ds: domain "S" using assms(3) by blast
   interpret pdr: domain "poly_ring R"
     using dr.univ_poly_is_domain[OF dr.carrier_is_subring] by simp
   interpret pds: domain "poly_ring S"
     using ds.univ_poly_is_domain[OF ds.carrier_is_subring] by simp
   interpret h: ring_hom_ring "R" "S" h
     using dr.ring_axioms ds.ring_axioms assms(1)
     by (intro ring_hom_ringI2, simp_all add:ring_iso_def)
   let ?R = "poly_ring R"
   let ?S = "poly_ring S"
 
-  have h_img: "h ` (carrier R) = carrier S" 
+  have h_img: "h ` (carrier R) = carrier S"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
-  have h_inj: "inj_on h (carrier R)" 
+  have h_inj: "inj_on h (carrier R)"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
   hence h_non_zero_iff:  "h x \<noteq> \<zero>\<^bsub>S\<^esub>"
     if "x \<noteq> \<zero>\<^bsub>R\<^esub>" "x \<in> carrier R" for x
     using h.hom_zero dr.zero_closed inj_onD that by metis
 
-  have norm_elim: "ds.normalize (map h x) = map h x" 
-    if "x \<in> carrier (poly_ring R)" for x 
+  have norm_elim: "ds.normalize (map h x) = map h x"
+    if "x \<in> carrier (poly_ring R)" for x
   proof (cases "x")
     case Nil then show ?thesis by simp
   next
     case (Cons xh xt)
     have "xh \<in> carrier R" "xh \<noteq> \<zero>\<^bsub>R\<^esub>"
-      using that unfolding Cons univ_poly_carrier[symmetric] 
+      using that unfolding Cons univ_poly_carrier[symmetric]
       unfolding polynomial_def by auto
     hence "h xh \<noteq> \<zero>\<^bsub>S\<^esub>" using h_non_zero_iff by simp
     then show ?thesis unfolding Cons by simp
   qed
 
-  show t_1: "map h x \<in> carrier ?S" 
+  show t_1: "map h x \<in> carrier ?S"
     if "x \<in> carrier ?R" for x
     using that hd_in_set h_non_zero_iff hd_map
-    unfolding univ_poly_carrier[symmetric] polynomial_def 
+    unfolding univ_poly_carrier[symmetric] polynomial_def
     by (cases x, auto)
 
-  show "map h (x \<otimes>\<^bsub>?R\<^esub> y) = map h x \<otimes>\<^bsub>?S\<^esub> map h y" 
+  show "map h (x \<otimes>\<^bsub>?R\<^esub> y) = map h x \<otimes>\<^bsub>?S\<^esub> map h y"
     if "x \<in> carrier ?R" "y \<in> carrier ?R" for x y
   proof -
     have "map h (x \<otimes>\<^bsub>?R\<^esub> y) = ds.normalize (map h (x \<otimes>\<^bsub>?R\<^esub> y))"
-      using that by (intro norm_elim[symmetric],simp) 
+      using that by (intro norm_elim[symmetric],simp)
     also have "... = map h x \<otimes>\<^bsub>?S\<^esub> map h y"
-      using that unfolding univ_poly_mult univ_poly_carrier[symmetric] 
+      using that unfolding univ_poly_mult univ_poly_carrier[symmetric]
       unfolding polynomial_def
       by (intro h.poly_mult_hom'[of x y] , auto)
     finally show ?thesis by simp
   qed
 
   show "map h (x \<oplus>\<^bsub>?R\<^esub> y) = map h x \<oplus>\<^bsub>?S\<^esub> map h y"
     if "x \<in> carrier ?R" "y \<in> carrier ?R" for x y
   proof -
     have "map h (x \<oplus>\<^bsub>?R\<^esub> y) = ds.normalize (map h (x \<oplus>\<^bsub>?R\<^esub> y))"
-      using that by (intro norm_elim[symmetric],simp) 
+      using that by (intro norm_elim[symmetric],simp)
     also have "... = map h x \<oplus>\<^bsub>?S\<^esub> map h y"
       using that
-      unfolding univ_poly_add univ_poly_carrier[symmetric] 
+      unfolding univ_poly_add univ_poly_carrier[symmetric]
       unfolding polynomial_def
       by (intro h.poly_add_hom'[of x y], auto)
     finally show ?thesis by simp
   qed
 
-  show "map h \<one>\<^bsub>?R\<^esub> = \<one>\<^bsub>?S\<^esub>" 
+  show "map h \<one>\<^bsub>?R\<^esub> = \<one>\<^bsub>?S\<^esub>"
     unfolding univ_poly_one by simp
 
   let ?hinv = "map (the_inv_into (carrier R) h)"
 
-  have "map h \<in> carrier ?R \<rightarrow> carrier ?S" 
+  have "map h \<in> carrier ?R \<rightarrow> carrier ?S"
     using t_1 by simp
-  moreover have "?hinv x \<in> carrier ?R" 
+  moreover have "?hinv x \<in> carrier ?R"
     if "x \<in> carrier ?S" for x
   proof (cases "x = []")
     case True
-    then show ?thesis 
+    then show ?thesis
       by (simp add:univ_poly_carrier[symmetric] polynomial_def)
   next
     case False
-    have set_x: "set x \<subseteq> h ` carrier R" 
+    have set_x: "set x \<subseteq> h ` carrier R"
       using that h_img unfolding univ_poly_carrier[symmetric]
       unfolding polynomial_def by auto
     have "lead_coeff x \<noteq> \<zero>\<^bsub>S\<^esub>" "lead_coeff x \<in> carrier S"
       using that False unfolding univ_poly_carrier[symmetric]
       unfolding polynomial_def by auto
-    hence "the_inv_into (carrier R) h (lead_coeff x) \<noteq> 
-      the_inv_into (carrier R) h \<zero>\<^bsub>S\<^esub>" 
-      using inj_on_the_inv_into[OF h_inj] inj_onD 
+    hence "the_inv_into (carrier R) h (lead_coeff x) \<noteq>
+      the_inv_into (carrier R) h \<zero>\<^bsub>S\<^esub>"
+      using inj_on_the_inv_into[OF h_inj] inj_onD
       using ds.zero_closed h_img by metis
-    hence "the_inv_into (carrier R) h (lead_coeff x) \<noteq> \<zero>\<^bsub>R\<^esub>" 
-      unfolding h.hom_zero[symmetric] 
+    hence "the_inv_into (carrier R) h (lead_coeff x) \<noteq> \<zero>\<^bsub>R\<^esub>"
+      unfolding h.hom_zero[symmetric]
       unfolding the_inv_into_f_f[OF h_inj dr.zero_closed] by simp
-    hence "lead_coeff (?hinv x) \<noteq> \<zero>\<^bsub>R\<^esub>" 
+    hence "lead_coeff (?hinv x) \<noteq> \<zero>\<^bsub>R\<^esub>"
       using False by (simp add:hd_map)
-    moreover have "the_inv_into (carrier R) h ` set x \<subseteq> carrier R" 
+    moreover have "the_inv_into (carrier R) h ` set x \<subseteq> carrier R"
       using the_inv_into_into[OF h_inj] set_x
       by (intro image_subsetI) auto
-    hence "set (?hinv x) \<subseteq> carrier R" by simp 
+    hence "set (?hinv x) \<subseteq> carrier R" by simp
     ultimately show ?thesis
       by (simp add:univ_poly_carrier[symmetric] polynomial_def)
   qed
-  moreover have "?hinv (map h x) = x" if "x \<in> carrier ?R" for x 
+  moreover have "?hinv (map h x) = x" if "x \<in> carrier ?R" for x
   proof -
-    have set_x: "set x \<subseteq> carrier R" 
+    have set_x: "set x \<subseteq> carrier R"
       using that unfolding univ_poly_carrier[symmetric]
       unfolding polynomial_def by auto
-    have "?hinv (map h x) = 
+    have "?hinv (map h x) =
       map (\<lambda>y. the_inv_into (carrier R) h (h y)) x"
       by simp
     also have "... = map id x"
       using set_x by (intro map_cong)
         (auto simp add:the_inv_into_f_f[OF h_inj])
     also have "... = x" by simp
     finally show ?thesis by simp
   qed
-  moreover have "map h (?hinv x) = x" 
+  moreover have "map h (?hinv x) = x"
     if "x \<in> carrier ?S" for x
   proof -
-    have set_x: "set x \<subseteq> h ` carrier R" 
+    have set_x: "set x \<subseteq> h ` carrier R"
       using that h_img unfolding univ_poly_carrier[symmetric]
       unfolding polynomial_def by auto
-    have "map h (?hinv x) = 
+    have "map h (?hinv x) =
       map (\<lambda>y. h (the_inv_into (carrier R) h y)) x"
       by simp
     also have "... = map id x"
       using set_x by (intro map_cong)
         (auto simp add:f_the_inv_into_f[OF h_inj])
     also have "... = x" by simp
     finally show ?thesis by simp
   qed
-  ultimately show "bij_betw (map h) (carrier ?R) (carrier ?S)" 
-    by (intro bij_betwI[where g="?hinv"], auto) 
+  ultimately show "bij_betw (map h) (carrier ?R) (carrier ?S)"
+    by (intro bij_betwI[where g="?hinv"], auto)
 qed
 
 lemma carrier_hom:
   assumes "f \<in> carrier (poly_ring R)"
   assumes "h \<in> ring_iso R S" "domain R" "domain S"
   shows "map h f \<in> carrier (poly_ring S)"
 proof -
-  note poly_iso = lift_iso_to_poly_ring[OF assms(2,3,4)] 
+  note poly_iso = lift_iso_to_poly_ring[OF assms(2,3,4)]
   show ?thesis
     using ring_iso_memE(1)[OF poly_iso assms(1)] by simp
 qed
 
 lemma carrier_hom':
   assumes "f \<in> carrier (poly_ring R)"
   assumes "h \<in> ring_hom R S"
-  assumes "domain R" "domain S" 
+  assumes "domain R" "domain S"
   assumes "inj_on h (carrier R)"
   shows "map h f \<in> carrier (poly_ring S)"
 proof -
   let ?S = "S \<lparr> carrier := h ` carrier R \<rparr>"
 
   interpret dr: domain "R" using assms(3) by blast
   interpret ds: domain "S" using assms(4) by blast
   interpret h1: ring_hom_ring R S h
-    using assms(2) ring_hom_ringI2 dr.ring_axioms 
-    using ds.ring_axioms by blast 
-  have subr: "subring (h ` carrier R) S" 
+    using assms(2) ring_hom_ringI2 dr.ring_axioms
+    using ds.ring_axioms by blast
+  have subr: "subring (h ` carrier R) S"
     using h1.img_is_subring[OF dr.carrier_is_subring] by blast
   interpret h: ring_hom_ring "((h ` carrier R)[X]\<^bsub>S\<^esub>)" "poly_ring S" "id"
     using ds.embed_hom[OF subr] by simp
 
   let ?S = "S \<lparr> carrier := h ` carrier R \<rparr>"
   have "h \<in> ring_hom R ?S"
     using assms(2) unfolding ring_hom_def by simp
   moreover have "bij_betw h (carrier R) (carrier ?S)"
     using assms(5) bij_betw_def by auto
   ultimately have h_iso: "h \<in> ring_iso R ?S"
     unfolding ring_iso_def by simp
 
-  have dom_S: "domain ?S" 
+  have dom_S: "domain ?S"
     using ds.subring_is_domain[OF subr] by simp
 
   note poly_iso = lift_iso_to_poly_ring[OF h_iso assms(3) dom_S]
   have "map h f \<in> carrier (poly_ring ?S)"
     using ring_iso_memE(1)[OF poly_iso assms(1)] by simp
-  also have "carrier (poly_ring ?S) = 
+  also have "carrier (poly_ring ?S) =
     carrier (univ_poly S (h ` carrier R))"
     using ds.univ_poly_consistent[OF subr] by simp
   also have "... \<subseteq> carrier (poly_ring S)"
     using h.hom_closed by auto
   finally show ?thesis by simp
 qed
 
 text \<open>The following lemmas transfer properties like divisibility, irreducibility etc. between
 ring isomorphisms.\<close>
 
 lemma divides_hom:
-  assumes "h \<in> ring_iso R S" 
-  assumes "domain R" "domain S" 
+  assumes "h \<in> ring_iso R S"
+  assumes "domain R" "domain S"
   assumes "x \<in> carrier R" "y \<in> carrier R"
   shows "x divides\<^bsub>R\<^esub> y \<longleftrightarrow> (h x) divides\<^bsub>S\<^esub> (h y)"  (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   interpret dr: domain "R" using assms(2) by blast
   interpret ds: domain "S" using assms(3) by blast
   interpret pdr: domain "poly_ring R"
     using dr.univ_poly_is_domain[OF dr.carrier_is_subring] by simp
   interpret pds: domain "poly_ring S"
     using ds.univ_poly_is_domain[OF ds.carrier_is_subring] by simp
   interpret h: ring_hom_ring "R" "S" h
     using dr.ring_axioms ds.ring_axioms assms(1)
     by (intro ring_hom_ringI2, simp_all add:ring_iso_def)
 
-  have h_inj_on: "inj_on h (carrier R)" 
+  have h_inj_on: "inj_on h (carrier R)"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
-  have h_img: "h ` (carrier R) = carrier S" 
+  have h_img: "h ` (carrier R) = carrier S"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
 
   have "?lhs \<longleftrightarrow> (\<exists>c \<in> carrier R. y = x \<otimes>\<^bsub>R\<^esub> c)"
     unfolding factor_def by simp
   also have "... \<longleftrightarrow> (\<exists>c \<in> carrier R. h y = h x \<otimes>\<^bsub>S\<^esub> h c)"
     using assms(4,5) inj_onD[OF h_inj_on]
-    by (intro bex_cong, auto simp flip:h.hom_mult) 
+    by (intro bex_cong, auto simp flip:h.hom_mult)
   also have "... \<longleftrightarrow> (\<exists>c \<in> carrier S. h y = h x  \<otimes>\<^bsub>S\<^esub> c)"
     unfolding h_img[symmetric] by simp
-  also have "... \<longleftrightarrow> ?rhs" 
+  also have "... \<longleftrightarrow> ?rhs"
     unfolding factor_def by simp
   finally show ?thesis by simp
 qed
 
 lemma properfactor_hom:
-  assumes "h \<in> ring_iso R S" 
-  assumes "domain R" "domain S" 
+  assumes "h \<in> ring_iso R S"
+  assumes "domain R" "domain S"
   assumes "x \<in> carrier R" "b \<in> carrier R"
-  shows "properfactor R b x \<longleftrightarrow> properfactor S (h b) (h x)" 
+  shows "properfactor R b x \<longleftrightarrow> properfactor S (h b) (h x)"
   using divides_hom[OF assms(1,2,3)] assms(4,5)
   unfolding properfactor_def by simp
 
 lemma Units_hom:
-  assumes "h \<in> ring_iso R S" 
-  assumes "domain R" "domain S" 
+  assumes "h \<in> ring_iso R S"
+  assumes "domain R" "domain S"
   assumes "x \<in> carrier R"
   shows "x \<in> Units R \<longleftrightarrow>  h x \<in> Units S"
 proof -
 
   interpret dr: domain "R" using assms(2) by blast
   interpret ds: domain "S" using assms(3) by blast
   interpret pdr: domain "poly_ring R"
     using dr.univ_poly_is_domain[OF dr.carrier_is_subring] by simp
   interpret pds: domain "poly_ring S"
     using ds.univ_poly_is_domain[OF ds.carrier_is_subring] by simp
   interpret h: ring_hom_ring "R" "S" h
     using dr.ring_axioms ds.ring_axioms assms(1)
     by (intro ring_hom_ringI2, simp_all add:ring_iso_def)
 
-  have h_img: "h ` (carrier R) = carrier S" 
+  have h_img: "h ` (carrier R) = carrier S"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
 
-  have h_inj_on: "inj_on h (carrier R)" 
+  have h_inj_on: "inj_on h (carrier R)"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
 
   hence h_one_iff: "h x = \<one>\<^bsub>S\<^esub> \<longleftrightarrow> x = \<one>\<^bsub>R\<^esub>" if "x \<in> carrier R" for x
     using h.hom_one that by (metis dr.one_closed inj_onD)
 
-  have "x \<in> Units R \<longleftrightarrow> 
+  have "x \<in> Units R \<longleftrightarrow>
     (\<exists>y\<in>carrier R. x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub> \<and> y \<otimes>\<^bsub>R\<^esub> x = \<one>\<^bsub>R\<^esub>)"
     using assms unfolding Units_def by auto
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (\<exists>y\<in>carrier R. h x \<otimes>\<^bsub>S\<^esub> h y = h \<one>\<^bsub>R\<^esub> \<and> h y \<otimes>\<^bsub>S\<^esub> h x = h \<one>\<^bsub>R\<^esub>)"
     using h_one_iff assms by (intro bex_cong, simp_all flip:h.hom_mult)
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (\<exists>y\<in>carrier S. h x \<otimes>\<^bsub>S\<^esub> y = h \<one>\<^bsub>R\<^esub> \<and> y \<otimes>\<^bsub>S\<^esub> h x = \<one>\<^bsub>S\<^esub>)"
     unfolding h_img[symmetric] by simp
   also have "... \<longleftrightarrow> h x \<in> Units S"
     using assms h.hom_closed unfolding Units_def by auto
   finally show ?thesis by simp
 qed
 
 lemma irreducible_hom:
-  assumes "h \<in> ring_iso R S" 
-  assumes "domain R" "domain S" 
+  assumes "h \<in> ring_iso R S"
+  assumes "domain R" "domain S"
   assumes "x \<in> carrier R"
   shows "irreducible R x = irreducible S (h x)"
 proof -
-  have h_img: "h ` (carrier R) = carrier S" 
+  have h_img: "h ` (carrier R) = carrier S"
     using assms(1) unfolding ring_iso_def bij_betw_def by auto
 
-  have "irreducible R x \<longleftrightarrow> (x \<notin> Units R \<and> 
+  have "irreducible R x \<longleftrightarrow> (x \<notin> Units R \<and>
     (\<forall>b\<in>carrier R. properfactor R b x \<longrightarrow> b \<in> Units R))"
     unfolding Divisibility.irreducible_def by simp
-  also have "... \<longleftrightarrow> (x \<notin> Units R \<and> 
+  also have "... \<longleftrightarrow> (x \<notin> Units R \<and>
     (\<forall>b\<in>carrier R. properfactor S (h b) (h x) \<longrightarrow> b \<in> Units R))"
     using properfactor_hom[OF assms(1,2,3)] assms(4) by simp
-  also have "... \<longleftrightarrow> (h x \<notin> Units S \<and> 
+  also have "... \<longleftrightarrow> (h x \<notin> Units S \<and>
     (\<forall>b\<in>carrier R. properfactor S (h b) (h x) \<longrightarrow> h b \<in> Units S))"
     using assms(4) Units_hom[OF assms(1,2,3)] by simp
-  also have "...\<longleftrightarrow> (h x \<notin> Units S \<and> 
+  also have "...\<longleftrightarrow> (h x \<notin> Units S \<and>
     (\<forall>b\<in>h ` carrier R. properfactor S b (h x) \<longrightarrow> b \<in> Units S))"
     by simp
   also have "... \<longleftrightarrow> irreducible S (h x)"
     unfolding h_img Divisibility.irreducible_def by simp
   finally show ?thesis by simp
 qed
 
 lemma pirreducible_hom:
-  assumes "h \<in> ring_iso R S" 
+  assumes "h \<in> ring_iso R S"
   assumes "domain R" "domain S"
   assumes "f \<in> carrier (poly_ring R)"
-  shows "pirreducible\<^bsub>R\<^esub> (carrier R) f = 
-    pirreducible\<^bsub>S\<^esub> (carrier S) (map h f)" 
+  shows "pirreducible\<^bsub>R\<^esub> (carrier R) f =
+    pirreducible\<^bsub>S\<^esub> (carrier S) (map h f)"
     (is "?lhs = ?rhs")
 proof -
   note lift_iso = lift_iso_to_poly_ring[OF assms(1,2,3)]
   interpret dr: domain "R" using assms(2) by blast
   interpret ds: domain "S" using assms(3) by blast
   interpret pdr: domain "poly_ring R"
     using dr.univ_poly_is_domain[OF dr.carrier_is_subring] by simp
   interpret pds: domain "poly_ring S"
     using ds.univ_poly_is_domain[OF ds.carrier_is_subring] by simp
 
-  have mh_inj_on: "inj_on (map h) (carrier (poly_ring R))" 
+  have mh_inj_on: "inj_on (map h) (carrier (poly_ring R))"
     using lift_iso unfolding ring_iso_def bij_betw_def by auto
   moreover have "map h \<zero>\<^bsub>poly_ring R\<^esub> = \<zero>\<^bsub>poly_ring S\<^esub>"
     by (simp add:univ_poly_zero)
-  ultimately have mh_zero_iff: 
+  ultimately have mh_zero_iff:
     "map h f = \<zero>\<^bsub>poly_ring S\<^esub> \<longleftrightarrow> f = \<zero>\<^bsub>poly_ring R\<^esub>"
     using assms(4) by (metis pdr.zero_closed inj_onD)
 
   have "?lhs \<longleftrightarrow> (f \<noteq> \<zero>\<^bsub>poly_ring R\<^esub> \<and> irreducible (poly_ring R) f)"
     unfolding ring_irreducible_def by simp
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (f \<noteq> \<zero>\<^bsub>poly_ring R\<^esub> \<and> irreducible (poly_ring S) (map h f))"
     using irreducible_hom[OF lift_iso] pdr.domain_axioms
     using assms(4) pds.domain_axioms by simp
-  also have "... \<longleftrightarrow> 
+  also have "... \<longleftrightarrow>
     (map h f \<noteq> \<zero>\<^bsub>poly_ring S\<^esub> \<and> irreducible (poly_ring S) (map h f))"
     using mh_zero_iff by simp
   also have "... \<longleftrightarrow> ?rhs"
     unfolding ring_irreducible_def by simp
   finally show ?thesis by simp
 qed
 
-
 lemma ring_hom_cong:
-  assumes "\<And>x. x \<in> carrier R \<Longrightarrow> f' x = f x" 
+  assumes "\<And>x. x \<in> carrier R \<Longrightarrow> f' x = f x"
   assumes "ring R"
   assumes "f \<in> ring_hom R S"
   shows "f' \<in> ring_hom R S"
 proof -
   interpret ring "R" using assms(2) by simp
-  show ?thesis 
+  show ?thesis
     using assms(1) ring_hom_memE[OF assms(3)]
-    by (intro ring_hom_memI, auto) 
+    by (intro ring_hom_memI, auto)
 qed
 
 text \<open>The natural homomorphism between factor rings, where one ideal is a subset of the other.\<close>
 
-lemma (in ring) quot_quot_hom: 
+lemma (in ring) quot_quot_hom:
   assumes "ideal I R"
   assumes "ideal J R"
   assumes "I \<subseteq> J"
-  shows "(\<lambda>x. (J <+>\<^bsub>R\<^esub> x)) \<in> ring_hom (R Quot I) (R Quot J)"  
+  shows "(\<lambda>x. (J <+>\<^bsub>R\<^esub> x)) \<in> ring_hom (R Quot I) (R Quot J)"
 proof (rule ring_hom_memI)
   interpret ji: ideal J R
     using assms(2) by simp
   interpret ii: ideal I R
     using assms(1) by simp
 
   have a:"J <+>\<^bsub>R\<^esub> I = J"
     using assms(3) unfolding set_add_def set_mult_def by auto
 
   show "J <+>\<^bsub>R\<^esub> x \<in> carrier (R Quot J)"
     if "x \<in> carrier (R Quot I)" for x
   proof -
-    have " \<exists>y\<in>carrier R. x = I +> y" 
+    have " \<exists>y\<in>carrier R. x = I +> y"
       using that unfolding FactRing_def A_RCOSETS_def' by simp
     then obtain y where y_def: "y \<in> carrier R" "x = I +> y"
       by auto
     have "J <+>\<^bsub>R\<^esub> (I +> y) = (J <+>\<^bsub>R\<^esub> I) +> y"
       using y_def(1) by (subst a_setmult_rcos_assoc) auto
     also have "... = J +> y" using a by simp
     finally have "J <+>\<^bsub>R\<^esub> (I +> y) = J +> y" by simp
     thus ?thesis
-      using y_def unfolding FactRing_def A_RCOSETS_def' by auto 
+      using y_def unfolding FactRing_def A_RCOSETS_def' by auto
   qed
 
-  show "J <+>\<^bsub>R\<^esub> x \<otimes>\<^bsub>R Quot I\<^esub> y = 
+  show "J <+>\<^bsub>R\<^esub> x \<otimes>\<^bsub>R Quot I\<^esub> y =
     (J <+>\<^bsub>R\<^esub> x) \<otimes>\<^bsub>R Quot J\<^esub> (J <+>\<^bsub>R\<^esub> y)"
-    if "x \<in> carrier (R Quot I)" "y \<in> carrier (R Quot I)" 
+    if "x \<in> carrier (R Quot I)" "y \<in> carrier (R Quot I)"
     for x y
   proof -
-    have "\<exists>x1\<in>carrier R. x = I +> x1" "\<exists>y1\<in>carrier R. y = I +> y1" 
+    have "\<exists>x1\<in>carrier R. x = I +> x1" "\<exists>y1\<in>carrier R. y = I +> y1"
       using that unfolding FactRing_def A_RCOSETS_def' by auto
-    then obtain x1 y1 
+    then obtain x1 y1
       where x1_def: "x1 \<in> carrier R" "x = I +> x1"
         and y1_def: "y1 \<in> carrier R" "y = I +> y1"
       by auto
     have "J <+>\<^bsub>R\<^esub> x \<otimes>\<^bsub>R Quot I\<^esub> y = J <+>\<^bsub>R\<^esub> (I +> x1 \<otimes> y1)"
       using x1_def y1_def
       by (simp add: FactRing_def ii.rcoset_mult_add)
     also have "... = (J <+>\<^bsub>R\<^esub> I) +> x1 \<otimes> y1"
       using x1_def(1) y1_def(1)
       by (subst a_setmult_rcos_assoc) auto
     also have "... = J +> x1 \<otimes> y1"
       using a by simp
-    also have "... = [mod J:] (J +> x1) \<Otimes> (J +> y1)" 
+    also have "... = [mod J:] (J +> x1) \<Otimes> (J +> y1)"
       using x1_def(1) y1_def(1) by (subst ji.rcoset_mult_add, auto)
-    also have "... = 
-      [mod J:] ((J <+>\<^bsub>R\<^esub> I) +> x1) \<Otimes> ((J <+>\<^bsub>R\<^esub> I) +> y1)" 
+    also have "... =
+      [mod J:] ((J <+>\<^bsub>R\<^esub> I) +> x1) \<Otimes> ((J <+>\<^bsub>R\<^esub> I) +> y1)"
       using a by simp
-    also have "... = 
+    also have "... =
       [mod J:] (J <+>\<^bsub>R\<^esub> (I +> x1)) \<Otimes> (J <+>\<^bsub>R\<^esub> (I +> y1))"
       using x1_def(1) y1_def(1)
       by (subst (1 2) a_setmult_rcos_assoc) auto
     also have "... = (J <+>\<^bsub>R\<^esub> x) \<otimes>\<^bsub>R Quot J\<^esub> (J <+>\<^bsub>R\<^esub> y)"
       using x1_def y1_def by (simp add: FactRing_def)
     finally show ?thesis by simp
   qed
 
-  show "J <+>\<^bsub>R\<^esub> x \<oplus>\<^bsub>R Quot I\<^esub> y = 
+  show "J <+>\<^bsub>R\<^esub> x \<oplus>\<^bsub>R Quot I\<^esub> y =
     (J <+>\<^bsub>R\<^esub> x) \<oplus>\<^bsub>R Quot J\<^esub> (J <+>\<^bsub>R\<^esub> y)"
     if "x \<in> carrier (R Quot I)" "y \<in> carrier (R Quot I)"
     for x y
   proof -
-    have "\<exists>x1\<in>carrier R. x = I +> x1" "\<exists>y1\<in>carrier R. y = I +> y1" 
+    have "\<exists>x1\<in>carrier R. x = I +> x1" "\<exists>y1\<in>carrier R. y = I +> y1"
       using that unfolding FactRing_def A_RCOSETS_def' by auto
-    then obtain x1 y1 
+    then obtain x1 y1
       where x1_def: "x1 \<in> carrier R" "x = I +> x1"
         and y1_def: "y1 \<in> carrier R" "y = I +> y1"
       by auto
-    have "J <+>\<^bsub>R\<^esub> x \<oplus>\<^bsub>R Quot I\<^esub> y = 
+    have "J <+>\<^bsub>R\<^esub> x \<oplus>\<^bsub>R Quot I\<^esub> y =
       J <+>\<^bsub>R\<^esub> ((I +> x1) <+>\<^bsub>R\<^esub> (I +> y1))"
       using x1_def y1_def by (simp add:FactRing_def)
     also have "... = J <+>\<^bsub>R\<^esub> (I +> (x1 \<oplus> y1))"
       using x1_def y1_def ii.a_rcos_sum by simp
     also have "... = (J <+>\<^bsub>R\<^esub> I) +> (x1 \<oplus> y1)"
       using x1_def y1_def by (subst a_setmult_rcos_assoc) auto
     also have "... = J +> (x1 \<oplus> y1)"
       using a by simp
-    also have "... = 
+    also have "... =
       ((J <+>\<^bsub>R\<^esub> I) +> x1) <+>\<^bsub>R\<^esub> ((J <+>\<^bsub>R\<^esub> I) +> y1)"
       using x1_def y1_def ji.a_rcos_sum a by simp
-    also have "... = 
-      J <+>\<^bsub>R\<^esub> (I +> x1) <+>\<^bsub>R\<^esub> (J <+>\<^bsub>R\<^esub> (I +> y1))" 
+    also have "... =
+      J <+>\<^bsub>R\<^esub> (I +> x1) <+>\<^bsub>R\<^esub> (J <+>\<^bsub>R\<^esub> (I +> y1))"
       using x1_def y1_def by (subst (1 2) a_setmult_rcos_assoc) auto
     also have "... = (J <+>\<^bsub>R\<^esub> x) \<oplus>\<^bsub>R Quot J\<^esub> (J <+>\<^bsub>R\<^esub> y)"
       using x1_def y1_def by (simp add:FactRing_def)
     finally show ?thesis by simp
   qed
 
   have "J <+>\<^bsub>R\<^esub> \<one>\<^bsub>R Quot I\<^esub> = J <+>\<^bsub>R\<^esub> (I +> \<one>)"
     unfolding FactRing_def by simp
-  also have "... = (J <+>\<^bsub>R\<^esub> I) +> \<one>" 
+  also have "... = (J <+>\<^bsub>R\<^esub> I) +> \<one>"
     by (subst a_setmult_rcos_assoc) auto
   also have "... = J +> \<one>" using a by simp
   also have "... = \<one>\<^bsub>R Quot J\<^esub>"
     unfolding FactRing_def by simp
-  finally show "J <+>\<^bsub>R\<^esub> \<one>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot J\<^esub>" 
+  finally show "J <+>\<^bsub>R\<^esub> \<one>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot J\<^esub>"
     by simp
 qed
 
 lemma (in ring) quot_carr:
   assumes "ideal I R"
   assumes "y \<in> carrier (R Quot I)"
   shows "y \<subseteq> carrier R"
 proof -
   interpret ideal I R using assms(1) by simp
   have "y \<in> a_rcosets I"
     using assms(2) unfolding FactRing_def by simp
   then obtain v where y_def: "y = I +> v" "v \<in> carrier R"
     unfolding A_RCOSETS_def' by auto
-  have "I +> v \<subseteq> carrier R" 
+  have "I +> v \<subseteq> carrier R"
     using y_def(2) a_r_coset_subset_G a_subset by presburger
   thus "y \<subseteq> carrier R" unfolding y_def by simp
 qed
 
 lemma (in ring) set_add_zero:
   assumes "A \<subseteq> carrier R"
   shows "{\<zero>} <+>\<^bsub>R\<^esub> A = A"
 proof -
   have "{\<zero>} <+>\<^bsub>R\<^esub> A = (\<Union>x\<in>A. {\<zero> \<oplus> x})"
     using assms unfolding set_add_def set_mult_def by simp
   also have "... = (\<Union>x\<in>A. {x})"
     using assms by (intro arg_cong[where f="Union"] image_cong, auto)
   also have "... = A" by simp
   finally show ?thesis by simp
 qed
 
 text \<open>Adapted from the proof of @{thm [source] domain.polynomial_rupture}\<close>
 
 lemma (in domain) rupture_surj_as_eval:
-  assumes "subring K R" 
+  assumes "subring K R"
   assumes "p \<in> carrier (K[X])" "q \<in> carrier (K[X])"
-  shows "rupture_surj K p q = 
-    ring.eval (Rupt K p) (map ((rupture_surj K p) \<circ> poly_of_const) q) 
+  shows "rupture_surj K p q =
+    ring.eval (Rupt K p) (map ((rupture_surj K p) \<circ> poly_of_const) q)
     (rupture_surj K p X)"
 proof -
   let ?surj = "rupture_surj K p"
 
   interpret UP: domain "K[X]"
     using univ_poly_is_domain[OF assms(1)] .
   interpret h: ring_hom_ring "K[X]" "Rupt K p" ?surj
     using rupture_surj_hom(2)[OF assms(1,2)] .
 
-  have "(h.S.eval) (map (?surj \<circ> poly_of_const) q) (?surj X) = 
+  have "(h.S.eval) (map (?surj \<circ> poly_of_const) q) (?surj X) =
     ?surj ((UP.eval) (map poly_of_const q) X)"
     using h.eval_hom[OF UP.carrier_is_subring var_closed(1)[OF assms(1)]
           map_norm_in_poly_ring_carrier[OF assms(1,3)]] by simp
   also have " ... = ?surj q"
     unfolding sym[OF eval_rewrite[OF assms(1,3)]] ..
   finally show ?thesis by simp
 qed
 
 subsection \<open>Divisibility\<close>
 
-lemma  (in field) f_comm_group_1:
+lemma (in field) f_comm_group_1:
   assumes "x \<in> carrier R" "y \<in> carrier R"
   assumes "x \<noteq> \<zero>" "y \<noteq> \<zero>"
   assumes "x \<otimes> y = \<zero>"
-  shows "False" 
+  shows "False"
   using integral assms by auto
 
 lemma (in field) f_comm_group_2:
   assumes "x \<in> carrier R"
   assumes "x \<noteq> \<zero>"
   shows " \<exists>y\<in>carrier R - {\<zero>}. y \<otimes> x = \<one>"
 proof -
   have x_unit: "x \<in> Units R" using field_Units assms by simp
   thus ?thesis unfolding Units_def by auto
 qed
 
 sublocale field < mult_of: comm_group "mult_of R"
   rewrites "mult (mult_of R) = mult R"
        and "one  (mult_of R) = one R"
   using f_comm_group_1 f_comm_group_2
   by (auto intro!:comm_groupI m_assoc m_comm)
 
 lemma (in domain) div_neg:
   assumes "a \<in> carrier R" "b \<in> carrier R"
   assumes "a divides b"
   shows "a divides (\<ominus> b)"
 proof -
   obtain r1 where r1_def: "r1 \<in> carrier R" "a \<otimes> r1 = b"
-    using assms by (auto simp:factor_def) 
+    using assms by (auto simp:factor_def)
 
   have "a \<otimes> (\<ominus> r1) = \<ominus> (a \<otimes> r1)"
     using assms(1) r1_def(1) by algebra
   also have "... = \<ominus> b"
     using r1_def(2) by simp
   finally have "\<ominus>b = a \<otimes> (\<ominus> r1)" by simp
   moreover have "\<ominus>r1 \<in> carrier R"
     using r1_def(1) by simp
   ultimately show ?thesis
-    by (auto simp:factor_def) 
+    by (auto simp:factor_def)
 qed
 
 lemma (in domain) div_sum:
   assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
   assumes "a divides b"
   assumes "a divides c"
   shows "a divides (b \<oplus> c)"
 proof -
   obtain r1 where r1_def: "r1 \<in> carrier R" "a \<otimes> r1 = b"
-    using assms by (auto simp:factor_def) 
+    using assms by (auto simp:factor_def)
 
   obtain r2 where r2_def: "r2 \<in> carrier R" "a \<otimes> r2 = c"
-    using assms by (auto simp:factor_def) 
+    using assms by (auto simp:factor_def)
 
   have "a \<otimes> (r1 \<oplus> r2) = (a \<otimes> r1) \<oplus> (a \<otimes> r2)"
     using assms(1) r1_def(1) r2_def(1) by algebra
   also have "... = b \<oplus> c"
     using r1_def(2) r2_def(2) by simp
   finally have "b \<oplus> c = a \<otimes> (r1 \<oplus> r2)" by simp
   moreover have "r1 \<oplus> r2 \<in> carrier R"
     using r1_def(1) r2_def(1) by simp
   ultimately show ?thesis
-    by (auto simp:factor_def) 
+    by (auto simp:factor_def)
 qed
 
 lemma (in domain) div_sum_iff:
   assumes "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
   assumes "a divides b"
   shows "a divides (b \<oplus> c) \<longleftrightarrow> a divides c"
-proof 
+proof
   assume "a divides (b \<oplus> c)"
   moreover have "a divides (\<ominus> b)"
     using div_neg assms(1,2,4) by simp
   ultimately have "a divides ((b \<oplus> c) \<oplus> (\<ominus> b))"
     using div_sum assms by simp
   also have "... = c" using assms(1,2,3) by algebra
   finally show "a divides c" by simp
 next
   assume "a divides c"
   thus "a divides (b \<oplus> c)"
     using assms by (intro div_sum) auto
 qed
 
+lemma (in comm_monoid) irreducible_prod_unit:
+  assumes "f \<in> carrier G"  "x \<in> Units G"
+  shows "irreducible G f = irreducible G (x \<otimes> f)" (is "?L = ?R")
+proof
+  assume "?L"
+  thus ?R using irreducible_prod_lI assms by auto
+next
+  have "inv x \<otimes> (x \<otimes> f)  = (inv x  \<otimes> x) \<otimes> f"
+    using assms by (intro m_assoc[symmetric]) auto
+  also have "... = f" using assms by simp
+  finally have 0: "inv x \<otimes> (x \<otimes> f) = f" by simp
+  assume ?R
+  hence "irreducible G (inv x \<otimes> (x \<otimes> f) )" using irreducible_prod_lI assms by blast
+  thus ?L using 0 by simp
+qed
+
 end
diff --git a/thys/Finite_Fields/Formal_Polynomial_Derivatives.thy b/thys/Finite_Fields/Formal_Polynomial_Derivatives.thy
--- a/thys/Finite_Fields/Formal_Polynomial_Derivatives.thy
+++ b/thys/Finite_Fields/Formal_Polynomial_Derivatives.thy
@@ -1,414 +1,414 @@
 section \<open>Formal Derivatives\label{sec:pderiv}\<close>
 
 theory Formal_Polynomial_Derivatives
   imports "HOL-Algebra.Polynomial_Divisibility" "Ring_Characteristic"
 begin
 
-definition pderiv ("pderiv\<index>") where 
+definition pderiv ("pderiv\<index>") where
   "pderiv\<^bsub>R\<^esub> x = ring.normalize R (
     map (\<lambda>i. int_embed R i \<otimes>\<^bsub>R\<^esub> ring.coeff R x i) (rev [1..<length x]))"
 
 context domain
 begin
 
 lemma coeff_range:
   assumes "subring K R"
   assumes "f \<in> carrier (K[X])"
   shows "coeff f i \<in> K"
 proof -
   have "coeff f i \<in> set f \<union> {\<zero>}"
     using coeff_img(3) by auto
   also have "... \<subseteq> K \<union> {\<zero>}"
     using assms(2) univ_poly_carrier polynomial_incl by blast
-  also have "... \<subseteq> K" 
+  also have "... \<subseteq> K"
     using subringE[OF assms(1)] by simp
   finally show ?thesis by simp
 qed
 
 lemma pderiv_carr:
   assumes "subring K R"
   assumes "f \<in> carrier (K[X])"
   shows "pderiv f \<in> carrier (K[X])"
 proof -
   have "int_embed R i \<otimes> coeff f i \<in> K" for i
-    using coeff_range[OF assms] int_embed_range[OF assms(1)] 
+    using coeff_range[OF assms] int_embed_range[OF assms(1)]
     using subringE[OF assms(1)] by simp
   hence "polynomial K (pderiv f)"
     unfolding pderiv_def by (intro normalize_gives_polynomial, auto)
   thus ?thesis
     using univ_poly_carrier by auto
 qed
 
 lemma pderiv_coeff:
   assumes "subring K R"
   assumes "f \<in> carrier (K[X])"
   shows "coeff (pderiv f) k = int_embed R (Suc k) \<otimes> coeff f (Suc k)"
     (is "?lhs = ?rhs")
 proof (cases "k + 1  < length f")
   case True
   define j where "j = length f - k - 2"
-  define d where 
+  define d where
     "d = map (\<lambda>i. int_embed R i \<otimes> coeff f i) (rev [1..<length f])"
 
   have a: "j+1 < length f"
     using True unfolding j_def by simp
   hence b: "j < length [1..<length f]"
     by simp
   have c: "k < length d"
     unfolding d_def using True by simp
   have d: "degree d - k = j"
     unfolding d_def j_def by simp
   have e: "rev [Suc 0..<length f] ! j = length f - 1 - j"
     using b  by (subst rev_nth, auto)
   have f: "length f - j - 1 = k+1"
     unfolding j_def using True by simp
 
   have "coeff (pderiv f ) k = coeff (normalize d) k"
     unfolding pderiv_def d_def by simp
   also have "... = coeff d k"
     using normalize_coeff by simp
   also have "... = d ! j"
     using c d by (subst coeff_nth, auto)
-  also have 
+  also have
     "... = int_embed R (length f - j - 1) \<otimes> coeff f (length f - j - 1)"
     using b e unfolding d_def by simp
   also have "... = ?rhs"
     using f by simp
   finally show ?thesis by simp
 next
   case False
   hence "Suc k \<ge> length f"
     by simp
   hence a:"coeff f (Suc k) = \<zero>"
     using coeff_img by blast
   have b:"coeff (pderiv f) k = \<zero>"
     unfolding pderiv_def normalize_coeff[symmetric] using False
     by (intro coeff_length, simp)
-  show ?thesis 
-    using int_embed_range[OF carrier_is_subring] by (simp add:a b) 
+  show ?thesis
+    using int_embed_range[OF carrier_is_subring] by (simp add:a b)
 qed
 
 lemma pderiv_const:
   assumes "degree x = 0"
   shows "pderiv x = \<zero>\<^bsub>K[X]\<^esub>"
 proof (cases "length x = 0")
   case True
   then show ?thesis by (simp add:univ_poly_zero pderiv_def)
 next
   case False
   hence "length x = 1" using assms by linarith
-  then obtain y where "x = [y]" by (cases x, auto) 
+  then obtain y where "x = [y]" by (cases x, auto)
   then show ?thesis by (simp add:univ_poly_zero pderiv_def)
 qed
 
 lemma pderiv_var:
   shows "pderiv X = \<one>\<^bsub>K[X]\<^esub>"
   unfolding var_def pderiv_def
   by (simp add:univ_poly_one int_embed_def)
 
 lemma pderiv_zero:
   shows "pderiv \<zero>\<^bsub>K[X]\<^esub> = \<zero>\<^bsub>K[X]\<^esub>"
   unfolding pderiv_def univ_poly_zero by simp
 
 lemma pderiv_add:
   assumes "subring K R"
   assumes [simp]: "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
   shows "pderiv (f \<oplus>\<^bsub>K[X]\<^esub> g) = pderiv f \<oplus>\<^bsub>K[X]\<^esub> pderiv g"
     (is "?lhs = ?rhs")
 proof -
   interpret p: ring "(K[X])"
     using univ_poly_is_ring[OF assms(1)] by simp
 
   let ?n = "(\<lambda>i. int_embed R i)"
 
   have a[simp]:"?n k \<in> carrier R" for k
     using int_embed_range[OF carrier_is_subring] by auto
   have b[simp]:"coeff f k \<in> carrier R" if "f \<in> carrier (K[X])" for k f
     using coeff_range[OF assms(1)] that
     using subringE(1)[OF assms(1)] by auto
 
   have "coeff ?lhs i = coeff ?rhs i" for i
   proof -
     have "coeff ?lhs i = ?n (i+1) \<otimes> coeff (f \<oplus>\<^bsub>K [X]\<^esub> g) (i+1)"
       by (simp add: pderiv_coeff[OF assms(1)])
     also have "... = ?n (i+1) \<otimes> (coeff f (i+1) \<oplus> coeff g (i+1))"
       by (subst coeff_add[OF assms], simp)
-    also have "... = ?n (i+1) \<otimes> coeff f (i+1) 
+    also have "... = ?n (i+1) \<otimes> coeff f (i+1)
       \<oplus> int_embed R (i+1) \<otimes> coeff g (i+1)"
       by (subst r_distr, simp_all)
     also have "... = coeff (pderiv f) i \<oplus> coeff (pderiv g) i"
       by (simp add: pderiv_coeff[OF assms(1)])
     also have "... = coeff (pderiv f \<oplus>\<^bsub>K [X]\<^esub> pderiv g) i"
-      using pderiv_carr[OF assms(1)] 
-      by (subst coeff_add[OF assms(1)], auto) 
+      using pderiv_carr[OF assms(1)]
+      by (subst coeff_add[OF assms(1)], auto)
     finally show ?thesis by simp
   qed
   hence "coeff ?lhs = coeff ?rhs" by auto
   thus "?lhs = ?rhs"
     using pderiv_carr[OF assms(1)]
     by (subst coeff_iff_polynomial_cond[where K="K"])
       (simp_all add:univ_poly_carrier)+
 qed
 
 lemma pderiv_inv:
   assumes "subring K R"
   assumes [simp]: "f \<in> carrier (K[X])"
   shows "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = \<ominus>\<^bsub>K[X]\<^esub> pderiv f" (is "?lhs = ?rhs")
 proof -
   interpret p: cring "(K[X])"
     using univ_poly_is_cring[OF assms(1)] by simp
 
   have "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> \<zero>\<^bsub>K[X]\<^esub>"
     using pderiv_carr[OF assms(1)]
     by (subst p.r_zero, simp_all)
-  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> (pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f)" 
+  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> (pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f)"
     using pderiv_carr[OF assms(1)] by simp
-  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f" 
+  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) \<oplus>\<^bsub>K[X]\<^esub> pderiv f \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     using pderiv_carr[OF assms(1)]
     unfolding a_minus_def by (simp add:p.a_assoc)
-  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub> f) \<ominus>\<^bsub>K[X]\<^esub> pderiv f" 
+  also have "... = pderiv (\<ominus>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub> f) \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     by (subst pderiv_add[OF assms(1)], simp_all)
   also have "... = pderiv \<zero>\<^bsub>K[X]\<^esub> \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     by (subst p.l_neg, simp_all)
   also have "... = \<zero>\<^bsub>K[X]\<^esub> \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     by (subst pderiv_zero, simp)
   also have "... = \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     unfolding a_minus_def using pderiv_carr[OF assms(1)]
     by (subst p.l_zero, simp_all)
   finally show "pderiv (\<ominus>\<^bsub>K[X]\<^esub> f) = \<ominus>\<^bsub>K[X]\<^esub> pderiv f"
     by simp
 qed
 
 
 lemma coeff_mult:
   assumes "subring K R"
   assumes "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
-  shows "coeff (f \<otimes>\<^bsub>K[X]\<^esub> g) i = 
+  shows "coeff (f \<otimes>\<^bsub>K[X]\<^esub> g) i =
     (\<Oplus> k \<in> {..i}. (coeff f) k \<otimes> (coeff g) (i - k))"
 proof -
   have a:"set f \<subseteq> carrier R"
-    using assms(1,2) univ_poly_carrier 
+    using assms(1,2) univ_poly_carrier
     using subringE(1)[OF assms(1)] polynomial_incl by blast
-  have b:"set g \<subseteq> carrier R" 
+  have b:"set g \<subseteq> carrier R"
     using assms(1,3) univ_poly_carrier
     using subringE(1)[OF assms(1)] polynomial_incl by blast
   show ?thesis
     unfolding univ_poly_mult poly_mult_coeff[OF a b] by simp
 qed
 
 lemma pderiv_mult:
   assumes "subring K R"
   assumes [simp]: "f \<in> carrier (K[X])" "g \<in> carrier (K[X])"
-  shows "pderiv (f \<otimes>\<^bsub>K[X]\<^esub> g) = 
-    pderiv f \<otimes>\<^bsub>K[X]\<^esub> g \<oplus>\<^bsub>K[X]\<^esub> f \<otimes>\<^bsub>K[X]\<^esub> pderiv g" 
+  shows "pderiv (f \<otimes>\<^bsub>K[X]\<^esub> g) =
+    pderiv f \<otimes>\<^bsub>K[X]\<^esub> g \<oplus>\<^bsub>K[X]\<^esub> f \<otimes>\<^bsub>K[X]\<^esub> pderiv g"
     (is "?lhs = ?rhs")
 proof -
   interpret p: cring "(K[X])"
     using univ_poly_is_cring[OF assms(1)] by simp
 
   let ?n = "(\<lambda>i. int_embed R i)"
 
-  have a[simp]:"?n k \<in> carrier R" for k 
+  have a[simp]:"?n k \<in> carrier R" for k
     using int_embed_range[OF carrier_is_subring] by auto
   have b[simp]:"coeff f k \<in> carrier R" if "f \<in> carrier (K[X])" for k f
-    using coeff_range[OF assms(1)] 
+    using coeff_range[OF assms(1)]
     using subringE(1)[OF assms(1)] that by auto
 
   have "coeff ?lhs i = coeff ?rhs i" for i
   proof -
     have "coeff ?lhs i = ?n (i+1) \<otimes> coeff (f \<otimes>\<^bsub>K [X]\<^esub> g) (i+1)"
       using assms(2,3) by (simp add: pderiv_coeff[OF assms(1)])
-    also have "... = ?n (i+1) \<otimes> 
+    also have "... = ?n (i+1) \<otimes>
       (\<Oplus>k \<in> {..i+1}. coeff f k \<otimes> (coeff g (i + 1 - k)))"
       by (subst coeff_mult[OF assms], simp)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> {..i+1}. ?n (i+1) \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)))"
-      by (intro finsum_rdistr, simp_all add:Pi_def) 
-    also have "... = 
+      by (intro finsum_rdistr, simp_all add:Pi_def)
+    also have "... =
       (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)) \<oplus>
-      ?n (i+1-k) \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)))" 
+      ?n (i+1-k) \<otimes> (coeff f k \<otimes> coeff g (i + 1 - k)))"
       using int_embed_add[symmetric] of_nat_diff
-      by (intro finsum_cong') 
-        (simp_all add:l_distr[symmetric] of_nat_diff) 
-    also have "... = 
+      by (intro finsum_cong')
+        (simp_all add:l_distr[symmetric] of_nat_diff)
+    also have "... =
       (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i + 1 - k) \<oplus>
-      coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i + 1 - k)))" 
+      coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i + 1 - k)))"
       using Pi_def a b m_assoc m_comm
       by (intro finsum_cong' arg_cong2[where f="(\<oplus>)"], simp_all)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> {..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
-      (\<Oplus>k \<in> {..i+1}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))" 
-      by (subst finsum_addf[symmetric], simp_all add:Pi_def) 
-    also have "... = 
+      (\<Oplus>k \<in> {..i+1}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
+      by (subst finsum_addf[symmetric], simp_all add:Pi_def)
+    also have "... =
       (\<Oplus>k\<in>insert 0 {1..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
-      (\<Oplus>k\<in>insert (i+1) {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))" 
+      (\<Oplus>k\<in>insert (i+1) {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
       using subringE(1)[OF assms(1)]
       by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong')
         (auto simp:set_eq_iff)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> {1..i+1}. ?n k \<otimes> coeff f k \<otimes> coeff g (i+1-k)) \<oplus>
-      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))" 
+      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
       by (subst (1 2) finsum_insert, auto simp add:int_embed_zero)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> Suc ` {..i}. ?n k \<otimes> coeff f (k) \<otimes> coeff g (i+1-k)) \<oplus>
-      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))" 
+      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
       by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong')
         (simp_all add:Pi_def atMost_atLeast0)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> {..i}. ?n (k+1) \<otimes> coeff f (k+1) \<otimes> coeff g (i-k)) \<oplus>
-      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))" 
+      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> (?n (i+1-k) \<otimes> coeff g (i+1-k)))"
       by (subst finsum_reindex, auto)
-    also have "... = 
+    also have "... =
       (\<Oplus>k \<in> {..i}. coeff (pderiv f) k \<otimes> coeff g (i-k)) \<oplus>
-      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> coeff (pderiv g) (i-k))" 
+      (\<Oplus>k \<in> {..i}. coeff f k \<otimes> coeff (pderiv g) (i-k))"
       using Suc_diff_le
-      by (subst (1 2) pderiv_coeff[OF assms(1)]) 
+      by (subst (1 2) pderiv_coeff[OF assms(1)])
         (auto intro!: finsum_cong')
-    also have "... = 
+    also have "... =
       coeff (pderiv f \<otimes>\<^bsub>K[X]\<^esub> g) i \<oplus> coeff (f \<otimes>\<^bsub>K[X]\<^esub> pderiv g) i"
       using pderiv_carr[OF assms(1)]
       by (subst (1 2) coeff_mult[OF assms(1)], auto)
-    also have "... = coeff ?rhs i" 
+    also have "... = coeff ?rhs i"
       using pderiv_carr[OF assms(1)]
       by (subst coeff_add[OF assms(1)], auto)
     finally show ?thesis by simp
   qed
 
   hence "coeff ?lhs = coeff ?rhs" by auto
   thus "?lhs = ?rhs"
     using pderiv_carr[OF assms(1)]
     by (subst coeff_iff_polynomial_cond[where K="K"])
      (simp_all add:univ_poly_carrier)
 qed
 
 lemma pderiv_pow:
   assumes "n > (0 :: nat)"
   assumes "subring K R"
   assumes [simp]: "f \<in> carrier (K[X])"
-  shows "pderiv (f [^]\<^bsub>K[X]\<^esub> n) = 
-    int_embed (K[X]) n \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> (n-1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f" 
+  shows "pderiv (f [^]\<^bsub>K[X]\<^esub> n) =
+    int_embed (K[X]) n \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> (n-1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
     (is "?lhs = ?rhs")
 proof -
   interpret p: cring "(K[X])"
     using univ_poly_is_cring[OF assms(2)] by simp
 
   let ?n = "\<lambda>n. int_embed (K[X]) n"
 
-  have [simp]: "?n i \<in> carrier (K[X])" for i 
+  have [simp]: "?n i \<in> carrier (K[X])" for i
     using p.int_embed_range[OF p.carrier_is_subring] by simp
 
   obtain m where n_def: "n = Suc m" using assms(1) lessE by blast
-  have "pderiv (f [^]\<^bsub>K[X]\<^esub> (m+1)) = 
-    ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> m \<otimes>\<^bsub>K[X]\<^esub> pderiv f" 
+  have "pderiv (f [^]\<^bsub>K[X]\<^esub> (m+1)) =
+    ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K[X]\<^esub> m \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
   proof (induction m)
     case 0
-    then show ?case 
-      using pderiv_carr[OF assms(2)] assms(3) 
+    then show ?case
+      using pderiv_carr[OF assms(2)] assms(3)
       using p.int_embed_one by simp
   next
     case (Suc m)
-    have "pderiv (f [^]\<^bsub>K [X]\<^esub> (Suc m + 1)) = 
+    have "pderiv (f [^]\<^bsub>K [X]\<^esub> (Suc m + 1)) =
       pderiv (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> f) "
       by simp
-    also have "... = 
-      pderiv (f [^]\<^bsub>K [X]\<^esub> (m+1)) \<otimes>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub> 
+    also have "... =
+      pderiv (f [^]\<^bsub>K [X]\<^esub> (m+1)) \<otimes>\<^bsub>K[X]\<^esub> f \<oplus>\<^bsub>K[X]\<^esub>
       f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
       using assms(3) by (subst pderiv_mult[OF assms(2)], auto)
-    also have "... = 
-      (?n (m+1) \<otimes>\<^bsub>K [X]\<^esub> f [^]\<^bsub>K [X]\<^esub> m \<otimes>\<^bsub>K [X]\<^esub> pderiv f) \<otimes>\<^bsub>K[X]\<^esub> f 
+    also have "... =
+      (?n (m+1) \<otimes>\<^bsub>K [X]\<^esub> f [^]\<^bsub>K [X]\<^esub> m \<otimes>\<^bsub>K [X]\<^esub> pderiv f) \<otimes>\<^bsub>K[X]\<^esub> f
       \<oplus>\<^bsub>K[X]\<^esub> f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f"
-      by (subst Suc(1), simp)  
-    also have 
-      "... = ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f) 
+      by (subst Suc(1), simp)
+    also have
+      "... = ?n (m+1) \<otimes>\<^bsub>K[X]\<^esub> (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f)
       \<oplus>\<^bsub>K[X]\<^esub> \<one>\<^bsub>K [X]\<^esub> \<otimes>\<^bsub>K[X]\<^esub> (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K[X]\<^esub> pderiv f)"
       using assms(3) pderiv_carr[OF assms(2)]
       apply (intro arg_cong2[where f="(\<oplus>\<^bsub>K[X]\<^esub>)"])
       apply (simp add:p.m_assoc)
        apply (simp add:p.m_comm)
       by simp
-    also have 
-      "... = (?n (m+1) \<oplus>\<^bsub>K[X]\<^esub> \<one>\<^bsub>K [X]\<^esub>) \<otimes>\<^bsub>K [X]\<^esub> 
+    also have
+      "... = (?n (m+1) \<oplus>\<^bsub>K[X]\<^esub> \<one>\<^bsub>K [X]\<^esub>) \<otimes>\<^bsub>K [X]\<^esub>
       (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K [X]\<^esub> pderiv f)"
-      using assms(3) pderiv_carr[OF assms(2)] 
+      using assms(3) pderiv_carr[OF assms(2)]
       by (subst p.l_distr[symmetric], simp_all)
-    also have "... = 
-      (\<one>\<^bsub>K [X]\<^esub> \<oplus>\<^bsub>K[X]\<^esub> ?n (m+1)) \<otimes>\<^bsub>K [X]\<^esub> 
+    also have "... =
+      (\<one>\<^bsub>K [X]\<^esub> \<oplus>\<^bsub>K[X]\<^esub> ?n (m+1)) \<otimes>\<^bsub>K [X]\<^esub>
       (f [^]\<^bsub>K [X]\<^esub> (m+1) \<otimes>\<^bsub>K [X]\<^esub> pderiv f)"
       using assms(3) pderiv_carr[OF assms(2)]
       by (subst p.a_comm, simp_all)
-    also have "... = ?n (1+ Suc m) 
+    also have "... = ?n (1+ Suc m)
       \<otimes>\<^bsub>K [X]\<^esub> f [^]\<^bsub>K [X]\<^esub> (Suc m) \<otimes>\<^bsub>K [X]\<^esub> pderiv f"
       using assms(3) pderiv_carr[OF assms(2)] of_nat_add
       apply (subst (2) of_nat_add, subst p.int_embed_add)
-      by (simp add:p.m_assoc p.int_embed_one) 
+      by (simp add:p.m_assoc p.int_embed_one)
     finally show ?case by simp
   qed
   thus "?thesis" using n_def by auto
 qed
 
 lemma pderiv_var_pow:
   assumes "n > (0::nat)"
   assumes "subring K R"
-  shows "pderiv (X [^]\<^bsub>K[X]\<^esub> n) = 
+  shows "pderiv (X [^]\<^bsub>K[X]\<^esub> n) =
     int_embed (K[X]) n \<otimes>\<^bsub>K[X]\<^esub> X [^]\<^bsub>K[X]\<^esub> (n-1)"
 proof -
   interpret p: cring "(K[X])"
     using univ_poly_is_cring[OF assms(2)] by simp
 
   have [simp]: "int_embed (K[X]) i \<in> carrier (K[X])" for i
     using p.int_embed_range[OF p.carrier_is_subring] by simp
 
   show ?thesis
-    using var_closed[OF assms(2)] 
+    using var_closed[OF assms(2)]
     using pderiv_var[where K="K"] pderiv_carr[OF assms(2)]
     by (subst pderiv_pow[OF assms(1,2)], simp_all)
 qed
 
 lemma int_embed_consistent_with_poly_of_const:
   assumes "subring K R"
   shows "int_embed (K[X]) m = poly_of_const (int_embed R m)"
 proof -
   define K' where "K' = R \<lparr> carrier := K \<rparr>"
   interpret p: cring "(K[X])"
     using univ_poly_is_cring[OF assms] by simp
   interpret d: domain "K'"
     unfolding K'_def
     using assms(1) subdomainI' subdomain_is_domain by simp
   interpret h: ring_hom_ring  "K'" "K[X]" "poly_of_const"
     unfolding K'_def
     using canonical_embedding_ring_hom[OF assms(1)] by simp
 
   define n where "n=nat (abs m)"
 
   have a1: "int_embed (K[X]) (int n) = poly_of_const (int_embed K' n)"
   proof (induction n)
     case 0
     then show ?case by (simp add:d.int_embed_zero p.int_embed_zero)
   next
     case (Suc n)
     then show ?case
       using d.int_embed_closed d.int_embed_add d.int_embed_one
       by (simp add:p.int_embed_add p.int_embed_one)
   qed
   also have "... = poly_of_const (int_embed R n)"
     unfolding K'_def using int_embed_consistent[OF assms] by simp
-  finally have a: 
+  finally have a:
     "int_embed (K[X]) (int n) = poly_of_const (int_embed R (int n))"
     by simp
 
-  have "int_embed (K[X]) (-(int n)) = 
+  have "int_embed (K[X]) (-(int n)) =
     poly_of_const (int_embed K' (- (int n)))"
     using d.int_embed_closed a1 by (simp add: p.int_embed_inv d.int_embed_inv)
   also have "... = poly_of_const (int_embed R (- (int n)))"
     unfolding K'_def using int_embed_consistent[OF assms] by simp
   finally have b:
     "int_embed (K[X]) (-int n) = poly_of_const (int_embed R (-int n))"
     by simp
 
   show ?thesis
     using a b n_def by (cases "m \<ge> 0", simp, simp)
 qed
 
 end
 
 end
diff --git a/thys/Finite_Fields/Monic_Polynomial_Factorization.thy b/thys/Finite_Fields/Monic_Polynomial_Factorization.thy
--- a/thys/Finite_Fields/Monic_Polynomial_Factorization.thy
+++ b/thys/Finite_Fields/Monic_Polynomial_Factorization.thy
@@ -1,658 +1,658 @@
 section \<open>Factorization into Monic Polynomials\label{sec:monic}\<close>
 
 theory Monic_Polynomial_Factorization
 imports
   Finite_Fields_Factorization_Ext
   Formal_Polynomial_Derivatives
 begin
 
 hide_const Factorial_Ring.multiplicity
 hide_const Factorial_Ring.irreducible
 
 lemma (in domain) finprod_mult_of:
   assumes "finite A"
   assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> carrier (mult_of R)"
   shows "finprod R f A = finprod (mult_of R) f A"
-  using assms by (induction A rule:finite_induct, auto) 
+  using assms by (induction A rule:finite_induct, auto)
 
 lemma (in ring) finite_poly:
   assumes "subring K R"
   assumes "finite K"
-  shows 
+  shows
     "finite {f. f \<in> carrier (K[X]) \<and> degree f = n}" (is "finite ?A")
     "finite {f. f \<in> carrier (K[X]) \<and> degree f \<le> n}" (is "finite ?B")
 proof -
   have "finite {f. set f \<subseteq> K \<and> length f \<le> n + 1}" (is "finite ?C")
     using assms(2) finite_lists_length_le by auto
   moreover have "?B \<subseteq> ?C"
-    by (intro subsetI) 
+    by (intro subsetI)
       (auto simp:univ_poly_carrier[symmetric] polynomial_def)
-  ultimately show a: "finite ?B" 
+  ultimately show a: "finite ?B"
     using finite_subset by auto
-  moreover have "?A \<subseteq> ?B" 
+  moreover have "?A \<subseteq> ?B"
     by (intro subsetI, simp)
   ultimately show "finite ?A"
     using finite_subset by auto
 qed
 
-definition pmult :: "_ \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat" ("pmult\<index>") 
-  where "pmult\<^bsub>R\<^esub> d p = multiplicity (mult_of (poly_ring R)) d p" 
+definition pmult :: "_ \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat" ("pmult\<index>")
+  where "pmult\<^bsub>R\<^esub> d p = multiplicity (mult_of (poly_ring R)) d p"
 
 definition monic_poly :: "_ \<Rightarrow> 'a list \<Rightarrow> bool"
-  where "monic_poly R f = 
+  where "monic_poly R f =
     (f \<noteq> [] \<and> lead_coeff f = \<one>\<^bsub>R\<^esub> \<and> f \<in> carrier (poly_ring R))"
 
 definition monic_irreducible_poly where
   "monic_irreducible_poly R f =
     (monic_poly R f \<and> pirreducible\<^bsub>R\<^esub> (carrier R) f)"
 
 abbreviation "m_i_p \<equiv> monic_irreducible_poly"
 
 locale polynomial_ring = field +
   fixes K
   assumes polynomial_ring_assms: "subfield K R"
 begin
 
 lemma K_subring: "subring K R"
   using polynomial_ring_assms subfieldE(1) by auto
 
 abbreviation P where "P \<equiv> K[X]"
 
 text \<open>This locale is used to specialize the following lemmas for a fixed coefficient ring.
 It can be introduced in a context as an intepretation to be able to use the following specialized
 lemmas. Because it is not (and should not) introduced as a sublocale it has no lasting effect
-for the field locale itself.\<close> 
+for the field locale itself.\<close>
 
 lemmas
     poly_mult_lead_coeff = poly_mult_lead_coeff[OF K_subring]
 and degree_add_distinct = degree_add_distinct[OF K_subring]
 and coeff_add = coeff_add[OF K_subring]
 and var_closed = var_closed[OF K_subring]
 and degree_prod = degree_prod[OF _ K_subring]
 and degree_pow = degree_pow[OF K_subring]
 and pirreducible_degree = pirreducible_degree[OF polynomial_ring_assms]
-and degree_one_imp_pirreducible = 
+and degree_one_imp_pirreducible =
     degree_one_imp_pirreducible[OF polynomial_ring_assms]
 and var_pow_closed = var_pow_closed[OF K_subring]
 and var_pow_carr = var_pow_carr[OF K_subring]
 and univ_poly_a_inv_degree = univ_poly_a_inv_degree[OF K_subring]
 and var_pow_degree = var_pow_degree[OF K_subring]
 and pdivides_zero = pdivides_zero[OF K_subring]
 and pdivides_imp_degree_le = pdivides_imp_degree_le[OF K_subring]
 and var_carr = var_carr[OF K_subring]
 and rupture_eq_0_iff = rupture_eq_0_iff[OF polynomial_ring_assms]
 and rupture_is_field_iff_pirreducible =
     rupture_is_field_iff_pirreducible[OF polynomial_ring_assms]
 and rupture_surj_hom = rupture_surj_hom[OF K_subring]
 and canonical_embedding_ring_hom =
     canonical_embedding_ring_hom[OF K_subring]
 and rupture_surj_norm_is_hom = rupture_surj_norm_is_hom[OF K_subring]
 and rupture_surj_as_eval = rupture_surj_as_eval[OF K_subring]
 and eval_cring_hom = eval_cring_hom[OF K_subring]
 and coeff_range = coeff_range[OF K_subring]
 and finite_poly = finite_poly[OF K_subring]
 and int_embed_consistent_with_poly_of_const =
     int_embed_consistent_with_poly_of_const[OF K_subring]
 and pderiv_var_pow = pderiv_var_pow[OF _ K_subring]
 and pderiv_add = pderiv_add[OF K_subring]
 and pderiv_inv = pderiv_inv[OF K_subring]
 and pderiv_mult = pderiv_mult[OF K_subring]
 and pderiv_pow = pderiv_pow[OF _ K_subring]
 and pderiv_carr = pderiv_carr[OF K_subring]
 
 sublocale p:principal_domain "poly_ring R"
   by (simp add: carrier_is_subfield univ_poly_is_principal)
 
 end
 
 context field
 begin
 
-interpretation polynomial_ring "R" "carrier R" 
+interpretation polynomial_ring "R" "carrier R"
   using carrier_is_subfield field_axioms
   by (simp add:polynomial_ring_def polynomial_ring_axioms_def)
 
-lemma pdivides_mult_r: 
-  assumes "a \<in> carrier (mult_of P)" 
-  assumes "b \<in> carrier (mult_of P)" 
+lemma pdivides_mult_r:
+  assumes "a \<in> carrier (mult_of P)"
+  assumes "b \<in> carrier (mult_of P)"
   assumes "c \<in> carrier (mult_of P)"
-  shows "a \<otimes>\<^bsub>P\<^esub> c pdivides b \<otimes>\<^bsub>P\<^esub> c \<longleftrightarrow> a pdivides b" 
+  shows "a \<otimes>\<^bsub>P\<^esub> c pdivides b \<otimes>\<^bsub>P\<^esub> c \<longleftrightarrow> a pdivides b"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   have a:"b \<otimes>\<^bsub>P\<^esub> c \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
     using assms p.mult_of.m_closed by force
   have b:"a \<otimes>\<^bsub>P\<^esub> c \<in> carrier P"
     using assms by simp
   have c:"b \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
     using assms p.mult_of.m_closed by force
   have d:"a \<in> carrier P" using assms by simp
   have "?lhs \<longleftrightarrow> a \<otimes>\<^bsub>P\<^esub> c divides\<^bsub>mult_of P\<^esub> b \<otimes>\<^bsub>P\<^esub> c"
     unfolding pdivides_def using p.divides_imp_divides_mult a b
     by (meson divides_mult_imp_divides)
   also have "... \<longleftrightarrow> a divides\<^bsub>mult_of P\<^esub> b"
     using p.mult_of.divides_mult_r[OF assms] by simp
   also have "... \<longleftrightarrow> ?rhs"
     unfolding pdivides_def using p.divides_imp_divides_mult c d
     by (meson divides_mult_imp_divides)
   finally show ?thesis by simp
 qed
 
 lemma lead_coeff_carr:
   assumes "x \<in> carrier (mult_of P)"
   shows "lead_coeff x \<in> carrier R - {\<zero>}"
 proof (cases x)
   case Nil
   then show ?thesis using assms by (simp add:univ_poly_zero)
 next
   case (Cons a list)
   hence a: "polynomial (carrier R) (a # list)"
     using assms univ_poly_carrier by auto
   have "lead_coeff x = a"
     using Cons by simp
   also have "a \<in> carrier R - {\<zero>}"
     using lead_coeff_not_zero a by simp
   finally show ?thesis by simp
 qed
 
 lemma lead_coeff_poly_of_const:
   assumes "r \<noteq> \<zero>"
   shows "lead_coeff (poly_of_const r) = r"
   using assms
   by (simp add:poly_of_const_def)
 
 lemma lead_coeff_mult:
   assumes "f \<in> carrier (mult_of P)"
   assumes "g \<in> carrier (mult_of P)"
   shows "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = lead_coeff f \<otimes> lead_coeff g"
-  unfolding univ_poly_mult using assms 
+  unfolding univ_poly_mult using assms
   using univ_poly_carrier[where R="R" and K="carrier R"]
   by (subst poly_mult_lead_coeff) (simp_all add:univ_poly_zero)
 
 lemma monic_poly_carr:
   assumes "monic_poly R f"
   shows "f \<in> carrier P"
   using assms unfolding monic_poly_def by simp
 
-lemma monic_poly_add_distinct: 
+lemma monic_poly_add_distinct:
   assumes "monic_poly R f"
   assumes "g \<in> carrier P" "degree g < degree f"
   shows "monic_poly R (f \<oplus>\<^bsub>P\<^esub> g)"
 proof (cases "g \<noteq> \<zero>\<^bsub>P\<^esub>")
   case True
   define n where "n = degree f"
   have "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
     using assms(1) univ_poly_zero
     unfolding monic_poly_def by auto
   hence "degree (f \<oplus>\<^bsub>P\<^esub> g) = max (degree f) (degree g)"
     using assms(2,3) True
     by (subst degree_add_distinct, simp_all)
   also have "... = degree f"
     using assms(3) by simp
   finally have b: "degree (f \<oplus>\<^bsub>P\<^esub> g) = n"
     unfolding n_def by simp
   moreover have "n > 0"
     using assms(3) unfolding n_def by simp
   ultimately have "degree (f \<oplus>\<^bsub>P\<^esub> g) \<noteq> degree ([])"
     by simp
   hence a:"f \<oplus>\<^bsub>P\<^esub> g \<noteq> []" by auto
 
   have "degree [] = 0" by simp
   also have  "... < degree f"
     using assms(3) by simp
   finally have "degree f \<noteq> degree []" by simp
   hence c: "f \<noteq> []" by auto
 
-  have d: "length g \<le> n" 
-    using  assms(3) unfolding n_def by simp 
+  have d: "length g \<le> n"
+    using  assms(3) unfolding n_def by simp
 
   have "lead_coeff (f \<oplus>\<^bsub>P\<^esub> g) = coeff (f \<oplus>\<^bsub>P\<^esub> g) n"
     using a b by (cases "f \<oplus>\<^bsub>P\<^esub> g", auto)
-  also have "... = coeff f n \<oplus> coeff g n" 
+  also have "... = coeff f n \<oplus> coeff g n"
     using monic_poly_carr assms
-    by (subst coeff_add, auto) 
+    by (subst coeff_add, auto)
   also have "... = lead_coeff f \<oplus> coeff g n"
     using c unfolding n_def by (cases "f", auto)
   also have "... = \<one> \<oplus> \<zero>"
-    using assms(1) unfolding monic_poly_def 
+    using assms(1) unfolding monic_poly_def
     unfolding subst coeff_length[OF d] by simp
   also have "... = \<one>"
     by simp
   finally have "lead_coeff (f \<oplus>\<^bsub>P\<^esub> g) = \<one>" by simp
   moreover have "f \<oplus>\<^bsub>P\<^esub> g \<in> carrier P"
     using monic_poly_carr assms by simp
   ultimately show  ?thesis
     using a  unfolding monic_poly_def by auto
 next
   case False
   then show ?thesis using assms monic_poly_carr by simp
 qed
 
 lemma monic_poly_one: "monic_poly R \<one>\<^bsub>P\<^esub>"
 proof -
   have "\<one>\<^bsub>P\<^esub> \<in> carrier P"
     by simp
   thus ?thesis
     by (simp add:univ_poly_one monic_poly_def)
 qed
 
 lemma monic_poly_var: "monic_poly R X"
 proof -
   have "X \<in> carrier P"
     using var_closed by simp
   thus ?thesis
     by (simp add:var_def monic_poly_def)
 qed
 
 lemma monic_poly_carr_2:
   assumes "monic_poly R f"
   shows "f \<in> carrier (mult_of P)"
   using assms unfolding monic_poly_def
   by (simp add:univ_poly_zero)
 
 lemma monic_poly_mult:
   assumes "monic_poly R f"
   assumes "monic_poly R g"
   shows "monic_poly R (f \<otimes>\<^bsub>P\<^esub> g)"
 proof -
   have "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = lead_coeff f \<otimes>\<^bsub>R\<^esub> lead_coeff g"
     using assms monic_poly_carr_2
     by (subst lead_coeff_mult) auto
   also have "... =  \<one>"
     using assms unfolding monic_poly_def by simp
   finally have "lead_coeff (f \<otimes>\<^bsub>P\<^esub> g) = \<one>\<^bsub>R\<^esub>" by simp
   moreover have "(f \<otimes>\<^bsub>P\<^esub> g) \<in> carrier (mult_of P)"
     using monic_poly_carr_2 assms by blast
   ultimately show ?thesis
     by (simp add:monic_poly_def univ_poly_zero)
 qed
 
 lemma monic_poly_pow:
   assumes "monic_poly R f"
   shows "monic_poly R (f [^]\<^bsub>P\<^esub> (n::nat))"
   using assms monic_poly_one monic_poly_mult
   by (induction n, auto)
 
 lemma monic_poly_prod:
   assumes "finite A"
   assumes "\<And>x. x \<in> A \<Longrightarrow> monic_poly R (f x)"
   shows "monic_poly R (finprod P f A)"
-  using assms 
+  using assms
 proof (induction A rule:finite_induct)
   case empty
   then show ?case by (simp add:monic_poly_one)
 next
   case (insert x F)
-  have a: "f \<in> F \<rightarrow> carrier P" 
+  have a: "f \<in> F \<rightarrow> carrier P"
     using insert monic_poly_carr by simp
-  have b: "f x \<in> carrier P" 
+  have b: "f x \<in> carrier P"
     using insert monic_poly_carr by simp
   have "monic_poly R (f x \<otimes>\<^bsub>P\<^esub> finprod P f F)"
     using insert by (intro monic_poly_mult) auto
   thus ?case
     using insert a b by (subst p.finprod_insert, auto)
 qed
 
 lemma monic_poly_not_assoc:
   assumes "monic_poly R f"
   assumes "monic_poly R g"
   assumes "f \<sim>\<^bsub>(mult_of P)\<^esub> g"
   shows "f = g"
 proof -
   obtain u where u_def: "f = g \<otimes>\<^bsub>P\<^esub> u" "u \<in> Units (mult_of P)"
     using p.mult_of.associatedD2 assms monic_poly_carr_2
     by blast
 
   hence "u \<in> Units P" by simp
   then obtain v where v_def: "u = [v]" "v \<noteq> \<zero>\<^bsub>R\<^esub>" "v \<in> carrier R"
     using univ_poly_carrier_units by auto
 
   have "\<one> = lead_coeff f"
     using assms(1) by (simp add:monic_poly_def)
   also have  "... = lead_coeff (g \<otimes>\<^bsub>P\<^esub> u)"
     by (simp add:u_def)
   also have "... = lead_coeff g \<otimes> lead_coeff u"
     using assms(2) monic_poly_carr_2 v_def u_def(2)
-    by (subst lead_coeff_mult, auto simp add:univ_poly_zero) 
+    by (subst lead_coeff_mult, auto simp add:univ_poly_zero)
   also have "... = lead_coeff g \<otimes> v"
     using v_def by simp
   also have "... = v"
     using assms(2) v_def(3) by (simp add:monic_poly_def)
   finally have "\<one> = v" by simp
-  hence "u = \<one>\<^bsub>P\<^esub>" 
+  hence "u = \<one>\<^bsub>P\<^esub>"
     using v_def by (simp add:univ_poly_one)
   thus "f = g"
     using u_def assms monic_poly_carr by simp
 qed
 
 lemma monic_poly_span:
   assumes "x \<in> carrier (mult_of P)" "irreducible (mult_of P) x"
   shows "\<exists>y. monic_irreducible_poly R y \<and> x \<sim>\<^bsub>(mult_of P)\<^esub> y"
 proof -
   define z where "z = poly_of_const (inv (lead_coeff x))"
   define y where "y = x \<otimes>\<^bsub>P\<^esub> z"
 
   have x_carr: "x \<in> carrier (mult_of P)" using assms by simp
 
-  hence lx_ne_0: "lead_coeff x \<noteq> \<zero>" 
-    and lx_unit: "lead_coeff x \<in> Units R" 
+  hence lx_ne_0: "lead_coeff x \<noteq> \<zero>"
+    and lx_unit: "lead_coeff x \<in> Units R"
     using lead_coeff_carr[OF x_carr] by (auto simp add:field_Units)
-  have lx_inv_ne_0: "inv (lead_coeff x) \<noteq> \<zero>"  
-    using lx_unit 
+  have lx_inv_ne_0: "inv (lead_coeff x) \<noteq> \<zero>"
+    using lx_unit
     by (metis Units_closed Units_r_inv r_null zero_not_one)
-  have lx_inv_carr: "inv (lead_coeff x) \<in> carrier R" 
+  have lx_inv_carr: "inv (lead_coeff x) \<in> carrier R"
     using lx_unit by simp
 
   have "z \<in> carrier P"
     using lx_inv_carr poly_of_const_over_carrier
     unfolding z_def by auto
-  moreover have "z \<noteq> \<zero>\<^bsub>P\<^esub>" 
+  moreover have "z \<noteq> \<zero>\<^bsub>P\<^esub>"
     using lx_inv_ne_0
     by (simp add:z_def poly_of_const_def univ_poly_zero)
   ultimately have z_carr: "z \<in> carrier (mult_of P)" by simp
   have z_unit: "z \<in> Units (mult_of P)"
     using lx_inv_ne_0 lx_inv_carr
     by (simp add:univ_poly_carrier_units z_def poly_of_const_def)
-  have y_exp: "y = x \<otimes>\<^bsub>(mult_of P)\<^esub> z" 
+  have y_exp: "y = x \<otimes>\<^bsub>(mult_of P)\<^esub> z"
     by (simp add:y_def)
-  hence y_carr: "y \<in> carrier (mult_of P)" 
+  hence y_carr: "y \<in> carrier (mult_of P)"
     using x_carr z_carr p.mult_of.m_closed by simp
 
   have "irreducible (mult_of P) y"
     unfolding y_def using assms z_unit z_carr
     by (intro p.mult_of.irreducible_prod_rI, auto)
-  moreover have "lead_coeff y = \<one>\<^bsub>R\<^esub>" 
+  moreover have "lead_coeff y = \<one>\<^bsub>R\<^esub>"
     unfolding y_def using x_carr z_carr lx_inv_ne_0 lx_unit
     by (simp add: lead_coeff_mult z_def lead_coeff_poly_of_const)
   hence "monic_poly R y"
     using y_carr unfolding monic_poly_def
-    by (simp add:univ_poly_zero) 
+    by (simp add:univ_poly_zero)
   ultimately have "monic_irreducible_poly R y"
     using p.irreducible_mult_imp_irreducible y_carr
     by (simp add:monic_irreducible_poly_def ring_irreducible_def)
-  moreover have "y \<sim>\<^bsub>(mult_of P)\<^esub> x" 
+  moreover have "y \<sim>\<^bsub>(mult_of P)\<^esub> x"
     by (intro p.mult_of.associatedI2[OF z_unit] y_def x_carr)
   hence "x \<sim>\<^bsub>(mult_of P)\<^esub> y"
     using x_carr y_carr by (simp add:p.mult_of.associated_sym)
   ultimately show ?thesis by auto
 qed
 
 lemma monic_polys_are_canonical_irreducibles:
   "canonical_irreducibles (mult_of P) {d. monic_irreducible_poly R d}"
   (is "canonical_irreducibles (mult_of P) ?S")
 proof -
-  have sp_1: 
-    "?S \<subseteq> {x \<in> carrier (mult_of P). irreducible (mult_of P) x}" 
+  have sp_1:
+    "?S \<subseteq> {x \<in> carrier (mult_of P). irreducible (mult_of P) x}"
     unfolding monic_irreducible_poly_def ring_irreducible_def
     using monic_poly_carr
-    by (intro subsetI, simp add: p.irreducible_imp_irreducible_mult) 
-  have sp_2: "x = y" 
-      if "x \<in> ?S" "y \<in> ?S" "x \<sim>\<^bsub>(mult_of P)\<^esub> y" for x y 
+    by (intro subsetI, simp add: p.irreducible_imp_irreducible_mult)
+  have sp_2: "x = y"
+      if "x \<in> ?S" "y \<in> ?S" "x \<sim>\<^bsub>(mult_of P)\<^esub> y" for x y
     using that monic_poly_not_assoc
     by (simp add:monic_irreducible_poly_def)
 
-  have sp_3: "\<exists>y \<in> ?S. x \<sim>\<^bsub>(mult_of P)\<^esub> y" 
+  have sp_3: "\<exists>y \<in> ?S. x \<sim>\<^bsub>(mult_of P)\<^esub> y"
     if "x \<in> carrier (mult_of P)" "irreducible (mult_of P) x" for x
     using that monic_poly_span by simp
 
   thus ?thesis using sp_1 sp_2 sp_3
     unfolding canonical_irreducibles_def by simp
 qed
 
 lemma
   assumes "monic_poly R a"
-  shows factor_monic_poly: 
-    "a = (\<Otimes>\<^bsub>P\<^esub>d\<in>{d. monic_irreducible_poly R d \<and> pmult d a > 0}. 
+  shows factor_monic_poly:
+    "a = (\<Otimes>\<^bsub>P\<^esub>d\<in>{d. monic_irreducible_poly R d \<and> pmult d a > 0}.
       d [^]\<^bsub>P\<^esub> pmult d a)" (is "?lhs = ?rhs")
-    and factor_monic_poly_fin: 
-      "finite {d. monic_irreducible_poly R d \<and> pmult d a > 0}" 
+    and factor_monic_poly_fin:
+      "finite {d. monic_irreducible_poly R d \<and> pmult d a > 0}"
 proof -
   let ?S = "{d. monic_irreducible_poly R d}"
   let ?T = "{d. monic_irreducible_poly R d \<and> pmult d a > 0}"
   let ?mip = "monic_irreducible_poly R"
 
-  have sp_4: "a \<in> carrier (mult_of P)" 
+  have sp_4: "a \<in> carrier (mult_of P)"
     using assms monic_poly_carr_2
     unfolding monic_irreducible_poly_def by simp
 
-  have b_1: "x \<in> carrier (mult_of P)" if "?mip x" for x 
+  have b_1: "x \<in> carrier (mult_of P)" if "?mip x" for x
     using that monic_poly_carr_2
     unfolding monic_irreducible_poly_def by simp
   have b_2:"irreducible (mult_of P) x" if "?mip x" for x
     using that
-    unfolding monic_irreducible_poly_def ring_irreducible_def 
+    unfolding monic_irreducible_poly_def ring_irreducible_def
     by (simp add: monic_poly_carr p.irreducible_imp_irreducible_mult)
   have b_3:"x \<in> carrier P" if "?mip x" for x
     using that monic_poly_carr
     unfolding monic_irreducible_poly_def
     by simp
 
-  have a_carr: "a \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" 
+  have a_carr: "a \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
     using sp_4 by simp
 
-  have "?T = {d. ?mip d \<and> multiplicity (mult_of P) d a > 0}" 
+  have "?T = {d. ?mip d \<and> multiplicity (mult_of P) d a > 0}"
     by (simp add:pmult_def)
   also have "... = {d \<in> ?S. multiplicity (mult_of P) d a > 0}"
     using p.mult_of.multiplicity_gt_0_iff[OF b_1 b_2 sp_4]
     by (intro order_antisym subsetI, auto)
   finally have t:"?T = {d \<in> ?S. multiplicity (mult_of P) d a > 0}"
     by simp
 
   show fin_T: "finite ?T"
     unfolding t
     using p.mult_of.split_factors(1)
       [OF monic_polys_are_canonical_irreducibles]
     using sp_4 by auto
 
   have a:"x [^]\<^bsub>P\<^esub> (n::nat) \<in> carrier (mult_of P)" if "?mip x" for x n
   proof -
     have "monic_poly R (x [^]\<^bsub>P\<^esub> n)"
-      using that monic_poly_pow 
+      using that monic_poly_pow
       unfolding monic_irreducible_poly_def by auto
     thus ?thesis
       using monic_poly_carr_2 by simp
   qed
 
-  have "?lhs \<sim>\<^bsub>(mult_of P)\<^esub> 
-    finprod (mult_of P) 
+  have "?lhs \<sim>\<^bsub>(mult_of P)\<^esub>
+    finprod (mult_of P)
       (\<lambda>d. d [^]\<^bsub>(mult_of P)\<^esub> (multiplicity (mult_of P) d a)) ?T"
-    unfolding t 
+    unfolding t
     by (intro p.mult_of.split_factors(2)
         [OF monic_polys_are_canonical_irreducibles sp_4])
-  also have "... = 
+  also have "... =
     finprod (mult_of P) (\<lambda>d. d [^]\<^bsub>P\<^esub> (multiplicity (mult_of P) d a)) ?T"
     by (simp add:nat_pow_mult_of)
   also have "... = ?rhs"
     using fin_T a
-    by (subst p.finprod_mult_of, simp_all add:pmult_def) 
+    by (subst p.finprod_mult_of, simp_all add:pmult_def)
   finally have "?lhs \<sim>\<^bsub>(mult_of P)\<^esub> ?rhs" by simp
-  moreover have "monic_poly R ?rhs" 
-    using fin_T 
+  moreover have "monic_poly R ?rhs"
+    using fin_T
     by (intro monic_poly_prod monic_poly_pow)
-      (auto simp:monic_irreducible_poly_def) 
+      (auto simp:monic_irreducible_poly_def)
   ultimately show "?lhs = ?rhs"
     using monic_poly_not_assoc assms monic_irreducible_poly_def
     by blast
 qed
 
 lemma degree_monic_poly':
   assumes "monic_poly R f"
-  shows 
-    "sum' (\<lambda>d. pmult d f * degree d) {d. monic_irreducible_poly R d} = 
-    degree f" 
+  shows
+    "sum' (\<lambda>d. pmult d f * degree d) {d. monic_irreducible_poly R d} =
+    degree f"
 proof -
   let ?mip = "monic_irreducible_poly R"
 
-  have b: "d \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" if "?mip d" for d 
+  have b: "d \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" if "?mip d" for d
     using that monic_poly_carr_2
     unfolding monic_irreducible_poly_def by simp
   have a: "d [^]\<^bsub>P\<^esub> n \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}" if "?mip d" for d and n :: "nat"
     using b that monic_poly_pow
-    unfolding monic_irreducible_poly_def 
+    unfolding monic_irreducible_poly_def
     by (simp add: p.pow_non_zero)
 
-  have "degree f = 
+  have "degree f =
     degree (\<Otimes>\<^bsub>P\<^esub>d\<in>{d. ?mip d \<and> pmult d f > 0}. d [^]\<^bsub>P\<^esub> pmult d f)"
     using factor_monic_poly[OF assms(1)] by simp
-  also have "... = 
+  also have "... =
     (\<Sum>i\<in>{d. ?mip d \<and> 0 < pmult d f}. degree (i [^]\<^bsub>P\<^esub> pmult i f))"
     using a assms(1)
     by (subst degree_prod[OF factor_monic_poly_fin])
      (simp_all add:Pi_def)
-  also have "... = 
+  also have "... =
     (\<Sum>i\<in>{d. ?mip d \<and> 0 < pmult d f}. degree i * pmult i f)"
     using b degree_pow by (intro sum.cong, auto)
-  also have "... = 
+  also have "... =
     (\<Sum>d\<in>{d. ?mip d \<and> 0 < pmult d f}. pmult d f * degree d)"
     by (simp add:mult.commute)
-  also have "... = 
+  also have "... =
     sum' (\<lambda>d. pmult d f * degree d) {d. ?mip d \<and> 0 < pmult d f}"
     using sum.eq_sum factor_monic_poly_fin[OF assms(1)] by simp
   also have "... = sum' (\<lambda>d. pmult d f * degree d) {d. ?mip d}"
     by (intro sum.mono_neutral_cong_left' subsetI, auto)
   finally show ?thesis by simp
 qed
 
 lemma monic_poly_min_degree:
   assumes "monic_irreducible_poly R f"
   shows  "degree f \<ge> 1"
   using assms unfolding monic_irreducible_poly_def monic_poly_def
   by (intro pirreducible_degree) auto
 
 lemma degree_one_monic_poly:
-  "monic_irreducible_poly R f \<and> degree f = 1 \<longleftrightarrow> 
+  "monic_irreducible_poly R f \<and> degree f = 1 \<longleftrightarrow>
   (\<exists>x \<in> carrier R. f = [\<one>, \<ominus>x])"
-proof 
+proof
   assume "monic_irreducible_poly R f \<and> degree f = 1"
   hence a:"monic_poly R f" "length f = 2"
     unfolding monic_irreducible_poly_def by auto
   then obtain u v where f_def: "f = [u,v]"
     by (cases f, simp, cases "tl f", auto)
 
   have "u = \<one>" using a unfolding monic_poly_def f_def by simp
-  moreover have "v \<in> carrier R" 
+  moreover have "v \<in> carrier R"
     using a unfolding monic_poly_def univ_poly_carrier[symmetric]
-    unfolding polynomial_def f_def by simp 
+    unfolding polynomial_def f_def by simp
   ultimately have "f =  [\<one>, \<ominus>(\<ominus>v)]" "(\<ominus>v) \<in> carrier R"
     using a_inv_closed f_def by auto
   thus "(\<exists>x \<in> carrier R. f = [\<one>\<^bsub>R\<^esub>, \<ominus>\<^bsub>R\<^esub>x])" by auto
 next
   assume "(\<exists>x \<in> carrier R. f = [\<one>, \<ominus>x])"
   then obtain x where f_def: "f = [\<one>,\<ominus>x]" "x \<in> carrier R" by auto
   have a:"degree f = 1" using f_def(2) unfolding f_def by simp
   have b:"f \<in> carrier P"
     using f_def(2) unfolding univ_poly_carrier[symmetric]
     unfolding f_def polynomial_def by simp
-  have c: "pirreducible (carrier R) f"   
+  have c: "pirreducible (carrier R) f"
     by (intro degree_one_imp_pirreducible a b)
   have d: "lead_coeff f = \<one>" unfolding f_def by simp
   show "monic_irreducible_poly R f \<and> degree f = 1"
-    using a b c d 
+    using a b c d
     unfolding monic_irreducible_poly_def monic_poly_def
     by auto
 qed
 
 lemma multiplicity_ge_iff:
-  assumes "monic_irreducible_poly R d" 
+  assumes "monic_irreducible_poly R d"
   assumes "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
   shows "pmult d f \<ge> k \<longleftrightarrow> d [^]\<^bsub>P\<^esub> k pdivides f"
 proof -
-  have a:"f \<in> carrier (mult_of P)" 
+  have a:"f \<in> carrier (mult_of P)"
     using assms(2) by simp
-  have b: "d \<in> carrier (mult_of P)" 
+  have b: "d \<in> carrier (mult_of P)"
     using assms(1) monic_poly_carr_2
     unfolding monic_irreducible_poly_def by simp
-  have c: "irreducible (mult_of P) d" 
-    using assms(1) monic_poly_carr_2 
+  have c: "irreducible (mult_of P) d"
+    using assms(1) monic_poly_carr_2
     using p.irreducible_imp_irreducible_mult
-    unfolding monic_irreducible_poly_def 
+    unfolding monic_irreducible_poly_def
     unfolding ring_irreducible_def monic_poly_def
     by simp
   have d: "d [^]\<^bsub>P\<^esub> k \<in> carrier P" using b by simp
 
   have "pmult d f \<ge> k \<longleftrightarrow> d [^]\<^bsub>(mult_of P)\<^esub> k divides\<^bsub>(mult_of P)\<^esub> f"
     unfolding pmult_def
     by (intro p.mult_of.multiplicity_ge_iff a b c)
   also have "... \<longleftrightarrow> d [^]\<^bsub>P\<^esub> k pdivides\<^bsub>R\<^esub> f"
     using p.divides_imp_divides_mult[OF d assms(2)]
-    using divides_mult_imp_divides 
+    using divides_mult_imp_divides
     unfolding pdivides_def nat_pow_mult_of
     by auto
   finally show ?thesis by simp
 qed
 
 lemma multiplicity_ge_1_iff_pdivides:
   assumes "monic_irreducible_poly R d" "f \<in> carrier P - {\<zero>\<^bsub>P\<^esub>}"
   shows "pmult d f \<ge> 1 \<longleftrightarrow> d pdivides f"
 proof -
-  have "d \<in> carrier P" 
+  have "d \<in> carrier P"
     using assms(1) monic_poly_carr
     unfolding monic_irreducible_poly_def
     by simp
   thus ?thesis
     using multiplicity_ge_iff[OF assms, where k="1"]
     by simp
 qed
-  
+
 lemma divides_monic_poly:
   assumes "monic_poly R f" "monic_poly R g"
-  assumes "\<And>d. monic_irreducible_poly R d 
-    \<Longrightarrow> pmult d f \<le> pmult d g" 
+  assumes "\<And>d. monic_irreducible_poly R d
+    \<Longrightarrow> pmult d f \<le> pmult d g"
   shows "f pdivides g"
 proof -
-  have a:"f \<in> carrier (mult_of P)" "g \<in> carrier (mult_of P)" 
+  have a:"f \<in> carrier (mult_of P)" "g \<in> carrier (mult_of P)"
     using monic_poly_carr_2 assms(1,2) by auto
 
   have "f divides\<^bsub>(mult_of P)\<^esub> g"
-    using assms(3) unfolding pmult_def 
+    using assms(3) unfolding pmult_def
     by (intro p.mult_of.divides_iff_mult_mono
         [OF a monic_polys_are_canonical_irreducibles]) simp
-  thus ?thesis 
+  thus ?thesis
     unfolding pdivides_def using divides_mult_imp_divides by simp
 qed
 
 end
 
 lemma monic_poly_hom:
   assumes "monic_poly R f"
   assumes "h \<in> ring_iso R S" "domain R" "domain S"
   shows "monic_poly S (map h f)"
 proof -
   have c: "h \<in> ring_hom R S"
     using assms(2) ring_iso_def by auto
-  have e: "f \<in> carrier (poly_ring R)" 
+  have e: "f \<in> carrier (poly_ring R)"
     using assms(1) unfolding monic_poly_def by simp
 
   have a:"f \<noteq> []"
     using assms(1) unfolding monic_poly_def by simp
   hence "map h f \<noteq> []" by simp
   moreover have "lead_coeff f = \<one>\<^bsub>R\<^esub>"
     using assms(1) unfolding monic_poly_def by simp
-  hence "lead_coeff (map h f) = \<one>\<^bsub>S\<^esub>" 
+  hence "lead_coeff (map h f) = \<one>\<^bsub>S\<^esub>"
     using ring_hom_one[OF c] by (simp add: hd_map[OF a])
   ultimately show ?thesis
     using carrier_hom[OF e assms(2-4)]
     unfolding monic_poly_def by simp
 qed
 
 lemma monic_irreducible_poly_hom:
   assumes "monic_irreducible_poly R f"
   assumes "h \<in> ring_iso R S" "domain R" "domain S"
   shows "monic_irreducible_poly S (map h f)"
 proof -
   have a:
     "pirreducible\<^bsub>R\<^esub> (carrier R) f"
     "f \<in> carrier (poly_ring R)"
     "monic_poly R f"
     using assms(1)
     unfolding monic_poly_def monic_irreducible_poly_def
     by auto
- 
+
   have "pirreducible\<^bsub>S\<^esub> (carrier S) (map h f)"
-    using a pirreducible_hom assms by auto  
+    using a pirreducible_hom assms by auto
   moreover have "monic_poly S (map h f)"
     using a monic_poly_hom[OF _ assms(2,3,4)] by simp
   ultimately show ?thesis
     unfolding monic_irreducible_poly_def by simp
 qed
 
 end
diff --git a/thys/Finite_Fields/ROOT b/thys/Finite_Fields/ROOT
--- a/thys/Finite_Fields/ROOT
+++ b/thys/Finite_Fields/ROOT
@@ -1,18 +1,29 @@
 chapter AFP
 
 session Finite_Fields = "HOL-Algebra" +
-  options [timeout = 600]
+  options [timeout = 1200]
   sessions
+    Digit_Expansions
     Dirichlet_Series
+    Executable_Randomized_Algorithms
+    Probabilistic_While
   theories 
     Card_Irreducible_Polynomials
     Card_Irreducible_Polynomials_Aux
     Finite_Fields_Factorization_Ext
     Finite_Fields_Isomorphic
     Finite_Fields_Preliminary_Results
     Formal_Polynomial_Derivatives
     Monic_Polynomial_Factorization
     Ring_Characteristic
+    Rabin_Irreducibility_Test
+    Rabin_Irreducibility_Test_Code
+    Finite_Fields_More_Bijections
+    Finite_Fields_Indexed_Algebra_Code
+    Finite_Fields_Mod_Ring_Code
+    Finite_Fields_Poly_Factor_Ring_Code
+    Finite_Fields_Poly_Ring_Code
+    Find_Irreducible_Poly
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Finite_Fields/Rabin_Irreducibility_Test.thy b/thys/Finite_Fields/Rabin_Irreducibility_Test.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Rabin_Irreducibility_Test.thy
@@ -0,0 +1,344 @@
+section \<open>Rabin's test for irreducible polynomials\<close>
+
+theory Rabin_Irreducibility_Test
+  imports Card_Irreducible_Polynomials_Aux
+begin
+
+text \<open>This section introduces an effective test for irreducibility of polynomials
+(in finite fields) based on Rabin~\cite{rabin1980}.\<close>
+
+definition pcoprime :: "_ \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("pcoprime\<index>")
+  where "pcoprime\<^bsub>R\<^esub> p q =
+    (\<forall>r \<in> carrier (poly_ring R). r pdivides\<^bsub>R\<^esub> p \<and> r pdivides\<^bsub>R\<^esub> q \<longrightarrow> degree r = 0)"
+
+lemma pcoprimeI:
+  assumes "\<And>r. r \<in> carrier (poly_ring R) \<Longrightarrow> r pdivides \<^bsub>R\<^esub> p \<Longrightarrow> r pdivides\<^bsub>R\<^esub> q \<Longrightarrow> degree r = 0"
+  shows "pcoprime\<^bsub>R\<^esub> p q"
+  using assms unfolding pcoprime_def by auto
+
+context field
+begin
+
+interpretation r:polynomial_ring R "(carrier R)"
+  unfolding polynomial_ring_def polynomial_ring_axioms_def
+  using carrier_is_subfield field_axioms by force
+
+lemma pcoprime_one: "pcoprime\<^bsub>R\<^esub> p \<one>\<^bsub>poly_ring R\<^esub>"
+proof (rule pcoprimeI)
+  fix r
+  assume r_carr: "r \<in> carrier (poly_ring R)"
+  moreover assume "r pdivides \<^bsub>R\<^esub> \<one>\<^bsub>poly_ring R\<^esub>"
+  moreover have "\<one>\<^bsub>poly_ring R\<^esub> \<noteq> []" by (simp add:univ_poly_one)
+  ultimately have "degree r \<le> degree \<one>\<^bsub>poly_ring R\<^esub>"
+    by (intro pdivides_imp_degree_le[OF carrier_is_subring] r_carr) auto
+  also have "... = 0" by (simp add:univ_poly_one)
+  finally show "degree r = 0" by auto
+qed
+
+lemma pcoprime_left_factor:
+  assumes "x \<in> carrier (poly_ring R)"
+  assumes "y \<in> carrier (poly_ring R)"
+  assumes "z \<in> carrier (poly_ring R)"
+  assumes "pcoprime\<^bsub>R\<^esub> (x \<otimes>\<^bsub>poly_ring R\<^esub> y) z"
+  shows "pcoprime\<^bsub>R\<^esub> x z"
+proof (rule pcoprimeI)
+  fix r
+  assume r_carr: "r \<in> carrier (poly_ring R)"
+  assume "r pdivides \<^bsub>R\<^esub> x"
+  hence "r pdivides  \<^bsub>R\<^esub> (x \<otimes>\<^bsub>poly_ring R\<^esub> y)"
+    using assms(1,2) r_carr r.p.divides_prod_r unfolding pdivides_def by simp
+  moreover assume "r pdivides \<^bsub>R\<^esub> z"
+  ultimately show "degree r = 0" using assms(4) r_carr unfolding pcoprime_def by simp
+qed
+
+lemma pcoprime_sym:
+  shows "pcoprime x y = pcoprime y x"
+  unfolding pcoprime_def by auto
+
+lemma pcoprime_left_assoc_cong_aux:
+  assumes "x1 \<in> carrier (poly_ring R)" "x2 \<in> carrier (poly_ring R)"
+  assumes "x2 \<sim>\<^bsub>poly_ring R\<^esub> x1"
+  assumes "y \<in> carrier (poly_ring R)"
+  assumes "pcoprime x1 y"
+  shows "pcoprime x2 y"
+  using assms r.p.divides_cong_r[OF _ assms(3)] unfolding pcoprime_def pdivides_def by simp
+
+lemma pcoprime_left_assoc_cong:
+  assumes "x1 \<in> carrier (poly_ring R)" "x2 \<in> carrier (poly_ring R)"
+  assumes "x1 \<sim>\<^bsub>poly_ring R\<^esub> x2"
+  assumes "y \<in> carrier (poly_ring R)"
+  shows "pcoprime x1 y = pcoprime x2 y"
+  using assms pcoprime_left_assoc_cong_aux r.p.associated_sym by metis
+
+lemma pcoprime_right_assoc_cong:
+  assumes "x1 \<in> carrier (poly_ring R)" "x2 \<in> carrier (poly_ring R)"
+  assumes "x1 \<sim>\<^bsub>poly_ring R\<^esub> x2"
+  assumes "y \<in> carrier (poly_ring R)"
+  shows "pcoprime y x1 = pcoprime y x2"
+  using assms pcoprime_sym pcoprime_left_assoc_cong by metis
+
+lemma pcoprime_step:
+  assumes "f \<in> carrier (poly_ring R)"
+  assumes "g \<in> carrier (poly_ring R)"
+  shows "pcoprime f g \<longleftrightarrow> pcoprime g (f pmod g)"
+proof -
+  have "d pdivides f \<longleftrightarrow> d pdivides (f pmod g)" if "d \<in> carrier (poly_ring R)" "d pdivides g" for d
+  proof -
+    have "d pdivides f \<longleftrightarrow> d pdivides (g \<otimes>\<^bsub>r.P\<^esub> (f pdiv g) \<oplus>\<^bsub>r.P\<^esub> (f pmod g))"
+      using pdiv_pmod[OF carrier_is_subfield assms] by simp
+    also have "... \<longleftrightarrow> d pdivides ((f pmod g))"
+      using that assms long_division_closed[OF carrier_is_subfield] r.p.divides_prod_r
+      unfolding pdivides_def by (intro r.p.div_sum_iff) simp_all
+    finally show ?thesis by simp
+  qed
+  hence "d pdivides f \<and> d pdivides g \<longleftrightarrow> d pdivides g \<and> d pdivides (f pmod g)"
+    if "d \<in> carrier (poly_ring R)" for d
+    using that by auto
+  thus ?thesis
+    unfolding pcoprime_def by auto
+qed
+
+lemma pcoprime_zero_iff:
+  assumes "f \<in> carrier (poly_ring R)"
+  shows "pcoprime f [] \<longleftrightarrow> length f = 1"
+proof -
+  consider (i) "length f = 0" | (ii) "length f = 1" | (iii) "length f > 1"
+    by linarith
+  thus ?thesis
+  proof (cases)
+    case i
+    hence "f = []" by simp
+    moreover have "X pdivides []" using r.pdivides_zero r.var_closed(1) by blast
+    moreover have "degree X = 1" using degree_var by simp
+    ultimately have "\<not>pcoprime f []" using r.var_closed(1) unfolding pcoprime_def by auto
+    then show ?thesis using i by auto
+  next
+    case ii
+    hence "f \<noteq> []" "degree f = 0" by auto
+    hence "degree d = 0" if "d pdivides f" "d \<in> carrier (poly_ring R)" for d
+      using that(1) pdivides_imp_degree_le[OF carrier_is_subring that(2) assms] by simp
+    hence "pcoprime f []" unfolding pcoprime_def by auto
+    then show ?thesis using ii by simp
+  next
+    case iii
+    have "f pdivides f" using assms unfolding pdivides_def by simp
+    moreover have "f pdivides []" using assms r.pdivides_zero by blast
+    moreover have "degree f > 0" using iii by simp
+    ultimately have "\<not>pcoprime f []" using assms unfolding pcoprime_def by auto
+    then show ?thesis using iii by auto
+  qed
+qed
+
+end
+
+context finite_field
+begin
+
+interpretation r:polynomial_ring R "(carrier R)"
+  unfolding polynomial_ring_def polynomial_ring_axioms_def
+  using carrier_is_subfield field_axioms by force
+
+lemma exists_irreducible_proper_factor:
+  assumes "monic_poly R f" "degree f > 0" "\<not>monic_irreducible_poly R f"
+  shows "\<exists>g. monic_irreducible_poly R g \<and> g pdivides\<^bsub>R\<^esub> f \<and> degree g < degree f"
+proof -
+  define S where "S = {d. monic_irreducible_poly R d \<and> 0 < pmult d f}"
+
+  have f_carr: "f \<in> carrier (poly_ring R)" "f \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>"
+    using assms(1) unfolding monic_poly_def univ_poly_zero by auto
+
+  have "S \<noteq> {}"
+  proof (rule ccontr)
+    assume S_empty: "\<not>(S \<noteq> {})"
+    have "f = (\<Otimes>\<^bsub>poly_ring R\<^esub>d\<in>S. d [^]\<^bsub>poly_ring R\<^esub> pmult d f)"
+      unfolding S_def by (intro factor_monic_poly assms(1))
+    also have "... = \<one>\<^bsub>poly_ring R\<^esub>" using S_empty by simp
+    finally have "f = \<one>\<^bsub>poly_ring R\<^esub>" by simp
+    hence "degree f = 0" using degree_one by simp
+    thus "False" using assms(2) by simp
+  qed
+  then obtain g where g_irred: "monic_irreducible_poly R g" and "0 < pmult g f"
+    unfolding S_def by auto
+
+  hence "1 \<le> pmult g f" by simp
+
+  hence g_div: "g pdivides f" using multiplicity_ge_1_iff_pdivides f_carr g_irred by blast
+
+  then obtain h where f_def: "f = g \<otimes>\<^bsub>poly_ring R\<^esub> h" and h_carr:"h \<in> carrier (poly_ring R)"
+    unfolding pdivides_def by auto
+
+  have g_nz: "g \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>" and h_nz: "h \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>"
+    and g_carr: "g \<in> carrier (poly_ring R)"
+    using f_carr(2) h_carr g_irred unfolding f_def monic_irreducible_poly_def monic_poly_def
+    by auto
+
+  have "degree f = degree g + degree h"
+    using g_nz h_nz g_carr h_carr unfolding f_def by (intro degree_mult[OF r.K_subring]) auto
+  moreover have "degree h > 0"
+  proof (rule ccontr)
+    assume "\<not>(degree h > 0)"
+    hence "degree h = 0" by simp
+    hence "h \<in> Units (poly_ring R)"
+      using h_carr h_nz by (simp add: carrier_is_subfield univ_poly_units' univ_poly_zero)
+    hence "f \<sim>\<^bsub>poly_ring R\<^esub> g"
+      unfolding f_def using g_carr r.p.associatedI2' by force
+    hence "f \<sim>\<^bsub>mult_of (poly_ring R)\<^esub> g"
+      using f_carr g_nz g_carr by (simp add: r.p.assoc_iff_assoc_mult)
+    hence "f = g"
+      using monic_poly_not_assoc assms(1) g_irred unfolding monic_irreducible_poly_def by simp
+    hence "monic_irreducible_poly R f"
+      using g_irred by simp
+    thus "False"
+      using assms(3) by auto
+  qed
+  ultimately have "degree g < degree f" by simp
+  thus ?thesis using g_irred g_div by auto
+qed
+
+theorem rabin_irreducibility_condition:
+  assumes "monic_poly R f" "degree f > 0"
+  defines "N \<equiv> {degree f div p | p . Factorial_Ring.prime p \<and> p dvd degree f}"
+  shows "monic_irreducible_poly R f \<longleftrightarrow>
+    (f pdivides gauss_poly R (order R^degree f) \<and> (\<forall>n \<in> N. pcoprime (gauss_poly R (order R^n)) f))"
+    (is "?L \<longleftrightarrow> ?R1 \<and> ?R2")
+proof -
+  have f_carr: "f \<in> carrier (poly_ring R)"
+    using assms(1) unfolding monic_poly_def by blast
+
+  have "?R1" if "?L"
+    using div_gauss_poly_iff[where n="degree f"] that assms(2) by simp
+  moreover have "False" if cthat:"\<not>pcoprime (gauss_poly R (order R^n)) f" "?L" "n \<in> N" for n
+  proof -
+    obtain d where d_def:
+      "d pdivides f"
+      "d pdivides (gauss_poly R (order R^n))" "degree d > 0" "d \<in> carrier (poly_ring R)"
+      using cthat(1) unfolding pcoprime_def by auto
+
+    obtain p where p_def:
+      "n = degree f div p" "Factorial_Ring.prime p" "p dvd degree f"
+      using cthat(3) unfolding N_def by auto
+
+    have n_gt_0: "n > 0"
+      using p_def assms(2) by (metis dvd_div_eq_0_iff gr0I)
+
+    have "d \<notin> Units (poly_ring R)"
+      using d_def(3,4)  univ_poly_units'[OF carrier_is_subfield] by simp
+    hence "f pdivides d"
+      using cthat(2) d_def(1,4) unfolding monic_irreducible_poly_def ring_irreducible_def
+        Divisibility.irreducible_def properfactor_def pdivides_def f_carr by auto
+    hence "f pdivides (gauss_poly R (order R^n))"
+      using d_def(2,4) f_carr r.p.divides_trans unfolding pdivides_def by metis
+    hence "degree f dvd n"
+      using n_gt_0 div_gauss_poly_iff[OF _ cthat(2)] by auto
+    thus "False"
+      using p_def by (metis assms(2) div_less_dividend n_gt_0 nat_dvd_not_less prime_gt_1_nat)
+  qed
+  moreover have "False" if not_l:"\<not>?L" and r1:"?R1" and r2: "?R2"
+  proof -
+    obtain g where g_def: "g pdivides f" "degree g < degree f" "monic_irreducible_poly R g"
+      using r1 not_l exists_irreducible_proper_factor assms(1,2) by auto
+
+    have g_carr: "g \<in> carrier (poly_ring R)" and g_nz: "g \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>"
+      using g_def(3) unfolding monic_irreducible_poly_def monic_poly_def by (auto simp:univ_poly_zero)
+
+    have "g pdivides gauss_poly R (order R^degree f)"
+      using g_carr r1 g_def(1) unfolding pdivides_def using r.p.divides_trans by blast
+
+    hence "degree g dvd degree f"
+      using div_gauss_poly_iff[OF assms(2) g_def(3)] by auto
+
+    then obtain t where deg_f_def:"degree f = t * degree g"
+      by fastforce
+    hence "t > 1" using g_def(2) by simp
+    then obtain p where p_prime: "Factorial_Ring.prime p" "p dvd t"
+      by (metis order_less_irrefl prime_factor_nat)
+    hence p_div_deg_f: "p dvd degree f"
+      unfolding deg_f_def by simp
+    define n where "n = degree f div p"
+    have n_in_N: "n \<in> N"
+      unfolding N_def n_def using p_prime(1) p_div_deg_f by auto
+
+    have deg_g_dvd_n: "degree g dvd n"
+      using p_prime(2) unfolding n_def deg_f_def by auto
+
+    have n_gt_0: "n > 0"
+      using p_div_deg_f assms(2) p_prime(1) unfolding n_def
+      by (metis dvd_div_eq_0_iff gr0I)
+
+    have deg_g_gt_0: "degree g > 0"
+      using monic_poly_min_degree[OF g_def(3)] by simp
+
+    have 0:"g pdivides gauss_poly R (order R^n)"
+      using deg_g_dvd_n div_gauss_poly_iff[OF n_gt_0 g_def(3)] by simp
+
+    have "pcoprime (gauss_poly R (order R^n)) f"
+      using n_in_N r2 by simp
+    thus "False"
+      using 0 g_def(1) g_carr deg_g_gt_0 unfolding pcoprime_def by simp
+  qed
+  ultimately show ?thesis
+    by auto
+qed
+
+text \<open>A more general variant of the previous theorem for non-monic polynomials. The result is
+from Lemma~1 \cite{rabin1980}.\<close>
+
+theorem rabin_irreducibility_condition_2:
+  assumes "f \<in> carrier (poly_ring R)" "degree f > 0"
+  defines "N \<equiv> {degree f div p | p . Factorial_Ring.prime p \<and> p dvd degree f}"
+  shows "pirreducible (carrier R) f \<longleftrightarrow>
+    (f pdivides gauss_poly R (order R^degree f) \<and> (\<forall>n \<in> N. pcoprime (gauss_poly R (order R^n)) f))"
+    (is "?L \<longleftrightarrow> ?R1 \<and> ?R2")
+proof -
+  define \<alpha> where "\<alpha> = [inv (hd f)]"
+  let ?g = "(\<lambda>x. gauss_poly R (order R^x))"
+  let ?h = "\<alpha> \<otimes>\<^bsub>poly_ring R\<^esub> f"
+
+  have f_nz: "f \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>" unfolding univ_poly_zero using assms(2) by auto
+
+  hence "hd f \<in> carrier R - {\<zero>}" using assms(1) lead_coeff_carr by simp
+  hence "inv (hd f) \<in> carrier R - {\<zero>}" using field_Units by auto
+  hence \<alpha>_unit: "\<alpha> \<in> Units (poly_ring R)"
+    unfolding \<alpha>_def using univ_poly_carrier_units by simp
+
+  have \<alpha>_nz: "\<alpha> \<noteq> \<zero>\<^bsub>poly_ring R\<^esub>" unfolding univ_poly_zero \<alpha>_def by simp
+  have "hd ?h = hd \<alpha> \<otimes> hd f"
+    using \<alpha>_nz f_nz assms(1) \<alpha>_unit by (intro lead_coeff_mult) auto
+  also have "... = inv (hd f) \<otimes> hd f" unfolding \<alpha>_def by simp
+  also have "... = \<one>" using lead_coeff_carr f_nz assms(1) by (simp add: field_Units)
+  finally have "hd ?h = \<one>" by simp
+  moreover have "?h \<noteq> []"
+    using \<alpha>_nz f_nz univ_poly_zero by (metis \<alpha>_unit assms(1) r.p.Units_closed r.p.integral)
+  ultimately have h_monic: "monic_poly R ?h"
+    using r.p.Units_closed[OF \<alpha>_unit] assms(1) unfolding monic_poly_def by auto
+
+  have "degree ?h = degree \<alpha> + degree f"
+    using assms(1) f_nz \<alpha>_unit \<alpha>_nz by (intro degree_mult[OF carrier_is_subring]) auto
+  also have "... = degree f" unfolding \<alpha>_def by simp
+  finally have deg_f: "degree f = degree ?h" by simp
+
+  have hf_cong:"?h \<sim>\<^bsub>r.P\<^esub> f"
+    using assms(1) \<alpha>_unit by (simp add: r.p.Units_closed r.p.associatedI2 r.p.m_comm)
+  hence 0: "f pdivides ?g (degree f) \<longleftrightarrow> ?h pdivides ?g (degree f)"
+    unfolding pdivides_def using r.p.divides_cong_l r.p.associated_sym
+    using r.p.Units_closed[OF \<alpha>_unit] assms(1) gauss_poly_carr by blast
+
+  have 1: "pcoprime (?g n) f \<longleftrightarrow> pcoprime (?g n) ?h" for n
+    using hf_cong r.p.associated_sym r.p.Units_closed[OF \<alpha>_unit] assms(1)
+    by (intro pcoprime_right_assoc_cong gauss_poly_carr) auto
+
+  have "?L \<longleftrightarrow> pirreducible (carrier R) (\<alpha> \<otimes>\<^bsub>poly_ring R\<^esub> f)"
+    using \<alpha>_unit \<alpha>_nz assms(1) f_nz r.p.integral unfolding ring_irreducible_def
+    by (intro arg_cong2[where f="(\<and>)"] r.p.irreducible_prod_unit assms) auto
+  also have "... \<longleftrightarrow> monic_irreducible_poly R (\<alpha> \<otimes>\<^bsub>poly_ring R\<^esub> f)"
+    using h_monic unfolding monic_irreducible_poly_def by auto
+  also have "... \<longleftrightarrow> ?h pdivides ?g (degree f) \<and> (\<forall>n \<in> N. pcoprime (?g n) ?h)"
+    using assms(2) unfolding N_def deg_f by (intro rabin_irreducibility_condition h_monic) auto
+  also have "... \<longleftrightarrow> f pdivides ?g (degree f) \<and> (\<forall>n \<in> N. pcoprime (?g n) f)"
+    using 0 1 by simp
+  finally show ?thesis by simp
+qed
+
+end
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Rabin_Irreducibility_Test_Code.thy b/thys/Finite_Fields/Rabin_Irreducibility_Test_Code.thy
new file mode 100644
--- /dev/null
+++ b/thys/Finite_Fields/Rabin_Irreducibility_Test_Code.thy
@@ -0,0 +1,330 @@
+section \<open>Executable Code for Rabin's Irreducibility Test\<close>
+
+theory Rabin_Irreducibility_Test_Code
+  imports
+    Finite_Fields_Poly_Ring_Code
+    Finite_Fields_Mod_Ring_Code
+    Rabin_Irreducibility_Test
+begin
+
+fun pcoprime\<^sub>C :: "('a, 'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
+  where "pcoprime\<^sub>C R f g = (length (snd (ext_euclidean R f g)) = 1)"
+
+declare pcoprime\<^sub>C.simps[simp del]
+
+lemma pcoprime_c:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  shows "pcoprime\<^sub>C R f g \<longleftrightarrow> pcoprime\<^bsub>ring_of R\<^esub> f g"  (is "?L = ?R")
+proof (cases "f = [] \<and> g = []")
+  case True
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  have "?L = False" using True by (simp add: pcoprime\<^sub>C.simps ext_euclidean.simps poly_def)
+  also have "... \<longleftrightarrow>  (length \<zero>\<^bsub>poly_ring (ring_of R)\<^esub> = 1)" by (simp add:univ_poly_zero)
+  also have "... \<longleftrightarrow> pcoprime\<^bsub>ring_of R\<^esub> \<zero>\<^bsub>poly_ring (ring_of R)\<^esub>  []"
+    by (subst pcoprime_zero_iff) (simp_all)
+  also have "... \<longleftrightarrow> ?R" using True by (simp add: univ_poly_zero)
+  finally show ?thesis by simp
+next
+  case False
+
+  let ?P = "poly_ring (ring_of R)"
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  obtain s u v where suv_def: "((u,v),s) = ext_euclidean R f g" by (metis surj_pair)
+
+  have s_eq:"s = f \<otimes>\<^bsub>?P\<^esub> u \<oplus>\<^bsub>?P\<^esub> g \<otimes>\<^bsub>?P\<^esub> v" (is "?T1")
+    and s_div_f: "s pdivides\<^bsub>ring_of R\<^esub> f" and s_div_g: "s pdivides\<^bsub>ring_of R\<^esub> g" (is "?T3")
+    and suv_carr: "{s, u, v} \<subseteq> carrier ?P"
+    and s_nz: "s \<noteq> []"
+    using False suv_def[symmetric] ext_euclidean[OF assms(1,2,3)] by auto
+
+  have "?L \<longleftrightarrow> length s = 1" using suv_def[symmetric] by (simp add:pcoprime\<^sub>C.simps)
+  also have "... \<longleftrightarrow> ?R"
+    unfolding pcoprime_def
+  proof (intro iffI impI ballI)
+    fix r assume len_s: "length s = 1"
+    assume r_carr:"r \<in> carrier ?P"
+      and "r pdivides\<^bsub>ring_of R\<^esub> f \<and> r pdivides\<^bsub>ring_of R\<^esub> g"
+    hence r_div: "pmod f r = \<zero>\<^bsub>?P\<^esub>"  "pmod g r = \<zero>\<^bsub>?P\<^esub>" unfolding univ_poly_zero
+      using assms(2,3) pmod_zero_iff_pdivides[OF carrier_is_subfield] by auto
+
+    have "pmod s r = pmod (f \<otimes>\<^bsub>?P\<^esub> u) r \<oplus>\<^bsub>?P\<^esub> pmod (g \<otimes>\<^bsub>?P\<^esub> v) r"
+      using r_carr suv_carr assms unfolding s_eq
+      by (intro long_division_add[OF carrier_is_subfield]) auto
+    also have "... = pmod (pmod f r \<otimes>\<^bsub>?P\<^esub> u) r  \<oplus>\<^bsub>?P\<^esub> pmod (pmod g r \<otimes>\<^bsub>?P\<^esub> v) r"
+      using r_carr suv_carr assms by (intro arg_cong2[where f="(\<oplus>\<^bsub>?P\<^esub>)"] pmod_mult_left) auto
+    also have "... = pmod \<zero>\<^bsub>?P\<^esub> r  \<oplus>\<^bsub>?P\<^esub> pmod \<zero>\<^bsub>?P\<^esub> r"
+      using suv_carr unfolding r_div by simp
+    also have "... = []" using r_carr unfolding univ_poly_zero
+      by (simp add: long_division_zero[OF carrier_is_subfield] univ_poly_add)
+    finally have "pmod s r =  []" by simp
+    hence "r pdivides\<^bsub>ring_of R\<^esub> s"
+      using r_carr suv_carr pmod_zero_iff_pdivides[OF carrier_is_subfield] by auto
+    hence "degree r \<le> degree s"
+      using s_nz r_carr suv_carr by (intro pdivides_imp_degree_le[OF carrier_is_subring]) auto
+    thus "degree r = 0" using len_s by simp
+  next
+    assume "\<forall>r\<in>carrier ?P. r pdivides\<^bsub>ring_of R\<^esub> f \<and> r pdivides\<^bsub>ring_of R\<^esub> g \<longrightarrow> degree r = 0"
+    hence "degree s = 0" using s_div_f s_div_g suv_carr by simp
+    thus "length s =1" using s_nz
+      by (metis diff_is_0_eq diffs0_imp_equal length_0_conv less_one linorder_le_less_linear)
+  qed
+  finally show ?thesis by simp
+qed
+
+text \<open>The following is a fast version of @{term "pmod"} for polynomials (to a high power) that
+need to be reduced, this is used for the higher order term of the Gauss polynomial.\<close>
+
+fun pmod_pow\<^sub>C :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
+  where "pmod_pow\<^sub>C F f n g = (
+    let r = (if n \<ge> 2 then pmod_pow\<^sub>C F f (n div 2) g ^\<^sub>C\<^bsub>poly F\<^esub> 2 else 1\<^sub>C\<^bsub>poly F\<^esub>)
+    in pmod\<^sub>C F (r *\<^sub>C\<^bsub>poly F\<^esub> (f ^\<^sub>C\<^bsub>poly F\<^esub> (n mod 2))) g)"
+
+declare pmod_pow\<^sub>C.simps[simp del]
+
+lemma pmod_pow_c:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  assumes "g \<in> carrier (poly_ring (ring_of R))"
+  shows "pmod_pow\<^sub>C R f n g = ring.pmod (ring_of R) (f [^]\<^bsub>poly_ring (ring_of R)\<^esub> n) g"
+proof (induction n rule:nat_less_induct)
+  case (1 n)
+
+  let ?P = "poly_ring (ring_of R)"
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  have ring_c: "ring\<^sub>C R" using assms(1) unfolding field\<^sub>C_def domain\<^sub>C_def cring\<^sub>C_def by auto
+  have d_poly: "domain\<^sub>C (poly R)" using assms (1) unfolding field\<^sub>C_def by (intro poly_domain) auto
+
+  have ind: "pmod_pow\<^sub>C R f m g = pmod (f [^]\<^bsub>?P\<^esub> m) g" if "m < n" for m
+    using 1 that by auto
+
+  define r where "r = (if n \<ge> 2 then pmod_pow\<^sub>C R f (n div 2) g ^\<^sub>C\<^bsub>poly R\<^esub> 2 else 1\<^sub>C\<^bsub>poly R\<^esub>)"
+
+  have "pmod r g = pmod (f [^]\<^bsub>?P\<^esub> (n - (n mod 2))) g \<and> r \<in> carrier ?P"
+  proof (cases "n \<ge> 2")
+    case True
+    hence "r = pmod_pow\<^sub>C R f (n div 2) g [^]\<^bsub>?P\<^esub> (2 :: nat)"
+      unfolding r_def domain_cD[OF d_poly] by (simp add:ring_of_poly[OF ring_c])
+    also have "... = pmod (f [^]\<^bsub>?P\<^esub> (n div 2)) g [^]\<^bsub>?P\<^esub> (2 :: nat)"
+      using True by (intro arg_cong2[where f="([^]\<^bsub>?P\<^esub>)"] refl ind) auto
+    finally have r_alt: "r = pmod (f [^]\<^bsub>?P\<^esub> (n div 2)) g [^]\<^bsub>?P\<^esub> (2 :: nat)"
+      by simp
+
+    have "pmod r g = pmod (pmod (f [^]\<^bsub>?P\<^esub> (n div 2)) g \<otimes>\<^bsub>?P\<^esub> pmod (f [^]\<^bsub>?P\<^esub> (n div 2)) g) g"
+      unfolding r_alt using assms(2,3) long_division_closed[OF carrier_is_subfield]
+      by (simp add:numeral_eq_Suc) algebra
+    also have "... = pmod (f [^]\<^bsub>?P\<^esub> (n div 2) \<otimes>\<^bsub>?P\<^esub> f [^]\<^bsub>?P\<^esub> (n div 2)) g"
+      using assms(2,3) by (intro pmod_mult_both[symmetric]) auto
+    also have "... = pmod (f [^]\<^bsub>?P\<^esub> ((n div 2)+(n div 2))) g"
+      using assms(2,3) by (subst d_poly_ring.nat_pow_mult) auto
+    also have "... = pmod (f [^]\<^bsub>?P\<^esub> (n - (n mod 2))) g"
+      by (intro arg_cong2[where f="pmod"] refl arg_cong2[where f="([^]\<^bsub>?P\<^esub>)"]) presburger
+    finally have "pmod r g = pmod (f [^]\<^bsub>?P\<^esub> (n - (n mod 2))) g"
+      by simp
+    moreover have "r \<in> carrier ?P"
+      using assms(2,3) long_division_closed[OF carrier_is_subfield] unfolding r_alt by auto
+    ultimately show ?thesis by auto
+  next
+    case False
+    hence "r = \<one>\<^bsub>?P\<^esub>"
+      unfolding r_def using domain_cD[OF d_poly] ring_of_poly[OF ring_c] by simp
+    also have "... = f [^]\<^bsub>?P\<^esub> (0 :: nat)" by simp
+    also have "... = f [^]\<^bsub>?P\<^esub> (n - (n mod 2))"
+      using False by (intro arg_cong2[where f="([^]\<^bsub>?P\<^esub>)"] refl) auto
+    finally have "r = f [^]\<^bsub>?P\<^esub> (n - (n mod 2))" by simp
+    then show ?thesis using assms(2) by simp
+  qed
+
+  hence r_exp: "pmod r g = pmod (f [^]\<^bsub>?P\<^esub> (n - (n mod 2))) g" and r_carr: "r \<in> carrier ?P"
+    by auto
+
+  have "pmod_pow\<^sub>C R f n g = pmod\<^sub>C R (r *\<^sub>C\<^bsub>poly R\<^esub> (f ^\<^sub>C\<^bsub>poly R\<^esub> (n mod 2))) g"
+    by (subst pmod_pow\<^sub>C.simps) (simp add:r_def[symmetric])
+  also have "... = pmod\<^sub>C R (r \<otimes>\<^bsub>?P\<^esub> (f [^]\<^bsub>?P\<^esub> (n mod 2))) g"
+    unfolding domain_cD[OF d_poly] by (simp add:ring_of_poly[OF ring_c])
+  also have "... = pmod (r \<otimes>\<^bsub>?P\<^esub> (f [^]\<^bsub>?P\<^esub> (n mod 2))) g"
+    using r_carr assms(2,3) by (intro pmod_c[OF assms(1)]) auto
+  also have "... = pmod (pmod r g \<otimes>\<^bsub>?P\<^esub> (f [^]\<^bsub>?P\<^esub> (n mod 2))) g"
+    using r_carr assms(2,3) by (intro pmod_mult_left) auto
+  also have "... = pmod (f [^]\<^bsub>?P\<^esub> (n - (n mod 2)) \<otimes>\<^bsub>?P\<^esub> (f [^]\<^bsub>?P\<^esub> (n mod 2))) g"
+    using assms(2,3) unfolding r_exp by (intro pmod_mult_left[symmetric]) auto
+  also have "... = pmod (f [^]\<^bsub>?P\<^esub> ((n - (n mod 2)) + (n mod 2))) g"
+    using assms(2,3) by (intro arg_cong2[where f="pmod"] refl d_poly_ring.nat_pow_mult) auto
+  also have "... = pmod (f [^]\<^bsub>?P\<^esub> n) g" by simp
+  finally show "pmod_pow\<^sub>C R f n g = pmod (f [^]\<^bsub>?P\<^esub> n) g" by simp
+qed
+
+text \<open>The following function checks whether a given polynomial is coprime with the
+Gauss polynomial $X^n - X$.\<close>
+
+definition pcoprime_with_gauss_poly :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> bool"
+  where "pcoprime_with_gauss_poly F p n =
+    (pcoprime\<^sub>C F p (pmod_pow\<^sub>C F X\<^sub>C\<^bsub>F\<^esub> n p +\<^sub>C\<^bsub>poly F\<^esub> (-\<^sub>C\<^bsub>poly F\<^esub> pmod\<^sub>C F X\<^sub>C\<^bsub>F\<^esub> p)))"
+
+
+definition divides_gauss_poly :: "('a,'b) idx_ring_scheme \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> bool"
+  where "divides_gauss_poly F p n =
+    (pmod_pow\<^sub>C F X\<^sub>C\<^bsub>F\<^esub> n p +\<^sub>C\<^bsub>poly F\<^esub> (-\<^sub>C\<^bsub>poly F\<^esub> pmod\<^sub>C F X\<^sub>C\<^bsub>F\<^esub> p) = [])"
+
+lemma mod_gauss_poly:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  shows "pmod_pow\<^sub>C R X\<^sub>C\<^bsub>R\<^esub> n f +\<^sub>C\<^bsub>poly R\<^esub> (-\<^sub>C\<^bsub>poly R\<^esub> pmod\<^sub>C R X\<^sub>C\<^bsub>R\<^esub> f) =
+    ring.pmod (ring_of R) (gauss_poly (ring_of R) n) f" (is "?L = ?R")
+proof -
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+  interpret d_poly_ring: domain "poly_ring (ring_of R)"
+    by (rule univ_poly_is_domain[OF carrier_is_subring])
+
+  have ring_c: "ring\<^sub>C R" using assms(1) unfolding field\<^sub>C_def domain\<^sub>C_def cring\<^sub>C_def by auto
+  have d_poly: "domain\<^sub>C (poly R)" using assms (1) unfolding field\<^sub>C_def by (intro poly_domain) auto
+  let ?P = "poly_ring (ring_of R)"
+
+  have "?L = pmod_pow\<^sub>C R X\<^bsub>ring_of R\<^esub> n f \<oplus>\<^bsub>?P\<^esub> -\<^sub>C\<^bsub>poly R\<^esub> pmod\<^sub>C R X\<^bsub>ring_of R\<^esub> f"
+    by (simp add: poly_var domain_cD[OF d_poly] ring_of_poly[OF ring_c])
+  also have "...= pmod (X\<^bsub>ring_of R\<^esub>[^]\<^bsub>?P\<^esub> n) f\<oplus>\<^bsub>?P\<^esub> -\<^sub>C\<^bsub>poly R\<^esub> pmod X\<^bsub>ring_of R\<^esub> f"
+    using assms var_carr[OF carrier_is_subring] by (intro refl arg_cong2[where f="(\<oplus>\<^bsub>?P\<^esub>)"]
+        pmod_pow_c arg_cong[where f="\<lambda>x. (-\<^sub>C\<^bsub>poly R\<^esub> x)"] pmod_c) auto
+  also have "... =pmod (X\<^bsub>ring_of R\<^esub>[^]\<^bsub>?P\<^esub> n) f\<ominus>\<^bsub>?P\<^esub> pmod X\<^bsub>ring_of R\<^esub> f"
+    unfolding a_minus_def using assms(1,2) var_carr[OF carrier_is_subring]
+      ring_of_poly[OF ring_c] long_division_closed[OF carrier_is_subfield]
+    by (subst domain_cD[OF d_poly]) auto
+  also have "... = pmod (X\<^bsub>ring_of R\<^esub>[^]\<^bsub>?P\<^esub> n) f \<oplus>\<^bsub>?P\<^esub> pmod (\<ominus>\<^bsub>?P\<^esub> X\<^bsub>ring_of R\<^esub>) f"
+    using assms(2) var_carr[OF carrier_is_subring]
+    unfolding a_minus_def by (subst long_division_a_inv[OF carrier_is_subfield]) auto
+  also have " ... = pmod (gauss_poly (ring_of R) n) f"
+    using assms(2) var_carr[OF carrier_is_subring] var_pow_carr[OF carrier_is_subring]
+    unfolding gauss_poly_def a_minus_def by (subst long_division_add[OF carrier_is_subfield]) auto
+  finally show ?thesis by simp
+qed
+
+lemma pcoprime_with_gauss_poly:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  shows "pcoprime_with_gauss_poly R f n \<longleftrightarrow> pcoprime\<^bsub>ring_of R\<^esub> (gauss_poly (ring_of R) n) f"
+    (is "?L = ?R")
+proof -
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+
+  have "?L \<longleftrightarrow> pcoprime\<^sub>C R f (pmod (gauss_poly (ring_of R) n) f)"
+    unfolding pcoprime_with_gauss_poly_def using assms by (subst mod_gauss_poly) auto
+  also have "... = pcoprime\<^bsub>ring_of R\<^esub> f (pmod (gauss_poly (ring_of R) n) f)"
+    using assms gauss_poly_carr long_division_closed[OF carrier_is_subfield]
+    by (intro pcoprime_c) auto
+  also have "... = pcoprime\<^bsub>ring_of R\<^esub> (gauss_poly (ring_of R) n) f"
+    by (intro pcoprime_step[symmetric] gauss_poly_carr assms)
+  finally show ?thesis by simp
+qed
+
+lemma divides_gauss_poly:
+  assumes "field\<^sub>C R"
+  assumes "f \<in> carrier (poly_ring (ring_of R))"
+  shows "divides_gauss_poly R f n \<longleftrightarrow> f pdivides\<^bsub>ring_of R\<^esub> (gauss_poly (ring_of R) n)"
+    (is "?L = ?R")
+proof -
+  interpret field "ring_of R"
+    using assms(1) unfolding field\<^sub>C_def by simp
+  have "?L \<longleftrightarrow> (pmod (gauss_poly (ring_of R) n) f = [])"
+    unfolding divides_gauss_poly_def using assms by (subst mod_gauss_poly) auto
+  also have "... \<longleftrightarrow> ?R"
+    using assms gauss_poly_carr by (intro pmod_zero_iff_pdivides[OF carrier_is_subfield]) auto
+  finally show ?thesis
+    by simp
+qed
+
+
+fun rabin_test_powers :: "('a, 'b) idx_ring_enum_scheme \<Rightarrow> nat \<Rightarrow> nat list"
+  where "rabin_test_powers F n =
+    map (\<lambda>p. idx_size F^(n div p)) (filter (\<lambda>p. prime p \<and> p dvd n) [2..<(n+1)] )"
+
+text \<open>Given a monic polynomial with coefficients over a finite field returns true, if it is
+irreducible\<close>
+
+fun rabin_test :: "('a, 'b) idx_ring_enum_scheme \<Rightarrow> 'a list \<Rightarrow> bool"
+  where "rabin_test F f = (
+    if degree f = 0 then
+      False
+    else (if \<not>divides_gauss_poly F f (idx_size F^degree f) then
+      False
+    else (list_all (pcoprime_with_gauss_poly F f) (rabin_test_powers F (degree f)))))"
+
+declare rabin_test.simps[simp del]
+
+context
+  fixes R
+  assumes field_R: "field\<^sub>C R"
+  assumes enum_R: "enum\<^sub>C R"
+begin
+
+interpretation finite_field "(ring_of R)"
+  using field_R enum_cD[OF enum_R] unfolding field\<^sub>C_def
+  by (simp add:finite_field_def finite_field_axioms_def)
+
+lemma rabin_test_powers:
+  assumes "n > 0"
+  shows "set (rabin_test_powers R n) =
+    {order (ring_of R)^ (n div p) | p . Factorial_Ring.prime p \<and> p dvd n}"
+    (is "?L = ?R")
+proof -
+  let ?f = "(\<lambda>x. order (ring_of R) ^ (n div x))"
+
+  have 0:"p \<in> {2..n}" if "Factorial_Ring.prime p" "p dvd n"  for p
+    using assms that by (simp add: dvd_imp_le prime_ge_2_nat)
+
+  have "?L = ?f ` {p \<in> {2..n}.  Factorial_Ring.prime p \<and> p dvd n}"
+    using enum_cD[OF enum_R] by auto
+  also have "... = ?f ` {p.  Factorial_Ring.prime p \<and> p dvd n}"
+    using 0 by (intro image_cong Collect_cong) auto
+  also have "... = ?R"
+    by auto
+  finally show ?thesis by simp
+qed
+
+lemma rabin_test:
+  assumes "monic_poly (ring_of R) f"
+  shows "rabin_test R f \<longleftrightarrow> monic_irreducible_poly (ring_of R) f" (is "?L = ?R")
+proof (cases "degree f = 0")
+  case True
+  thus ?thesis unfolding rabin_test.simps using monic_poly_min_degree by fastforce
+next
+  case False
+  define N where "N = {degree f div p | p . Factorial_Ring.prime p \<and> p dvd degree f}"
+
+  have f_carr: "f \<in> carrier (poly_ring (ring_of R))"
+    using assms(1) unfolding monic_poly_def by auto
+
+  have deg_f_gt_0: "degree f > 0"
+    using False by auto
+  have rt_powers: "set (rabin_test_powers R (degree f)) = (\<lambda>x. order (ring_of R)^x) ` N"
+    unfolding rabin_test_powers[OF deg_f_gt_0] N_def by auto
+
+  have "?L \<longleftrightarrow> divides_gauss_poly R f (idx_size R ^ degree f) \<and>
+    (\<forall>n \<in> set (rabin_test_powers R (degree f)). (pcoprime_with_gauss_poly R f n))"
+    using False by (simp add: list_all_def rabin_test.simps del:rabin_test_powers.simps)
+  also have "... \<longleftrightarrow> f pdivides\<^bsub>ring_of R\<^esub> (gauss_poly (ring_of R) (order (ring_of R) ^ degree f))
+    \<and> (\<forall>n \<in> N. pcoprime\<^bsub>ring_of R\<^esub> (gauss_poly (ring_of R) (order (ring_of R) ^n)) f)"
+    unfolding divides_gauss_poly[OF field_R f_carr] pcoprime_with_gauss_poly[OF field_R f_carr]
+      rt_powers enum_cD[OF enum_R] by simp
+  also have "... \<longleftrightarrow> ?R"
+    using False unfolding N_def by (intro rabin_irreducibility_condition[symmetric] assms(1)) auto
+  finally show ?thesis by simp
+qed
+
+end
+
+end
\ No newline at end of file
diff --git a/thys/Finite_Fields/Ring_Characteristic.thy b/thys/Finite_Fields/Ring_Characteristic.thy
--- a/thys/Finite_Fields/Ring_Characteristic.thy
+++ b/thys/Finite_Fields/Ring_Characteristic.thy
@@ -1,1016 +1,1016 @@
 section \<open>Characteristic of Rings\label{sec:ring_char}\<close>
 
 theory Ring_Characteristic
-  imports 
+  imports
     "Finite_Fields_Factorization_Ext"
-    "HOL-Algebra.IntRing" 
+    "HOL-Algebra.IntRing"
     "HOL-Algebra.Embedded_Algebras"
 begin
 
 locale finite_field = field +
   assumes finite_carrier: "finite (carrier R)"
 begin
 
 lemma finite_field_min_order:
   "order R > 1"
 proof (rule ccontr)
   assume a:"\<not>(1 < order R)"
   have "{\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<subseteq> carrier R" by auto
   hence "card {\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<le> card (carrier R)"
     using card_mono finite_carrier by blast
   also have "... \<le> 1" using a by (simp add:order_def)
   finally have "card {\<zero>\<^bsub>R\<^esub>,\<one>\<^bsub>R\<^esub>} \<le> 1" by blast
   thus "False" by simp
 qed
 
 lemma (in finite_field) order_pow_eq_self:
   assumes "x \<in> carrier R"
   shows "x [^] (order R) = x"
 proof (cases "x = \<zero>")
   case True
   have "order R > 0"
     using assms(1) order_gt_0_iff_finite finite_carrier by simp
-  then obtain n where n_def:"order R = Suc n" 
+  then obtain n where n_def:"order R = Suc n"
     using lessE by blast
-  have "x [^] (order R) = \<zero>" 
+  have "x [^] (order R) = \<zero>"
     unfolding n_def using True by (subst nat_pow_Suc, simp)
   thus ?thesis using True by simp
 next
   case False
   have x_carr:"x \<in> carrier (mult_of R)"
     using False assms by simp
 
-  have carr_non_empty: "card (carrier R) > 0" 
+  have carr_non_empty: "card (carrier R) > 0"
     using order_gt_0_iff_finite finite_carrier
     unfolding order_def by simp
   have "x [^] (order R) = x [^]\<^bsub>mult_of R\<^esub> (order R)"
     by (simp add:nat_pow_mult_of)
   also have "... = x [^]\<^bsub>mult_of R\<^esub> (order (mult_of R)+1)"
     using carr_non_empty unfolding order_def
     by (intro arg_cong[where f="\<lambda>t. x [^]\<^bsub>mult_of R\<^esub> t"]) (simp)
   also have "... = x"
     using x_carr
     by (simp add:mult_of.pow_order_eq_1)
   finally show "x [^] (order R) = x"
     by simp
 qed
 
 lemma (in finite_field) order_pow_eq_self':
   assumes "x \<in> carrier R"
   shows "x [^] (order R ^ d) = x"
 proof (induction d)
   case 0
   then show ?case using assms by simp
 next
   case (Suc d)
   have "x [^] order R ^ (Suc d) = x [^] (order R ^ d * order R)"
     by (simp add:mult.commute)
   also have "... = (x [^] (order R ^ d)) [^] order R"
     using assms by (simp add: nat_pow_pow)
   also have "... = (x [^] (order R ^ d))"
     using order_pow_eq_self assms by simp
   also have "... = x"
     using Suc by simp
   finally show ?case by simp
 qed
 
 end
 
 lemma finite_fieldI:
   assumes "field R"
   assumes "finite (carrier R)"
   shows "finite_field R"
   using assms
   unfolding finite_field_def finite_field_axioms_def
   by auto
 
 lemma (in domain) finite_domain_units:
   assumes "finite (carrier R)"
   shows "Units R = carrier R - {\<zero>}" (is "?lhs = ?rhs")
-proof 
-  have "Units R \<subseteq> carrier R" by (simp add:Units_def) 
+proof
+  have "Units R \<subseteq> carrier R" by (simp add:Units_def)
   moreover have "\<zero> \<notin> Units R"
     by (meson zero_is_prime(1) primeE)
   ultimately show "Units R \<subseteq> carrier R - {\<zero>}" by blast
 next
   have "x \<in> Units R" if a: "x \<in> carrier R - {\<zero>}" for x
   proof -
     have x_carr: "x \<in> carrier R" using a by blast
     define f where "f = (\<lambda>y. y \<otimes>\<^bsub>R\<^esub> x)"
     have "inj_on f (carrier R)" unfolding f_def
       by (rule inj_onI, metis DiffD1 DiffD2 a m_rcancel insertI1)
     hence "card (carrier R) = card (f ` carrier R)"
       by (metis card_image)
     moreover have "f ` carrier R \<subseteq> carrier R" unfolding f_def
       by (rule image_subsetI, simp add: ring.ring_simprules x_carr)
     ultimately have "f ` carrier R = carrier R"
       using card_subset_eq assms by metis
     moreover have "\<one>\<^bsub>R\<^esub> \<in> carrier R" by simp
-    ultimately have "\<exists>y \<in> carrier R. f y = \<one>\<^bsub>R\<^esub>" 
+    ultimately have "\<exists>y \<in> carrier R. f y = \<one>\<^bsub>R\<^esub>"
       by (metis image_iff)
-    then obtain y 
-      where y_carrier: "y \<in> carrier R" 
-        and y_left_inv: "y \<otimes>\<^bsub>R\<^esub> x = \<one>\<^bsub>R\<^esub>" 
+    then obtain y
+      where y_carrier: "y \<in> carrier R"
+        and y_left_inv: "y \<otimes>\<^bsub>R\<^esub> x = \<one>\<^bsub>R\<^esub>"
       using f_def by blast
     hence  y_right_inv: "x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub>"
       by (metis DiffD1 a cring_simprules(14))
     show "x \<in> Units R"
       using y_carrier y_left_inv y_right_inv
       by (metis DiffD1 a divides_one factor_def)
   qed
   thus "?rhs \<subseteq> ?lhs" by auto
 qed
 
 text \<open>The following theorem can be found in Lidl and Niederreiter~\<^cite>\<open>\<open>Theorem 1.31\<close> in "lidl1986"\<close>.\<close>
 
 theorem finite_domains_are_fields:
   assumes "domain R"
   assumes "finite (carrier R)"
   shows "finite_field R"
 proof -
   interpret domain R using assms by auto
   have "Units R = carrier R - {\<zero>\<^bsub>R\<^esub>}"
     using finite_domain_units[OF assms(2)] by simp
   then have "field R"
     by (simp add: assms(1) field.intro field_axioms.intro)
   thus ?thesis
-    using assms(2) finite_fieldI by auto 
+    using assms(2) finite_fieldI by auto
 qed
 
 definition zfact_iso :: "nat \<Rightarrow> nat \<Rightarrow> int set" where
   "zfact_iso p k = Idl\<^bsub>\<Z>\<^esub> {int p} +>\<^bsub>\<Z>\<^esub> (int k)"
 
 context
   fixes n :: nat
   assumes n_gt_0: "n > 0"
 begin
 
 private abbreviation I where "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
 
 private lemma ideal_I: "ideal I \<Z>"
   by (simp add: int.genideal_ideal)
 
 lemma int_cosetI:
   assumes "u mod (int n) = v mod (int n)"
   shows "Idl\<^bsub>\<Z>\<^esub> {int n} +>\<^bsub>\<Z>\<^esub> u = Idl\<^bsub>\<Z>\<^esub> {int n} +>\<^bsub>\<Z>\<^esub> v"
 proof -
   have "u - v \<in> I"
     by (metis Idl_subset_eq_dvd assms int_Idl_subset_ideal mod_eq_dvd_iff)
   thus ?thesis
     using ideal_I int.quotient_eq_iff_same_a_r_cos by simp
 qed
 
 lemma zfact_iso_inj:
   "inj_on (zfact_iso n) {..<n}"
 proof (rule inj_onI)
   fix x y
   assume a:"x \<in> {..<n}" "y \<in> {..<n}"
   assume "zfact_iso n x = zfact_iso n y"
   hence "I +>\<^bsub>\<Z>\<^esub> (int x) = I +>\<^bsub>\<Z>\<^esub> (int y)"
     by (simp add:zfact_iso_def)
   hence "int x - int y \<in> I"
     by (subst int.quotient_eq_iff_same_a_r_cos[OF ideal_I], auto)
   hence "int x mod int n = int y mod int n"
     by (meson Idl_subset_eq_dvd int_Idl_subset_ideal mod_eq_dvd_iff)
   thus "x = y"
     using a by simp
 qed
 
 lemma zfact_iso_ran:
   "zfact_iso n ` {..<n} = carrier (ZFact (int n))"
 proof -
   have "zfact_iso n ` {..<n} \<subseteq> carrier (ZFact (int n))"
-    unfolding zfact_iso_def ZFact_def FactRing_simps 
+    unfolding zfact_iso_def ZFact_def FactRing_simps
     using int.a_rcosetsI by auto
-  moreover have "x \<in> zfact_iso n ` {..<n}" 
+  moreover have "x \<in> zfact_iso n ` {..<n}"
     if a:"x \<in> carrier (ZFact (int n))" for x
   proof -
     obtain y where y_def: "x = I +>\<^bsub>\<Z>\<^esub> y"
       using a unfolding ZFact_def FactRing_simps by auto
     define z where \<open>z = nat (y mod int n)\<close>
     with n_gt_0 have z_def: \<open>int z mod int n = y mod int n\<close> \<open>z < n\<close>
       by (simp_all add: z_def nat_less_iff)
     have "x = I  +>\<^bsub>\<Z>\<^esub> y"
       by (simp add:y_def)
     also have "... = I +>\<^bsub>\<Z>\<^esub> (int z)"
       by (intro int_cosetI, simp add:z_def)
     also have "... = zfact_iso n z"
       by (simp add:zfact_iso_def)
     finally have "x = zfact_iso n z"
       by simp
     thus "x \<in> zfact_iso n ` {..<n}"
       using z_def(2) by blast
   qed
   ultimately show ?thesis by auto
 qed
 
 lemma zfact_iso_bij:
   "bij_betw (zfact_iso n) {..<n} (carrier (ZFact (int n)))"
   using  bij_betw_def zfact_iso_inj zfact_iso_ran by blast
 
 lemma card_zfact_carr: "card (carrier (ZFact (int n))) = n"
   using bij_betw_same_card[OF zfact_iso_bij] by simp
 
 lemma fin_zfact: "finite (carrier (ZFact (int n)))"
   using card_zfact_carr n_gt_0 card_ge_0_finite by force
 
 end
 
 lemma zfact_prime_is_finite_field:
   assumes "Factorial_Ring.prime p"
   shows "finite_field (ZFact (int p))"
 proof -
   have p_gt_0: "p > 0" using assms(1) prime_gt_0_nat by simp
-  have "Factorial_Ring.prime (int p)" 
+  have "Factorial_Ring.prime (int p)"
     using assms by simp
-  moreover have "finite (carrier (ZFact (int p)))" 
+  moreover have "finite (carrier (ZFact (int p)))"
     using fin_zfact[OF p_gt_0] by simp
   ultimately show ?thesis
     by (intro finite_domains_are_fields ZFact_prime_is_domain, auto)
 qed
 
 definition int_embed :: "_ \<Rightarrow> int \<Rightarrow> _"  where
   "int_embed R k = add_pow R k \<one>\<^bsub>R\<^esub>"
 
 lemma (in ring) add_pow_consistent:
   fixes i :: "int"
   assumes "subring K R"
   assumes "k \<in> K"
   shows "add_pow R i k = add_pow (R \<lparr> carrier := K \<rparr>) i k"
     (is "?lhs = ?rhs")
 proof -
-  have a:"subgroup K (add_monoid R)" 
+  have a:"subgroup K (add_monoid R)"
     using assms(1) subring.axioms by auto
-  have "add_pow R i k = k [^]\<^bsub>add_monoid R\<lparr>carrier := K\<rparr>\<^esub> i" 
+  have "add_pow R i k = k [^]\<^bsub>add_monoid R\<lparr>carrier := K\<rparr>\<^esub> i"
     using add.int_pow_consistent[OF a assms(2)] by simp
   also have "... = ?rhs"
     unfolding add_pow_def by simp
   finally show ?thesis by simp
 qed
 
 lemma (in ring) int_embed_consistent:
   assumes "subring K R"
   shows "int_embed R i = int_embed (R \<lparr> carrier := K \<rparr>) i"
 proof -
   have a:"\<one> = \<one>\<^bsub>R \<lparr> carrier := K \<rparr>\<^esub>" by simp
-  have b:"\<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub> \<in> K" 
+  have b:"\<one>\<^bsub>R\<lparr>carrier := K\<rparr>\<^esub> \<in> K"
     using assms subringE(3) by auto
   show ?thesis
     unfolding int_embed_def a using b add_pow_consistent[OF assms(1)] by simp
 qed
 
 lemma (in ring) int_embed_closed:
   "int_embed R k \<in> carrier R"
   unfolding int_embed_def using add.int_pow_closed by simp
 
 lemma (in ring) int_embed_range:
   assumes "subring K R"
   shows "int_embed R k \<in> K"
 proof -
   let ?R' =  "R \<lparr> carrier := K \<rparr>"
   interpret x:ring ?R'
     using subring_is_ring[OF assms] by simp
   have "int_embed R k = int_embed ?R' k"
     using int_embed_consistent[OF assms] by simp
   also have "...  \<in> K"
     using x.int_embed_closed by simp
   finally show ?thesis by simp
 qed
 
 lemma (in ring) int_embed_zero:
   "int_embed R 0 = \<zero>\<^bsub>R\<^esub>"
-  by (simp add:int_embed_def add_pow_def)  
+  by (simp add:int_embed_def add_pow_def)
 
 lemma (in ring) int_embed_one:
   "int_embed R 1 = \<one>\<^bsub>R\<^esub>"
-  by (simp add:int_embed_def)  
+  by (simp add:int_embed_def)
 
 lemma (in ring) int_embed_add:
   "int_embed R (x+y) = int_embed R x \<oplus>\<^bsub>R\<^esub> int_embed R y"
-  by (simp add:int_embed_def add.int_pow_mult)  
+  by (simp add:int_embed_def add.int_pow_mult)
 
 lemma (in ring) int_embed_inv:
   "int_embed R (-x) = \<ominus>\<^bsub>R\<^esub> int_embed R x" (is "?lhs = ?rhs")
 proof -
   have "?lhs = int_embed R (-x) \<oplus> (int_embed R x \<ominus> int_embed R x)"
     using int_embed_closed by simp
-  also have 
+  also have
     "... = int_embed R (-x) \<oplus> int_embed R x \<oplus> (\<ominus> int_embed R x)"
     using int_embed_closed by (subst a_minus_def, subst a_assoc, auto)
   also have "... = int_embed R (-x +x) \<oplus> (\<ominus> int_embed R x)"
     by (subst int_embed_add, simp)
   also have "... = ?rhs"
     using int_embed_closed
     by (simp add:int_embed_zero)
   finally show ?thesis by simp
 qed
 
 lemma (in ring) int_embed_diff:
   "int_embed R (x-y) = int_embed R x \<ominus>\<^bsub>R\<^esub> int_embed R y"
   (is "?lhs = ?rhs")
 proof -
   have "?lhs = int_embed R (x + (-y))"  by simp
   also have "... = ?rhs"
     by (subst int_embed_add, simp add:a_minus_def int_embed_inv)
   finally show ?thesis by simp
 qed
 
 lemma (in ring) int_embed_mult_aux:
   "int_embed R (x*int y) = int_embed R x \<otimes> int_embed R y"
 proof (induction y)
   case 0
   then show ?case by (simp add:int_embed_closed int_embed_zero)
 next
   case (Suc y)
   have "int_embed R (x * int (Suc y)) = int_embed R (x + x * int y)"
-    by (simp add:algebra_simps) 
+    by (simp add:algebra_simps)
   also have "... = int_embed R x \<oplus> int_embed R (x * int y)"
     by (subst int_embed_add, simp)
-  also have 
+  also have
     "... = int_embed R x \<otimes> \<one> \<oplus> int_embed R x \<otimes> int_embed R y"
     using int_embed_closed
     by (subst Suc, simp)
   also have "... = int_embed R x \<otimes> (int_embed R 1 \<oplus> int_embed R y)"
     using int_embed_closed by (subst r_distr, simp_all add:int_embed_one)
   also have "... = int_embed R x \<otimes> int_embed R (1+int y)"
     by (subst int_embed_add, simp)
   also have "... = int_embed R x \<otimes> int_embed R (Suc y)"
     by simp
   finally show ?case by simp
 qed
 
 lemma (in ring) int_embed_mult:
   "int_embed R (x*y) = int_embed R x \<otimes>\<^bsub>R\<^esub> int_embed R y"
 proof (cases "y \<ge> 0")
   case True
   then obtain y' where y_def: "y = int y'"
     using nonneg_int_cases by auto
   have "int_embed R (x * y) = int_embed R (x * int y')"
     unfolding y_def by simp
   also have "... = int_embed R x \<otimes> int_embed R y'"
     by (subst int_embed_mult_aux, simp)
   also have "... = int_embed R x \<otimes> int_embed R y"
     unfolding y_def by simp
   finally show ?thesis by simp
 next
   case False
-  then obtain y' where y_def: "y = - int y'" 
+  then obtain y' where y_def: "y = - int y'"
     by (meson nle_le nonpos_int_cases)
   have "int_embed R (x * y) = int_embed R (-(x * int y'))"
     unfolding y_def by simp
   also have "... = \<ominus> (int_embed R (x * int y'))"
     by (subst int_embed_inv, simp)
   also have "... = \<ominus> (int_embed R x \<otimes> int_embed R y')"
     by (subst int_embed_mult_aux, simp)
   also have "... = int_embed R x \<otimes> \<ominus> int_embed R y'"
     using int_embed_closed by algebra
   also have "... = int_embed R x \<otimes> int_embed R (-y')"
     by (subst int_embed_inv, simp)
   also have "... = int_embed R x \<otimes> int_embed R y"
     unfolding y_def by simp
   finally show ?thesis by simp
 qed
 
-lemma (in ring) int_embed_ring_hom: 
+lemma (in ring) int_embed_ring_hom:
   "ring_hom_ring int_ring R (int_embed R)"
-proof (rule ring_hom_ringI) 
+proof (rule ring_hom_ringI)
   show "ring int_ring" using int.ring_axioms by simp
   show "ring R" using ring_axioms by simp
   show "int_embed R x \<in> carrier R" if "x \<in> carrier \<Z>" for x
     using int_embed_closed by simp
-  show "int_embed R (x\<otimes>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<otimes> int_embed R y" 
-    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y 
+  show "int_embed R (x\<otimes>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<otimes> int_embed R y"
+    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y
     using int_embed_mult by simp
-  show "int_embed R (x\<oplus>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<oplus> int_embed R y" 
-    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y 
+  show "int_embed R (x\<oplus>\<^bsub>\<Z>\<^esub>y) = int_embed R x \<oplus> int_embed R y"
+    if "x \<in> carrier \<Z>" "y \<in> carrier \<Z>" for x y
     using int_embed_add by simp
   show "int_embed R \<one>\<^bsub>\<Z>\<^esub> = \<one>"
     by (simp add:int_embed_one)
 qed
 
 abbreviation char_subring where
   "char_subring R \<equiv> int_embed R ` UNIV"
 
-definition char where 
+definition char where
   "char R = card (char_subring R)"
 
-text \<open>This is a non-standard definition for the characteristic of a ring. 
+text \<open>This is a non-standard definition for the characteristic of a ring.
 
 Commonly~\<^cite>\<open>\<open>Definition 1.43\<close> in "lidl1986"\<close> it is defined to be the smallest natural number $n$ such
-that n-times repeated addition of any number is zero. If no such number exists then it is defined 
+that n-times repeated addition of any number is zero. If no such number exists then it is defined
 to be $0$. In the case of rings with unit elements --- not that the locale @{locale "ring"} requires
 unit elements --- the above definition can be simplified to the number of times the unit elements
 needs to be repeatedly added to reach $0$.
 
 The following three lemmas imply that the definition of the characteristic here coincides with the
 latter definition.\<close>
 
 lemma (in ring) char_bound:
   assumes "x > 0"
   assumes "int_embed R (int x) = \<zero>"
   shows "char R \<le> x" "char R > 0"
 proof -
   have "char_subring R \<subseteq> int_embed R ` ({0..<int x})"
   proof (rule image_subsetI)
     fix y :: int
     assume "y \<in> UNIV"
     define u where "u = y div (int x)"
     define v where "v = y mod (int x)"
     have "int x > 0" using assms by simp
     hence y_exp: "y = u * int x + v" "v \<ge> 0" "v < int x"
       unfolding u_def v_def by simp_all
     have "int_embed R y = int_embed R v"
       using int_embed_closed unfolding y_exp
       by (simp add:int_embed_mult int_embed_add assms(2))
     also have "... \<in> int_embed R ` ({0..<int x})"
       using y_exp(2,3) by simp
     finally show "int_embed R y \<in> int_embed R ` {0..<int x}"
       by simp
   qed
   hence a:"char_subring R = int_embed R ` {0..<int x}"
     by auto
   hence "char R = card (int_embed R ` ({0..<int x}))"
     unfolding char_def a by simp
   also have "... \<le> card {0..<int x}"
     by (intro card_image_le, simp)
   also have "... = x" by simp
   finally show "char R \<le> x" by simp
   have "1 = card {int_embed R 0}" by simp
   also have "... \<le> card (int_embed R ` {0..<int x})"
-    using assms(1) by (intro card_mono finite_imageI, simp_all) 
+    using assms(1) by (intro card_mono finite_imageI, simp_all)
   also have "... = char R"
     unfolding char_def a by simp
   finally show "char R > 0" by simp
 qed
 
 lemma (in ring) embed_char_eq_0:
   "int_embed R (int (char R)) = \<zero>"
 proof (cases "finite (char_subring R)")
   case True
   interpret h: ring_hom_ring "int_ring" R "(int_embed R)"
     using int_embed_ring_hom by simp
 
   define A where "A = {0..int (char R)}"
   have "card (int_embed R ` A) \<le> card (char_subring R)"
     by (intro card_mono[OF True] image_subsetI, simp)
   also have "... = char R"
     unfolding char_def by simp
   also have "... < card A"
     unfolding A_def by simp
   finally have "card (int_embed R ` A) < card A" by simp
   hence "\<not>inj_on (int_embed R) A"
     using pigeonhole by simp
-  then obtain x y where xy: 
+  then obtain x y where xy:
     "x \<in> A" "y \<in> A" "x \<noteq> y" "int_embed R x = int_embed R y"
     unfolding inj_on_def by auto
   define v where "v = nat (max x y - min x y)"
   have a:"int_embed R v = \<zero>"
     using xy int_embed_closed
     by (cases "x < y", simp_all add:int_embed_diff v_def)
   moreover have "v > 0"
     using xy by (cases "x < y", simp_all add:v_def)
   ultimately have "char R \<le> v" using char_bound by simp
   moreover have "v \<le> char R"
     using xy v_def A_def by (cases "x < y", simp_all)
   ultimately have "char R = v" by simp
   then show ?thesis using a by simp
 next
   case False
-  hence "char R = 0" 
+  hence "char R = 0"
     unfolding char_def by simp
   then show ?thesis by (simp add:int_embed_zero)
 qed
 
 lemma (in ring) embed_char_eq_0_iff:
   fixes n :: int
   shows "int_embed R n = \<zero> \<longleftrightarrow> char R dvd n"
 proof (cases "char R > 0")
   case True
   define r where "r = n mod char R"
   define s where "s = n div char R"
-  have rs: "r < char R" "r \<ge> 0" "n = r + s * char R" 
+  have rs: "r < char R" "r \<ge> 0" "n = r + s * char R"
     using True by (simp_all add:r_def s_def)
 
   have "int_embed R n = int_embed R r"
     using int_embed_closed unfolding rs(3)
     by (simp add: int_embed_add  int_embed_mult embed_char_eq_0)
 
   moreover have "nat r < char R" using rs by simp
   hence "int_embed R (nat r) \<noteq> \<zero> \<or> nat r = 0"
     using True char_bound not_less by blast
   hence "int_embed R r \<noteq> \<zero> \<or> r = 0"
     using rs by simp
 
   ultimately have "int_embed R n = \<zero> \<longleftrightarrow> r = 0"
     using int_embed_zero by auto
   also have "r = 0 \<longleftrightarrow> char R dvd n"
     using r_def by auto
   finally show ?thesis by simp
 next
   case False
   hence "char R = 0" by simp
   hence a:"x > 0 \<Longrightarrow> int_embed R (int x) \<noteq> \<zero>" for x
     using char_bound by auto
 
   have c:"int_embed R (abs x) \<noteq> \<zero> \<longleftrightarrow> int_embed R x \<noteq> \<zero>" for x
     using int_embed_closed
     by (cases "x > 0", simp, simp add:int_embed_inv)
-  
+
   have "int_embed R x \<noteq> \<zero>" if b:"x \<noteq> 0" for x
   proof -
     have "nat (abs x) > 0" using b by simp
     hence "int_embed R (nat (abs x)) \<noteq> \<zero>"
       using a by blast
     hence "int_embed R (abs x) \<noteq> \<zero>" by simp
     thus ?thesis using c by simp
   qed
-  hence "int_embed R n = \<zero> \<longleftrightarrow> n = 0" 
+  hence "int_embed R n = \<zero> \<longleftrightarrow> n = 0"
     using int_embed_zero by auto
   also have "n = 0 \<longleftrightarrow> char R dvd n" using False by simp
   finally show ?thesis by simp
 qed
 
 text \<open>This result can be found in \<^cite>\<open>\<open>Theorem 1.44\<close> in "lidl1986"\<close>.\<close>
 
 lemma (in domain) characteristic_is_prime:
   assumes "char R > 0"
   shows "prime (char R)"
 proof (rule ccontr)
   have "\<not>(char R = 1)"
     using embed_char_eq_0 int_embed_one by auto
   hence "\<not>(char R dvd 1)" using assms(1) by simp
   moreover assume "\<not>(prime (char R))"
   hence "\<not>(irreducible (char R))"
     using irreducible_imp_prime_elem_gcd prime_elem_nat_iff by blast
-  ultimately obtain p q where pq_def: "p * q = char R" "p > 1" "q > 1" 
+  ultimately obtain p q where pq_def: "p * q = char R" "p > 1" "q > 1"
     using assms
     unfolding Factorial_Ring.irreducible_def by auto
   have "int_embed R p \<otimes> int_embed R q = \<zero>"
-    using embed_char_eq_0 pq_def 
+    using embed_char_eq_0 pq_def
     by (subst int_embed_mult[symmetric]) (metis of_nat_mult)
   hence "int_embed R p = \<zero> \<or> int_embed R q = \<zero>"
     using integral int_embed_closed by simp
   hence "p*q \<le> p \<or> p*q \<le> q"
     using char_bound pq_def by auto
   thus "False"
     using pq_def(2,3) by simp
 qed
 
 lemma (in ring) char_ring_is_subring:
   "subring (char_subring R) R"
 proof -
   have "subring (int_embed R ` carrier int_ring) R"
     by (intro ring.carrier_is_subring int.ring_axioms
-        ring_hom_ring.img_is_subring[OF int_embed_ring_hom]) 
+        ring_hom_ring.img_is_subring[OF int_embed_ring_hom])
   thus ?thesis by simp
 qed
 
 lemma (in cring) char_ring_is_subcring:
   "subcring (char_subring R) R"
   using subcringI'[OF char_ring_is_subring] by auto
 
 lemma (in domain) char_ring_is_subdomain:
   "subdomain (char_subring R) R"
   using subdomainI'[OF char_ring_is_subring] by auto
 
 lemma image_set_eqI:
   assumes "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
-  assumes "\<And>x. x \<in> B \<Longrightarrow> g x \<in> A \<and> f (g x) = x" 
+  assumes "\<And>x. x \<in> B \<Longrightarrow> g x \<in> A \<and> f (g x) = x"
   shows  "f ` A = B"
   using assms by force
 
 text \<open>This is the binomial expansion theorem for commutative rings.\<close>
 
 lemma (in cring) binomial_expansion:
   fixes n :: nat
   assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
-  shows "(x \<oplus> y) [^] n = 
-    (\<Oplus>k \<in> {..n}. int_embed R (n choose k) \<otimes> x [^] k \<otimes> y [^] (n-k))" 
+  shows "(x \<oplus> y) [^] n =
+    (\<Oplus>k \<in> {..n}. int_embed R (n choose k) \<otimes> x [^] k \<otimes> y [^] (n-k))"
 proof -
   define A where "A = (\<lambda>k. {A. A \<subseteq> {..<n} \<and> card A = k})"
 
-  have fin_A: "finite (A i)" for i 
+  have fin_A: "finite (A i)" for i
     unfolding A_def by simp
-  have disj_A: "pairwise (\<lambda>i j. disjnt (A i) (A j)) {..n}" 
+  have disj_A: "pairwise (\<lambda>i j. disjnt (A i) (A j)) {..n}"
     unfolding pairwise_def disjnt_def A_def by auto
-  have card_A: "B \<in> A i \<Longrightarrow> card B = i" if " i \<in> {..n}" for i B 
+  have card_A: "B \<in> A i \<Longrightarrow> card B = i" if " i \<in> {..n}" for i B
     unfolding A_def by simp
-  have card_A2: "card (A i) = (n choose i)" if "i \<in> {..n}" for i 
+  have card_A2: "card (A i) = (n choose i)" if "i \<in> {..n}" for i
     unfolding A_def using n_subsets[where A="{..<n}"] by simp
 
   have card_bound: "card A \<le> n"
-    if "A \<subseteq> {..<n}" for n A 
+    if "A \<subseteq> {..<n}" for n A
     by (metis card_lessThan finite_lessThan card_mono that)
   have card_insert: "card (insert n A) = card A + 1"
-    if "A \<subseteq> {..<(n::nat)}" for n A 
+    if "A \<subseteq> {..<(n::nat)}" for n A
     using finite_subset that by (subst card_insert_disjoint, auto)
 
-  have embed_distr: "[m] \<cdot> y = int_embed R (int m) \<otimes> y" 
+  have embed_distr: "[m] \<cdot> y = int_embed R (int m) \<otimes> y"
     if "y \<in> carrier R" for m y
     unfolding int_embed_def add_pow_def using that
     by (simp add:add_pow_def[symmetric] int_pow_int add_pow_ldistr)
 
-  have "(x \<oplus> y) [^] n = 
+  have "(x \<oplus> y) [^] n =
     (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A))"
   proof (induction n)
     case 0
     then show ?case by simp
   next
     case (Suc n)
-    have s1: 
-      "insert n ` Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<in> A}" 
-      by (intro image_set_eqI[where g="\<lambda>x. x \<inter> {..<n}"], auto) 
+    have s1:
+      "insert n ` Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<in> A}"
+      by (intro image_set_eqI[where g="\<lambda>x. x \<inter> {..<n}"], auto)
     have s2:
-      "Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}" 
+      "Pow {..<n} = {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}"
       using lessThan_Suc by auto
 
     have "(x \<oplus> y) [^] Suc n = (x \<oplus> y) [^] n \<otimes> (x \<oplus> y)" by simp
-    also have "... = 
-      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes> 
+    also have "... =
+      (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes>
       (x \<oplus> y)"
       by (subst Suc, simp)
-    also have "... = 
+    also have "... =
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes> x \<oplus>
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A)) \<otimes> y"
       by (subst r_distr, auto)
-    also have "... = 
+    also have "... =
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A) \<otimes> x) \<oplus>
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A) \<otimes> y)"
       by (simp add:finsum_ldistr)
-    also have "... = 
+    also have "... =
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A+1) \<otimes> y [^] (n-card A)) \<oplus>
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n-card A+1))"
-      using m_assoc m_comm 
+      using m_assoc m_comm
       by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong', auto)
-    also have "... = 
-      (\<Oplus>A \<in> Pow {..<n}. x [^] (card (insert n A)) 
+    also have "... =
+      (\<Oplus>A \<in> Pow {..<n}. x [^] (card (insert n A))
         \<otimes> y [^] (n+1-card (insert n A))) \<oplus>
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
       using finite_subset card_bound card_insert Suc_diff_le
       by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong', simp_all)
-    also have "... = 
-      (\<Oplus>A \<in> insert n ` Pow {..<n}. x [^] (card A) 
+    also have "... =
+      (\<Oplus>A \<in> insert n ` Pow {..<n}. x [^] (card A)
         \<otimes> y [^] (n+1-card A)) \<oplus>
       (\<Oplus>A \<in> Pow {..<n}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
-      by (subst finsum_reindex, auto simp add:inj_on_def) 
-    also have "... = 
-      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<in> A}. 
+      by (subst finsum_reindex, auto simp add:inj_on_def)
+    also have "... =
+      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<in> A}.
         x [^] (card A) \<otimes> y [^] (n+1-card A)) \<oplus>
-      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}. 
+      (\<Oplus>A \<in> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}.
         x [^] (card A) \<otimes> y [^] (n+1-card A))"
       by (intro arg_cong2[where f="(\<oplus>)"] finsum_cong' s1 s2, simp_all)
-    also have "... = (\<Oplus>A \<in> 
-      {A. A \<subseteq> {..<n+1} \<and> n \<in> A} \<union> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}. 
+    also have "... = (\<Oplus>A \<in>
+      {A. A \<subseteq> {..<n+1} \<and> n \<in> A} \<union> {A. A \<subseteq> {..<n+1} \<and> n \<notin> A}.
         x [^] (card A) \<otimes> y [^] (n+1-card A))"
       by (subst finsum_Un_disjoint, auto)
-    also have "... = 
+    also have "... =
       (\<Oplus>A \<in> Pow {..<n+1}. x [^] (card A) \<otimes> y [^] (n+1-card A))"
       by (intro finsum_cong', auto)
     finally show ?case by simp
   qed
-  also have "... = 
+  also have "... =
     (\<Oplus>A \<in> (\<Union> (A ` {..n})). x [^] (card A) \<otimes> y [^] (n-card A))"
     using card_bound by (intro finsum_cong', auto simp add:A_def)
-  also have "... = 
+  also have "... =
     (\<Oplus> k \<in> {..n}. (\<Oplus> A \<in> A k. x [^] (card A) \<otimes> y [^] (n-card A)))"
     using fin_A disj_A by (subst add.finprod_UN_disjoint, auto)
   also have "... = (\<Oplus> k \<in> {..n}. (\<Oplus> A \<in> A k. x [^] k \<otimes> y [^] (n-k)))"
     using card_A by (intro finsum_cong', auto)
-  also have "... = 
+  also have "... =
     (\<Oplus> k \<in> {..n}. int_embed R (card (A k)) \<otimes> x [^] k \<otimes> y [^] (n-k))"
     using int_embed_closed
     by (subst add.finprod_const, simp_all add:embed_distr m_assoc)
-  also have "... = 
+  also have "... =
     (\<Oplus> k \<in> {..n}. int_embed R (n choose k) \<otimes> x [^] k \<otimes> y [^] (n-k))"
     using int_embed_closed card_A2 by (intro finsum_cong', simp_all)
   finally show ?thesis by simp
 qed
 
 lemma bin_prime_factor:
   assumes "prime p"
   assumes "k > 0" "k < p"
   shows "p dvd (p choose k)"
 proof -
-  have "p dvd fact p" 
+  have "p dvd fact p"
     using assms(1) prime_dvd_fact_iff by auto
   hence "p dvd fact k * fact (p - k) * (p choose k)"
     using binomial_fact_lemma assms by simp
   hence "p dvd fact k \<or> p dvd fact (p-k) \<or> p dvd (p choose k)"
     by (simp add: assms(1) prime_dvd_mult_eq_nat)
   thus "p dvd (p choose k)"
     using assms(1,2,3) prime_dvd_fact_iff by auto
 qed
 
 theorem (in domain) freshmans_dream:
   assumes "char R > 0"
   assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
-  shows "(x \<oplus> y) [^] (char R) = x [^] char R \<oplus> y [^] char R" 
+  shows "(x \<oplus> y) [^] (char R) = x [^] char R \<oplus> y [^] char R"
     (is "?lhs = ?rhs")
 proof -
   have c:"prime (char R)"
     using assms(1) characteristic_is_prime by auto
-  have a:"int_embed R (char R choose i) = \<zero>" 
+  have a:"int_embed R (char R choose i) = \<zero>"
     if "i \<in> {..char R} - {0, char R}" for i
   proof -
     have "i > 0" "i < char R" using that by auto
     hence "char R dvd char R choose i"
       using c bin_prime_factor by simp
     thus ?thesis using embed_char_eq_0_iff by simp
   qed
 
-  have "?lhs = (\<Oplus>k \<in> {..char R}. int_embed R (char R choose k) 
+  have "?lhs = (\<Oplus>k \<in> {..char R}. int_embed R (char R choose k)
     \<otimes> x [^] k \<otimes> y [^] (char R-k))"
     using binomial_expansion[OF assms(2,3)] by simp
-  also have "... = (\<Oplus>k \<in> {0,char R}.int_embed R (char R choose k) 
+  also have "... = (\<Oplus>k \<in> {0,char R}.int_embed R (char R choose k)
     \<otimes> x [^] k \<otimes> y [^] (char R-k))"
     using a int_embed_closed
     by (intro add.finprod_mono_neutral_cong_right, simp, simp_all)
   also have "... = ?rhs"
     using int_embed_closed assms(1) by (simp add:int_embed_one a_comm)
   finally show ?thesis by simp
 qed
 
 text \<open>The following theorem is somtimes called Freshman's dream for obvious reasons,
 it can be found in Lidl and Niederreiter~\<^cite>\<open>\<open>Theorem 1.46\<close> in "lidl1986"\<close>.\<close>
 
 lemma (in domain) freshmans_dream_ext:
   fixes m
   assumes "char R > 0"
   assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
-  defines "n \<equiv> char R^m" 
+  defines "n \<equiv> char R^m"
   shows "(x \<oplus> y) [^] n = x [^] n \<oplus> y [^] n"
     (is "?lhs = ?rhs")
   unfolding n_def
 proof (induction m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
-  have "(x \<oplus> y) [^] (char R^(m+1)) = 
+  have "(x \<oplus> y) [^] (char R^(m+1)) =
     (x \<oplus> y) [^] (char R^m * char R)"
     by (simp add:mult.commute)
   also have "... = ((x \<oplus> y) [^] (char R^m)) [^] char R"
     using nat_pow_pow by simp
   also have "... = (x [^] (char R^m) \<oplus> y [^] (char R^m)) [^] char R"
     by (subst Suc, simp)
-  also have "... = 
+  also have "... =
     (x [^] (char R^m)) [^] char R \<oplus> (y [^] (char R^m)) [^] char R"
     by (subst freshmans_dream[OF assms(1), symmetric], simp_all)
-  also have "... = 
+  also have "... =
     x [^] (char R^m * char R) \<oplus> y [^] (char R^m * char R)"
     by (simp add:nat_pow_pow)
   also have "... = x [^] (char R^Suc m) \<oplus> y [^] (char R^Suc m)"
     by (simp add:mult.commute)
   finally show ?case by simp
 qed
 
 text \<open>The following is a generalized version of the Frobenius homomorphism. The classic version
 of the theorem is the case where @{term "(k::nat) = 1"}.\<close>
 
 theorem (in domain) frobenius_hom:
   assumes "char R  > 0"
   assumes "m = char R ^ k"
   shows "ring_hom_cring R R (\<lambda>x. x [^] m)"
 proof -
-  have a:"(x \<otimes> y) [^] m = x [^] m \<otimes> y [^] m" 
-    if b:"x \<in> carrier R" "y \<in> carrier R" for x y 
+  have a:"(x \<otimes> y) [^] m = x [^] m \<otimes> y [^] m"
+    if b:"x \<in> carrier R" "y \<in> carrier R" for x y
     using b nat_pow_distrib by simp
   have b:"(x \<oplus> y) [^] m = x [^] m \<oplus> y [^] m"
-    if b:"x \<in> carrier R" "y \<in> carrier R" for x y 
-    unfolding assms(2) freshmans_dream_ext[OF assms(1) b] 
+    if b:"x \<in> carrier R" "y \<in> carrier R" for x y
+    unfolding assms(2) freshmans_dream_ext[OF assms(1) b]
     by simp
 
   have "ring_hom_ring R R (\<lambda>x. x [^] m)"
-    by  (intro ring_hom_ringI a b ring_axioms, simp_all) 
+    by  (intro ring_hom_ringI a b ring_axioms, simp_all)
 
   thus "?thesis"
     using RingHom.ring_hom_cringI is_cring by blast
 qed
 
 lemma (in domain) char_ring_is_subfield:
   assumes "char R > 0"
   shows "subfield (char_subring R) R"
 proof -
   interpret d:domain "R \<lparr> carrier := char_subring R \<rparr>"
     using char_ring_is_subdomain subdomain_is_domain by simp
 
-  have "finite (char_subring R)" 
+  have "finite (char_subring R)"
     using char_def assms by (metis card_ge_0_finite)
-  hence "Units (R \<lparr> carrier := char_subring R \<rparr>) 
+  hence "Units (R \<lparr> carrier := char_subring R \<rparr>)
     = char_subring R - {\<zero>}"
     using d.finite_domain_units by simp
 
   thus ?thesis
     using subfieldI[OF char_ring_is_subcring] by simp
 qed
 
-lemma card_lists_length_eq': 
+lemma card_lists_length_eq':
   fixes A :: "'a set"
-  shows "card {xs. set xs \<subseteq> A \<and> length xs = n} = card A ^ n" 
+  shows "card {xs. set xs \<subseteq> A \<and> length xs = n} = card A ^ n"
 proof (cases "finite A")
   case True
   then show ?thesis using card_lists_length_eq by auto
 next
   case False
   hence inf_A: "infinite A" by simp
   show ?thesis
   proof (cases "n = 0")
     case True
     hence "card {xs. set xs \<subseteq> A \<and> length xs = n} = card {([] :: 'a list)}"
       by (intro arg_cong[where f="card"], auto simp add:set_eq_iff)
     also have "... = 1" by simp
     also have "... = card A^n" using True inf_A by simp
-    finally show ?thesis by simp 
+    finally show ?thesis by simp
   next
     case False
-    hence "inj (replicate n)" 
+    hence "inj (replicate n)"
       by (meson inj_onI replicate_eq_replicate)
-    hence "inj_on (replicate n) A" using inj_on_subset 
-      by (metis subset_UNIV) 
+    hence "inj_on (replicate n) A" using inj_on_subset
+      by (metis subset_UNIV)
     hence "infinite (replicate n ` A)"
       using inf_A finite_image_iff by auto
-    moreover have 
+    moreover have
       "replicate n ` A \<subseteq> {xs. set xs \<subseteq> A \<and> length xs  = n}"
       by (intro image_subsetI, auto)
     ultimately have "infinite {xs. set xs \<subseteq> A \<and> length xs  = n}"
       using infinite_super by auto
     hence "card {xs. set xs \<subseteq> A \<and> length xs  = n} = 0" by simp
     then show ?thesis using inf_A False by simp
   qed
 qed
 
 lemma (in ring) card_span:
   assumes "subfield K R"
   assumes "independent K w"
   assumes "set w \<subseteq> carrier R"
   shows "card (Span K w) = card K^(length w)"
 proof -
   define A where "A = {x. set x \<subseteq> K \<and> length x = length w}"
   define f where "f = (\<lambda>x. combine x w)"
 
   have "x \<in> f ` A" if a:"x \<in> Span K w" for x
   proof -
     obtain y where "y \<in> A" "x = f y"
       unfolding A_def f_def
       using unique_decomposition[OF assms(1,2) a] by auto
     thus ?thesis by simp
   qed
   moreover have "f x \<in> Span K w" if a: "x \<in> A" for x
     using Span_eq_combine_set[OF assms(1,3)] a
     unfolding A_def f_def by auto
   ultimately have b:"Span K w = f ` A" by auto
 
   have "False" if a: "x \<in> A" "y \<in> A" "f x = f y" "x \<noteq> y" for x y
   proof -
     have "f x \<in> Span K w" using b a by simp
-    thus "False" 
+    thus "False"
       using a unique_decomposition[OF assms(1,2)]
       unfolding f_def A_def by blast
   qed
-  hence f_inj: "inj_on f A" 
+  hence f_inj: "inj_on f A"
     unfolding inj_on_def by auto
 
   have "card (Span K w) = card (f ` A)" using b by simp
-  also have "... = card A" by (intro card_image f_inj) 
+  also have "... = card A" by (intro card_image f_inj)
   also have "... = card K^length w"
     unfolding A_def by (intro card_lists_length_eq')
   finally show ?thesis by simp
 qed
 
 lemma (in ring) finite_carr_imp_char_ge_0:
   assumes "finite (carrier R)"
   shows "char R > 0"
 proof -
   have "char_subring R \<subseteq> carrier R"
     using int_embed_closed by auto
   hence "finite (char_subring R)"
     using finite_subset assms by auto
   hence "card (char_subring R) > 0"
     using card_range_greater_zero by simp
-  thus "char R > 0" 
+  thus "char R > 0"
     unfolding char_def by simp
 qed
 
 lemma (in ring) char_consistent:
   assumes "subring H R"
   shows "char (R \<lparr> carrier := H \<rparr>) = char R"
 proof -
   show ?thesis
     using int_embed_consistent[OF assms(1)]
     unfolding char_def by simp
 qed
 
 lemma (in ring_hom_ring) char_consistent:
   assumes "inj_on h (carrier R)"
   shows "char R = char S"
 proof -
   have a:"h (int_embed R (int n)) = int_embed S (int n)" for n
     using R.int_embed_range[OF R.carrier_is_subring]
     using R.int_embed_range[OF R.carrier_is_subring]
     using S.int_embed_one R.int_embed_one
     using S.int_embed_zero R.int_embed_zero
     using S.int_embed_add R.int_embed_add
     by (induction n, simp_all)
 
   have b:"h (int_embed R (-(int n))) = int_embed S (-(int n))" for n
     using R.int_embed_range[OF R.carrier_is_subring]
     using S.int_embed_range[OF S.carrier_is_subring] a
     by (simp add:R.int_embed_inv S.int_embed_inv)
 
   have c:"h (int_embed R n) = int_embed S n" for n
   proof (cases "n \<ge> 0")
     case True
     then obtain m where "n = int m"
       using nonneg_int_cases by auto
-    then show ?thesis 
+    then show ?thesis
       by (simp add:a)
   next
     case False
     hence "n \<le> 0" by simp
-    then obtain m where "n = -int m" 
+    then obtain m where "n = -int m"
       using nonpos_int_cases by auto
     then show ?thesis by (simp add:b)
   qed
 
   have "char S = card (h ` char_subring R)"
     unfolding char_def image_image c by simp
   also have "... = card (char_subring R)"
     using R.int_embed_range[OF R.carrier_is_subring]
-    by (intro card_image inj_on_subset[OF assms(1)]) auto 
+    by (intro card_image inj_on_subset[OF assms(1)]) auto
   also have "... = char R" unfolding char_def by simp
   finally show ?thesis
     by simp
 qed
 
-definition char_iso :: "_ \<Rightarrow> int set \<Rightarrow> 'a" 
+definition char_iso :: "_ \<Rightarrow> int set \<Rightarrow> 'a"
   where "char_iso R x = the_elem (int_embed R ` x)"
 
 text \<open>The function @{term "char_iso R"} denotes the isomorphism between @{term "ZFact (char R)"} and
 the characteristic subring.\<close>
 
-lemma (in ring) char_iso: "char_iso R \<in> 
+lemma (in ring) char_iso: "char_iso R \<in>
   ring_iso (ZFact (char R)) (R\<lparr>carrier := char_subring R\<rparr>)"
 proof -
   interpret h: ring_hom_ring "int_ring" "R" "int_embed R"
     using int_embed_ring_hom by simp
 
   have "a_kernel \<Z> R (int_embed R) = {x. int_embed R x = \<zero>}"
     unfolding a_kernel_def kernel_def by simp
   also have "... = {x. char R dvd x}"
     using embed_char_eq_0_iff by simp
-  also have "... = PIdl\<^bsub>\<Z>\<^esub> (int (char R))" 
+  also have "... = PIdl\<^bsub>\<Z>\<^esub> (int (char R))"
     unfolding cgenideal_def by auto
   also have "... = Idl\<^bsub>\<Z>\<^esub> {int (char R)}"
     using int.cgenideal_eq_genideal by simp
   finally have a:"a_kernel \<Z> R (int_embed R) = Idl\<^bsub>\<Z>\<^esub> {int (char R)}"
     by simp
   show  "?thesis"
     unfolding char_iso_def ZFact_def a[symmetric]
     by (intro h.FactRing_iso_set_aux)
 qed
 
 text \<open>The size of a finite field must be a prime power.
 This can be found in Ireland and Rosen~\<^cite>\<open>\<open>Proposition 7.1.3\<close> in "ireland1982"\<close>.\<close>
 
 theorem (in finite_field) finite_field_order:
   "\<exists>n. order R = char R ^ n \<and> n > 0"
 proof -
   have a:"char R > 0"
     using finite_carr_imp_char_ge_0[OF finite_carrier]
     by simp
   let ?CR = "char_subring R"
 
   obtain v where v_def: "set v = carrier R"
     using finite_carrier finite_list by auto
   hence b:"set v \<subseteq> carrier R" by auto
 
   have "carrier R = set v" using v_def by simp
   also have "... \<subseteq> Span ?CR v"
     using Span_base_incl[OF char_ring_is_subfield[OF a] b] by simp
   finally have "carrier R \<subseteq> Span ?CR v" by simp
   moreover have "Span ?CR v \<subseteq> carrier R"
     using int_embed_closed v_def by (intro Span_in_carrier, auto)
   ultimately have Span_v: "Span ?CR v = carrier R" by simp
 
-  obtain w where w_def: 
-    "set w \<subseteq> carrier R" 
-    "independent ?CR w" 
+  obtain w where w_def:
+    "set w \<subseteq> carrier R"
+    "independent ?CR w"
     "Span ?CR v = Span ?CR w"
     using b filter_base[OF char_ring_is_subfield[OF a]]
     by metis
 
   have Span_w: "Span ?CR w = carrier R"
     using w_def(3) Span_v by simp
 
   hence "order R = card (Span ?CR w)" by (simp add:order_def)
   also have "... = card ?CR^length w"
     by (intro card_span char_ring_is_subfield[OF a] w_def(1,2))
   finally have c:
     "order R = char R^(length w)"
     by (simp add:char_def)
   have "length w > 0"
     using finite_field_min_order c by auto
   thus ?thesis using c by auto
 qed
 
 end
diff --git a/thys/Finite_Fields/document/root.bib b/thys/Finite_Fields/document/root.bib
--- a/thys/Finite_Fields/document/root.bib
+++ b/thys/Finite_Fields/document/root.bib
@@ -1,42 +1,53 @@
 @book{ireland1982,
   author    = {Kenneth Ireland and
                Michael Rosen},
   title     = {A classical introduction to modern number theory},
   series    = {Graduate texts in mathematics},
   volume    = {84},
   publisher = {Springer},
   year      = {1982},
   isbn      = {978-0-387-90625-6},
   timestamp = {Fri, 28 Jun 2019 12:45:52 +0200},
   biburl    = {https://dblp.org/rec/books/daglib/0068082.bib},
   bibsource = {dblp computer science bibliography, https://dblp.org}
 }
 
 @book{lidl1986,
 author = {Lidl, Rudolf and Niederreiter, Harald},
 title = {Introduction to Finite Fields and Their Applications},
 year = {1986},
 isbn = {0521307066},
 publisher = {Cambridge University Press},
 address = {USA}
 }
 
 @article{chebolu2010,
   title={Counting Irreducible Polynomials over Finite Fields Using the Inclusion-Exclusion Principle},
   author={Sunil K. Chebolu and J{\'a}n Min{\'a}{\v{c}}},
   journal={Mathematics Magazine},
   year={2010},
   volume={84},
   pages={369 - 371}
 }
 
 @article{Dirichlet_Series-AFP,
   author  = {Manuel Eberl},
   title   = {Dirichlet Series},
   journal = {Archive of Formal Proofs},
   month   = oct,
   year    = 2017,
   note    = {\url{https://isa-afp.org/entries/Dirichlet_Series.html},
             Formal proof development},
   ISSN    = {2150-914x},
-}
\ No newline at end of file
+}
+
+@article{rabin1980,
+  author = {Rabin, Michael O.},
+  title = {Probabilistic Algorithms in Finite Fields},
+  journal = {SIAM Journal on Computing},
+  volume = {9},
+  number = {2},
+  pages = {273-280},
+  year = {1980},
+  doi = {10.1137/0209024},
+}
diff --git a/thys/Finite_Fields/document/root.tex b/thys/Finite_Fields/document/root.tex
--- a/thys/Finite_Fields/document/root.tex
+++ b/thys/Finite_Fields/document/root.tex
@@ -1,37 +1,37 @@
 \documentclass[11pt,a4paper]{article}
 \usepackage[T1]{fontenc}
 \usepackage{isabelle,isabellesym}
 \usepackage{amssymb}
 \usepackage{pdfsetup}
 \urlstyle{rm}
 \isabellestyle{it}
 
 \begin{document}
 
 \title{Finite Fields}
 \author{Emin Karayel}
 \maketitle
 
 \abstract{This entry formalizes the classification of the finite fields (also called Galois fields):
 For each prime power $p^n$ there exists exactly one (up to isomorphisms) finite field of that size
 and there are no other finite fields.
-The derivation includes a formalization of the characteristic of rings, the Frobenius endomorphism, 
-formal differentiation for polynomials in HOL-Algebra and Gauss' formula for the number of
-monic irreducible polynomials over finite fields:
+The derivation includes a formalization of the characteristic of rings, the Frobenius endomorphism,
+formal differentiation for polynomials in HOL-Algebra, Rabin's test for the irreducibility of
+polynomials and Gauss' formula for the number of monic irreducible polynomials over finite fields:
 \[
 \frac{1}{n} \sum_{d | n} \mu(d) p^{n/d} \textrm{.}
 \]
-The proofs are based on the books from Ireland and Rosen~\cite{ireland1982}, as well as,
-Lidl and Niederreiter~\cite{lidl1986}.
+The proofs are based on the books and publications from Ireland and Rosen~\cite{ireland1982},
+Rabin~\cite{rabin1980} as well as, Lidl and Niederreiter~\cite{lidl1986}.
 }
-  
+
 \parindent 0pt\parskip 0.5ex
 
 \tableofcontents
 
 \input{session}
 
 \bibliographystyle{abbrv}
 \bibliography{root}
 
 \end{document}
\ No newline at end of file
diff --git a/thys/Frequency_Moments/Frequency_Moment_0.thy b/thys/Frequency_Moments/Frequency_Moment_0.thy
--- a/thys/Frequency_Moments/Frequency_Moment_0.thy
+++ b/thys/Frequency_Moments/Frequency_Moment_0.thy
@@ -1,1314 +1,1314 @@
 section \<open>Frequency Moment $0$\label{sec:f0}\<close>
 
 theory Frequency_Moment_0
   imports
     Frequency_Moments_Preliminary_Results
     Median_Method.Median 
     K_Smallest 
     Universal_Hash_Families.Carter_Wegman_Hash_Family
     Frequency_Moments
     Landau_Ext 
     Product_PMF_Ext
     Universal_Hash_Families.Universal_Hash_Families_More_Finite_Fields
 begin
 
 text \<open>This section contains a formalization of a new algorithm for the zero-th frequency moment
 inspired by ideas described in \<^cite>\<open>"baryossef2002"\<close>.
 It is a KMV-type ($k$-minimum value) algorithm with a rounding method and matches the space complexity 
 of the best algorithm described in \<^cite>\<open>"baryossef2002"\<close>.
 
 In addition to the Isabelle proof here, there is also an informal hand-written proof in
 Appendix~\ref{sec:f0_proof}.\<close>
 
 type_synonym f0_state = "nat \<times> nat \<times> nat \<times> nat \<times> (nat \<Rightarrow> nat list) \<times> (nat \<Rightarrow> float set)"
 
 definition hash where "hash p = ring.hash (mod_ring p)"
 
 fun f0_init :: "rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> f0_state pmf" where
   "f0_init \<delta> \<epsilon> n =
     do {
       let s = nat \<lceil>-18 * ln (real_of_rat \<epsilon>)\<rceil>;
       let t = nat \<lceil>80 / (real_of_rat \<delta>)\<^sup>2\<rceil>;
       let p = prime_above (max n 19);
       let r = nat (4 * \<lceil>log 2 (1 / real_of_rat \<delta>)\<rceil> + 23); 
       h \<leftarrow> prod_pmf {..<s} (\<lambda>_. pmf_of_set (bounded_degree_polynomials (mod_ring p) 2));
       return_pmf (s, t, p, r, h, (\<lambda>_ \<in> {0..<s}. {}))
     }"
 
 fun f0_update :: "nat \<Rightarrow> f0_state \<Rightarrow> f0_state pmf" where
   "f0_update x (s, t, p, r, h, sketch) = 
     return_pmf (s, t, p, r, h, \<lambda>i \<in> {..<s}.
       least t (insert (float_of (truncate_down r (hash p x (h i)))) (sketch i)))"
 
 fun f0_result :: "f0_state \<Rightarrow> rat pmf" where
   "f0_result (s, t, p, r, h, sketch) = return_pmf (median s (\<lambda>i \<in> {..<s}.
       (if card (sketch i) < t then of_nat (card (sketch i)) else
         rat_of_nat t* rat_of_nat p / rat_of_float (Max (sketch i)))
     ))"
 
 fun f0_space_usage :: "(nat \<times> rat \<times> rat) \<Rightarrow> real" where
   "f0_space_usage (n, \<epsilon>, \<delta>) = (
     let s = nat \<lceil>-18 * ln (real_of_rat \<epsilon>)\<rceil> in 
     let r = nat (4 * \<lceil>log 2 (1 / real_of_rat \<delta>)\<rceil> + 23) in
     let t = nat \<lceil>80 / (real_of_rat \<delta>)\<^sup>2 \<rceil> in
     6 +
     2 * log 2 (real s + 1) +
     2 * log 2 (real t + 1) +
     2 * log 2 (real n + 21) +
     2 * log 2 (real r + 1) +
     real s * (5 + 2 * log 2 (21 + real n) +
     real t * (13 + 4 * r + 2 * log 2 (log 2 (real n + 13)))))"
 
 definition encode_f0_state :: "f0_state \<Rightarrow> bool list option" where
   "encode_f0_state = 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>s. 
     N\<^sub>e \<times>\<^sub>e (
     N\<^sub>e \<Join>\<^sub>e (\<lambda>p. 
     N\<^sub>e \<times>\<^sub>e ( 
     ([0..<s] \<rightarrow>\<^sub>e (P\<^sub>e p 2)) \<times>\<^sub>e
     ([0..<s] \<rightarrow>\<^sub>e (S\<^sub>e F\<^sub>e))))))"
 
 lemma "inj_on encode_f0_state (dom encode_f0_state)"
 proof -
   have "is_encoding encode_f0_state" 
     unfolding encode_f0_state_def
     by (intro dependent_encoding exp_golomb_encoding poly_encoding fun_encoding set_encoding float_encoding)
   thus ?thesis  by (rule encoding_imp_inj)
 qed
 
 context
   fixes \<epsilon> \<delta> :: rat
   fixes n :: nat
   fixes as :: "nat list"
   fixes result
   assumes \<epsilon>_range: "\<epsilon> \<in> {0<..<1}"
   assumes \<delta>_range: "\<delta> \<in> {0<..<1}"
   assumes as_range: "set as \<subseteq> {..<n}"
   defines "result \<equiv> fold (\<lambda>a state. state \<bind> f0_update a) as (f0_init \<delta> \<epsilon> n) \<bind> f0_result"
 begin  
 
 private definition t where "t = nat \<lceil>80 / (real_of_rat \<delta>)\<^sup>2\<rceil>"
 private lemma t_gt_0: "t > 0" using \<delta>_range by (simp add:t_def)
 
 private definition s where "s = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil>"
 private lemma s_gt_0: "s > 0" using \<epsilon>_range by (simp add:s_def)
 
 private definition p where "p = prime_above (max n 19)"
 
 private lemma p_prime:"Factorial_Ring.prime p"
   using p_def prime_above_prime by presburger
 
 private lemma p_ge_18: "p \<ge> 18"
 proof -
   have "p \<ge> 19" 
     by (metis p_def prime_above_lower_bound max.bounded_iff)
   thus ?thesis by simp
 qed
 
 private lemma p_gt_0: "p > 0" using p_ge_18 by simp
 private lemma p_gt_1: "p > 1" using p_ge_18 by simp
 
 private lemma n_le_p: "n \<le> p"
 proof -
   have "n \<le> max n 19" by simp
   also have "... \<le> p"
     unfolding p_def by (rule prime_above_lower_bound)
   finally show ?thesis by simp
 qed
 
 private lemma p_le_n: "p \<le> 2*n + 40"
 proof -
   have "p \<le> 2 * (max n 19) + 2"
     by (subst p_def, rule prime_above_upper_bound)
   also have "... \<le> 2 * n + 40"
     by (cases "n \<ge> 19", auto)
   finally show ?thesis by simp
 qed
 
 private lemma as_lt_p: "\<And>x. x \<in> set as \<Longrightarrow> x < p" 
   using as_range atLeastLessThan_iff
   by (intro order_less_le_trans[OF _ n_le_p]) blast
 
 private lemma as_subset_p: "set as \<subseteq> {..<p}"
    using as_lt_p  by (simp add: subset_iff)
 
 private definition r where "r = nat (4 * \<lceil>log 2 (1 / real_of_rat \<delta>)\<rceil> + 23)"
 
 private lemma r_bound: "4 * log 2 (1 / real_of_rat \<delta>) + 23 \<le> r"
 proof -
   have "0 \<le> log 2 (1 / real_of_rat \<delta>)" using \<delta>_range by simp 
   hence "0 \<le> \<lceil>log 2 (1 / real_of_rat \<delta>)\<rceil>" by simp
   hence "0 \<le> 4 * \<lceil>log 2 (1 / real_of_rat \<delta>)\<rceil> + 23"
     by (intro add_nonneg_nonneg mult_nonneg_nonneg, auto)
   thus ?thesis by (simp add:r_def)
 qed
 
 private lemma r_ge_23: "r \<ge> 23"
 proof -
   have "(23::real) = 0 + 23" by simp
   also have "... \<le> 4 * log 2 (1 / real_of_rat \<delta>) + 23" 
     using \<delta>_range by (intro add_mono mult_nonneg_nonneg, auto) 
   also have "... \<le> r" using r_bound by simp
   finally show "23 \<le> r" by simp
 qed
 
 private lemma two_pow_r_le_1: "0 < 1 - 2 powr - real r"
 proof -
   have a: "2 powr (0::real) = 1"
     by simp
   show ?thesis using r_ge_23 
     by (simp, subst a[symmetric], intro powr_less_mono, auto)
 qed
 
 interpretation carter_wegman_hash_family "mod_ring p" 2
   rewrites "ring.hash (mod_ring p) = Frequency_Moment_0.hash p"
   using carter_wegman_hash_familyI[OF mod_ring_is_field mod_ring_finite]
   using hash_def p_prime by auto
 
 private definition tr_hash where "tr_hash x \<omega> = truncate_down r (hash x \<omega>)"
 
 private definition sketch_rv where
   "sketch_rv \<omega> = least t ((\<lambda>x. float_of (tr_hash x \<omega>)) ` set as)"
 
 private definition estimate 
    where "estimate S = (if card S < t then of_nat (card S) else of_nat t * of_nat p / rat_of_float (Max S))"
 
 private definition sketch_rv' where "sketch_rv' \<omega> = least t ((\<lambda>x. tr_hash x \<omega>) ` set as)"
 private definition estimate' where "estimate' S = (if card S < t then real (card S) else real t * real p / Max S)"
 
 private definition \<Omega>\<^sub>0 where "\<Omega>\<^sub>0 = prod_pmf {..<s} (\<lambda>_. pmf_of_set space)"
 
 private lemma f0_alg_sketch:
   defines "sketch \<equiv> fold (\<lambda>a state. state \<bind> f0_update a) as (f0_init \<delta> \<epsilon> n)"
   shows "sketch = map_pmf (\<lambda>x. (s,t,p,r, x, \<lambda>i \<in> {..<s}. sketch_rv (x i))) \<Omega>\<^sub>0" 
   unfolding sketch_rv_def 
 proof (subst sketch_def, induction as rule:rev_induct)
   case Nil
   then show ?case
     by (simp add:s_def p_def[symmetric] map_pmf_def t_def r_def Let_def least_def restrict_def space_def \<Omega>\<^sub>0_def)
 next
   case (snoc x xs)
   let ?sketch = "\<lambda>\<omega> xs. least t ((\<lambda>a. float_of (tr_hash a \<omega>)) ` set xs)"
   have "fold (\<lambda>a state. state \<bind> f0_update a) (xs @ [x]) (f0_init \<delta> \<epsilon> n) =
      (map_pmf (\<lambda>\<omega>. (s, t, p, r, \<omega>, \<lambda>i \<in> {..<s}. ?sketch (\<omega> i) xs)) \<Omega>\<^sub>0) \<bind> f0_update x"
     by (simp add: restrict_def snoc del:f0_init.simps)
   also have "... = \<Omega>\<^sub>0 \<bind> (\<lambda>\<omega>. f0_update x (s, t, p, r, \<omega>, \<lambda>i\<in>{..<s}. ?sketch (\<omega> i) xs)) "
     by (simp add:map_pmf_def bind_assoc_pmf bind_return_pmf del:f0_update.simps)
   also have "... = map_pmf (\<lambda>\<omega>. (s, t, p, r, \<omega>, \<lambda>i\<in>{..<s}. ?sketch (\<omega> i) (xs@[x]))) \<Omega>\<^sub>0"
     by (simp add:least_insert map_pmf_def tr_hash_def cong:restrict_cong)
   finally show ?case by blast
 qed
 
 private lemma card_nat_in_ball:
   fixes x :: nat
   fixes q :: real
   assumes "q \<ge> 0"
   defines "A \<equiv> {k. abs (real x - real k) \<le> q \<and> k \<noteq> x}"
   shows "real (card A) \<le> 2 * q" and "finite A"
 proof -
   have a: "of_nat x \<in> {\<lceil>real x-q\<rceil>..\<lfloor>real x+q\<rfloor>}"
     using assms 
     by (simp add: ceiling_le_iff)
 
   have "card A = card (int ` A)"
     by (rule card_image[symmetric], simp)
   also have "... \<le> card ({\<lceil>real x-q\<rceil>..\<lfloor>real x+q\<rfloor>} - {of_nat x})"
     by (intro card_mono image_subsetI, simp_all add:A_def abs_le_iff, linarith)
   also have "... = card {\<lceil>real x-q\<rceil>..\<lfloor>real x+q\<rfloor>} - 1"
     by (rule card_Diff_singleton, rule a)
   also have "... = int (card {\<lceil>real x-q\<rceil>..\<lfloor>real x+q\<rfloor>}) - int 1"
     by (intro of_nat_diff)
      (metis a card_0_eq empty_iff finite_atLeastAtMost_int less_one linorder_not_le)
   also have "... \<le> \<lfloor>q+real x\<rfloor>+1 -\<lceil>real x-q\<rceil> - 1"
     using assms by (simp, linarith)
   also have "... \<le> 2*q"
     by linarith
   finally show "card A \<le> 2 * q"
     by simp
 
   have "A \<subseteq> {..x + nat \<lceil>q\<rceil>}"
     by (rule subsetI, simp add:A_def abs_le_iff, linarith)
   thus "finite A"
     by (rule finite_subset, simp)
 qed
 
 private lemma prob_degree_lt_1:
    "prob {\<omega>. degree \<omega> < 1} \<le> 1/real p" 
 proof -
   have "space \<inter> {\<omega>. length \<omega> \<le> Suc 0} = bounded_degree_polynomials (mod_ring p) 1"
     by (auto simp:set_eq_iff bounded_degree_polynomials_def space_def)
   moreover have "field_size = p" by (simp add:mod_ring_def)
   hence "real (card (bounded_degree_polynomials (mod_ring p) (Suc 0))) / real (card space) = 1 / real p"
     by (simp add:space_def bounded_degree_polynomials_card power2_eq_square)
   ultimately show ?thesis
     by (simp add:M_def measure_pmf_of_set)
 qed
 
 private lemma collision_prob:
   assumes "c \<ge> 1"
   shows "prob {\<omega>. \<exists>x \<in> set as. \<exists>y \<in> set as. x \<noteq> y \<and> tr_hash x \<omega> \<le> c \<and> tr_hash x \<omega> = tr_hash y \<omega>} \<le> 
     (5/2) * (real (card (set as)))\<^sup>2 * c\<^sup>2 * 2 powr -(real r) / (real p)\<^sup>2 + 1/real p" (is "prob {\<omega>. ?l \<omega>} \<le> ?r1 + ?r2")
 proof -
   define \<rho> :: real where "\<rho> = 9/8"
 
   have rho_c_ge_0: "\<rho> * c \<ge> 0" unfolding \<rho>_def using assms by simp 
 
   have c_ge_0: "c\<ge>0" using assms by simp
   
   have "degree \<omega> \<ge> 1 \<Longrightarrow> \<omega> \<in> space \<Longrightarrow> degree \<omega> = 1" for \<omega>
     by (simp add:bounded_degree_polynomials_def space_def) 
      (metis One_nat_def Suc_1 le_less_Suc_eq less_imp_diff_less list.size(3) pos2)
 
   hence a: "\<And>\<omega> x y. x < p \<Longrightarrow> y < p \<Longrightarrow>  x \<noteq> y \<Longrightarrow> degree \<omega> \<ge> 1 \<Longrightarrow> \<omega> \<in> space \<Longrightarrow>  hash x \<omega> \<noteq> hash y \<omega>" 
     using inj_onD[OF inj_if_degree_1]  mod_ring_carr by blast 
 
   have b: "prob {\<omega>. degree \<omega> \<ge> 1 \<and> tr_hash x \<omega> \<le> c \<and> tr_hash x \<omega> = tr_hash y \<omega>} \<le> 5 * c\<^sup>2 * 2 powr (-real r) /(real p)\<^sup>2"
     if b_assms: "x \<in> set as"  "y \<in> set as"  "x < y" for x y
   proof -
     have c: "real u \<le> \<rho> * c \<and> \<bar>real u - real v\<bar> \<le> \<rho> * c * 2 powr (-real r)"
       if c_assms:"truncate_down r (real u) \<le> c" "truncate_down r (real u) = truncate_down r (real v)" for u v
     proof -
       have "9 * 2 powr - real r \<le> 9 * 2 powr (- real 23)" 
         using r_ge_23 by (intro mult_left_mono powr_mono, auto)
 
       also have "... \<le> 1" by simp
 
       finally have "9 * 2 powr - real r \<le> 1" by simp
 
       hence "1 \<le> \<rho> * (1 - 2 powr (- real r))" 
         by (simp add:\<rho>_def)
 
       hence d: "(c*1) / (1 - 2 powr (-real r)) \<le> c * \<rho>" 
         using assms two_pow_r_le_1 by (simp add: pos_divide_le_eq)
 
       have "\<And>x. truncate_down r (real x) \<le> c \<Longrightarrow> real x * (1 - 2 powr - real r) \<le> c * 1" 
         using  truncate_down_pos[OF of_nat_0_le_iff] order_trans by (simp, blast)
 
       hence "\<And>x. truncate_down r (real x) \<le>  c  \<Longrightarrow> real x \<le> c * \<rho>"
         using two_pow_r_le_1 by (intro order_trans[OF _ d], simp add: pos_le_divide_eq) 
 
       hence e: "real u \<le> c * \<rho>" "real v \<le> c * \<rho>" 
         using c_assms by auto
 
       have " \<bar>real u - real v\<bar> \<le> (max \<bar>real u\<bar> \<bar>real v\<bar>) * 2 powr (-real r)"
         using c_assms by (intro truncate_down_eq, simp)
 
       also have "... \<le> (c * \<rho>) * 2 powr (-real r)"
         using e by (intro mult_right_mono, auto)
 
       finally have "\<bar>real u - real v\<bar> \<le> \<rho> * c * 2 powr (-real r)"
         by (simp add:algebra_simps)
 
       thus ?thesis using e by (simp add:algebra_simps)
     qed
 
     have "prob {\<omega>. degree \<omega> \<ge> 1 \<and> tr_hash x \<omega> \<le> c \<and> tr_hash x \<omega> = tr_hash y \<omega>} \<le>
       prob (\<Union> i \<in> {(u,v) \<in> {..<p} \<times> {..<p}. u \<noteq> v \<and> truncate_down r u \<le> c \<and> truncate_down r u = truncate_down r v}.
       {\<omega>.  hash x \<omega> = fst i \<and> hash y \<omega> = snd i})"
       using a by (intro pmf_mono[OF M_def], simp add:tr_hash_def) 
        (metis hash_range mod_ring_carr b_assms as_subset_p lessThan_iff nat_neq_iff subset_eq) 
 
     also have "... \<le> (\<Sum> i\<in> {(u,v) \<in> {..<p} \<times> {..<p}. u \<noteq> v \<and>
       truncate_down r u \<le> c \<and> truncate_down r u = truncate_down r v}. 
       prob {\<omega>. hash x \<omega> = fst i \<and> hash  y \<omega> = snd i})"
       by (intro measure_UNION_le finite_cartesian_product finite_subset[where B="{0..<p} \<times> {0..<p}"])
        (auto simp add:M_def)
 
     also have "... \<le> (\<Sum> i\<in> {(u,v) \<in> {..<p} \<times> {..<p}. u \<noteq> v \<and>
       truncate_down r u \<le> c \<and> truncate_down r u = truncate_down r v}. 
       prob {\<omega>. (\<forall>u \<in> {x,y}. hash u \<omega> = (if u = x then (fst i) else (snd i)))})" 
       by (intro sum_mono  pmf_mono[OF M_def]) force
 
     also have "... \<le> (\<Sum> i\<in> {(u,v) \<in> {..<p} \<times> {..<p}. u \<noteq> v \<and>
       truncate_down r u \<le> c \<and> truncate_down r u = truncate_down r v}. 1/(real p)\<^sup>2)"
       using assms as_subset_p b_assms
       by (intro sum_mono, subst hash_prob)  (auto simp add: mod_ring_def power2_eq_square)
 
     also have "... = 1/(real p)\<^sup>2 * 
       card {(u,v) \<in> {0..<p} \<times> {0..<p}. u \<noteq> v \<and> truncate_down r u \<le> c \<and> truncate_down r u = truncate_down r v}"
       by simp
 
     also have "... \<le> 1/(real p)\<^sup>2 * 
       card {(u,v) \<in> {..<p} \<times> {..<p}. u \<noteq> v \<and> real u \<le> \<rho> * c \<and> abs (real u - real v) \<le> \<rho> * c * 2 powr (-real r)}"
       using c
       by (intro mult_mono of_nat_mono card_mono finite_cartesian_product finite_subset[where B="{..<p}\<times>{..<p}"])
         auto
 
     also have "... \<le> 1/(real p)\<^sup>2 * card (\<Union>u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}.
         {(u::nat,v::nat). u = u' \<and> abs (real u - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v < p \<and> v \<noteq> u'})"
       by (intro mult_left_mono of_nat_mono card_mono finite_cartesian_product finite_subset[where B="{..<p}\<times>{..<p}"])
        auto
 
     also have "... \<le> 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}.
       card  {(u,v). u = u' \<and> abs (real u - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v < p \<and> v \<noteq> u'})"
       by (intro mult_left_mono of_nat_mono card_UN_le, auto)
 
     also have "... = 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and>  real u \<le> \<rho> * c}.
       card ((\<lambda>x. (u' ,x)) ` {v. abs (real u' - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v < p \<and> v \<noteq> u'}))"
       by (intro arg_cong2[where f="(*)"] arg_cong[where f="real"] sum.cong arg_cong[where f="card"])
        (auto simp add:set_eq_iff)
 
     also have "... \<le> 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}.
       card {v. abs (real u' - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v < p \<and> v \<noteq> u'})"
       by (intro mult_left_mono of_nat_mono sum_mono card_image_le, auto)
 
     also have "... \<le> 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}.
       card {v. abs (real u' - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v \<noteq> u'})"
       by (intro mult_left_mono sum_mono of_nat_mono card_mono card_nat_in_ball subsetI)  auto
 
     also have "... \<le> 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}.
       real (card {v. abs (real u' - real v) \<le> \<rho> * c * 2 powr (-real r) \<and> v \<noteq> u'}))"
       by simp
 
     also have "... \<le> 1/(real p)\<^sup>2 * (\<Sum> u' \<in> {u. u < p \<and> real u \<le> \<rho> * c}. 2 * (\<rho> * c * 2 powr (-real r)))"
       by (intro mult_left_mono sum_mono card_nat_in_ball(1), auto)
 
     also have "... =  1/(real p)\<^sup>2 * (real (card {u. u < p \<and> real u \<le> \<rho> * c}) * (2 * (\<rho> * c * 2 powr (-real r))))"
       by simp
 
     also have "... \<le>  1/(real p)\<^sup>2 * (real (card {u. u \<le> nat (\<lfloor>\<rho> * c \<rfloor>)}) * (2 * (\<rho> * c * 2 powr (-real r))))"
       using rho_c_ge_0 le_nat_floor
       by (intro mult_left_mono mult_right_mono of_nat_mono card_mono subsetI) auto
 
     also have "... \<le>  1/(real p)\<^sup>2 * ((1+\<rho> * c) * (2 * (\<rho> * c * 2 powr (-real r))))"
       using rho_c_ge_0 by (intro mult_left_mono mult_right_mono, auto)
 
     also have "... \<le>  1/(real p)\<^sup>2 * (((1+\<rho>) * c) * (2 * (\<rho> * c * 2 powr (-real r))))" 
       using assms by (intro mult_mono, auto simp add:distrib_left distrib_right \<rho>_def)
 
     also have "... = (\<rho> * (2 + \<rho> * 2)) * c\<^sup>2 * 2 powr (-real r) /(real p)\<^sup>2"
       by (simp add:ac_simps power2_eq_square) 
 
     also have "... \<le> 5 * c\<^sup>2 *  2 powr (-real r) /(real p)\<^sup>2"
       by (intro divide_right_mono mult_right_mono) (auto simp add:\<rho>_def)
 
     finally show ?thesis by simp
   qed
 
   have "prob {\<omega>. ?l \<omega> \<and> degree \<omega> \<ge> 1} \<le> 
     prob (\<Union> i \<in> {(x,y) \<in> (set as) \<times> (set as). x < y}. {\<omega>. degree \<omega> \<ge> 1 \<and> tr_hash (fst i) \<omega> \<le> c \<and>
     tr_hash (fst i) \<omega> = tr_hash (snd i) \<omega>})"
     by (rule pmf_mono[OF M_def], simp, metis linorder_neqE_nat)
 
   also have "... \<le> (\<Sum> i \<in> {(x,y) \<in> (set as) \<times> (set as). x < y}. prob 
     {\<omega>. degree \<omega> \<ge> 1 \<and> tr_hash  (fst i) \<omega> \<le> c \<and> tr_hash (fst i) \<omega> = tr_hash (snd i) \<omega>})"
     unfolding M_def
     by (intro measure_UNION_le finite_cartesian_product finite_subset[where B="(set as) \<times> (set as)"])
       auto
 
   also have "... \<le> (\<Sum> i \<in> {(x,y) \<in> (set as) \<times> (set as). x < y}. 5  * c\<^sup>2 * 2 powr (-real r) /(real p)\<^sup>2)"
     using b by (intro sum_mono, simp add:case_prod_beta)
 
   also have "... =  ((5/2) * c\<^sup>2  * 2 powr (-real r) /(real p)\<^sup>2) * (2 * card  {(x,y) \<in> (set as) \<times> (set as). x < y})"
     by simp
 
   also have "... =  ((5/2) * c\<^sup>2  * 2 powr (-real r) /(real p)\<^sup>2) * (card (set as) * (card (set as) - 1))"
     by (subst card_ordered_pairs, auto) 
 
   also have "... \<le> ((5/2) * c\<^sup>2 * 2 powr (-real r) /(real p)\<^sup>2) * (real (card (set as)))\<^sup>2"
     by (intro mult_left_mono) (auto simp add:power2_eq_square mult_left_mono)
 
   also have "... = (5/2) * (real (card (set as)))\<^sup>2 * c\<^sup>2 * 2 powr (-real r) /(real p)\<^sup>2"
     by (simp add:algebra_simps)
 
   finally have f:"prob {\<omega>. ?l \<omega> \<and> degree \<omega> \<ge> 1} \<le> ?r1" by simp
 
   have "prob {\<omega>. ?l \<omega>} \<le> prob {\<omega>. ?l \<omega> \<and> degree \<omega> \<ge> 1} + prob {\<omega>. degree \<omega> < 1}"
     by (rule pmf_add[OF M_def], auto)
   also have "... \<le> ?r1 + ?r2"
     by (intro add_mono f prob_degree_lt_1)
   finally show ?thesis by simp
 qed
 
 private lemma of_bool_square: "(of_bool x)\<^sup>2 = ((of_bool x)::real)"
   by (cases x, auto)
 
 private definition Q where "Q y \<omega> = card {x \<in> set as. int (hash x \<omega>) < y}"
 
 private definition m where "m = card (set as)"
 
 private lemma
   assumes "a \<ge> 0"
   assumes "a \<le> int p"
   shows exp_Q: "expectation (\<lambda>\<omega>. real (Q a \<omega>)) = real m * (of_int a) / p"
   and var_Q: "variance (\<lambda>\<omega>. real (Q a \<omega>)) \<le> real m * (of_int a) / p"
 proof -
   have exp_single: "expectation (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a)) = real_of_int a /real p"
     if a:"x \<in> set as" for x
   proof -
     have x_le_p: "x < p" using a as_lt_p by simp
     have "expectation (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a)) = expectation (indicat_real {\<omega>. int (Frequency_Moment_0.hash p x \<omega>) < a})"
       by (intro arg_cong2[where f="integral\<^sup>L"] ext, simp_all)
     also have "... = prob {\<omega>. hash x \<omega> \<in> {k. int k < a}}"
       by (simp add:M_def)
     also have "... = card ({k. int k < a} \<inter> {..<p}) / real p"
       by (subst prob_range, simp_all add: x_le_p mod_ring_def)
     also have "... = card {..<nat a} / real p"
       using assms by (intro arg_cong2[where f="(/)"] arg_cong[where f="real"] arg_cong[where f="card"])
        (auto simp add:set_eq_iff) 
     also have "... =  real_of_int a/real p"
       using assms by simp
     finally show "expectation (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a)) = real_of_int a /real p"
       by simp
   qed
 
   have "expectation(\<lambda>\<omega>. real (Q a \<omega>)) = expectation (\<lambda>\<omega>. (\<Sum>x \<in> set as. of_bool (int (hash x \<omega>) < a)))"
     by (simp add:Q_def Int_def)
   also have "... =  (\<Sum>x \<in> set as. expectation (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a)))"
     by (rule Bochner_Integration.integral_sum, simp)
   also have "... = (\<Sum> x \<in> set as. a /real p)"
     by (rule sum.cong, simp, subst exp_single, simp, simp)
   also have "... = real m *  real_of_int a / real p"
     by (simp add:m_def)
   finally show "expectation (\<lambda>\<omega>. real (Q a \<omega>)) = real m * real_of_int a / p" by simp
 
   have indep: "J \<subseteq> set as \<Longrightarrow> card J = 2 \<Longrightarrow> indep_vars (\<lambda>_. borel) (\<lambda>i x. of_bool (int (hash i x) < a)) J" for J
     using as_subset_p mod_ring_carr
     by (intro indep_vars_compose2[where Y="\<lambda>i x. of_bool (int x < a)" and M'="\<lambda>_. discrete"]
         k_wise_indep_vars_subset[OF k_wise_indep] finite_subset[OF _ finite_set]) auto
 
   have rv: "\<And>x. x \<in> set as \<Longrightarrow> random_variable borel (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a))"
      by (simp add:M_def)
 
   have "variance (\<lambda>\<omega>. real (Q a \<omega>)) = variance (\<lambda>\<omega>. (\<Sum>x \<in> set as. of_bool (int (hash x \<omega>) < a)))"
     by (simp add:Q_def Int_def)
   also have "... = (\<Sum>x \<in> set as. variance (\<lambda>\<omega>. of_bool (int (hash x \<omega>) < a)))"
-    by (intro var_sum_pairwise_indep_2 indep rv) auto
+    by (intro bienaymes_identity_pairwise_indep_2 indep rv) auto
   also have "... \<le> (\<Sum> x \<in> set as. a / real p)"
     by (rule sum_mono, simp add: variance_eq of_bool_square, simp add: exp_single)
   also have "... = real m * real_of_int a /real p"
     by (simp add:m_def)
   finally show "variance (\<lambda>\<omega>. real (Q a \<omega>)) \<le> real m * real_of_int a / p"
     by simp
 qed
 
 private lemma t_bound: "t \<le> 81 / (real_of_rat \<delta>)\<^sup>2"
 proof -
   have "t \<le> 80 / (real_of_rat \<delta>)\<^sup>2 + 1" using t_def t_gt_0 by linarith
   also have "... \<le> 80 / (real_of_rat \<delta>)\<^sup>2 + 1 /  (real_of_rat \<delta>)\<^sup>2"
     using \<delta>_range by (intro add_mono, simp, simp add:power_le_one)
   also have "... = 81 / (real_of_rat \<delta>)\<^sup>2" by simp
   finally show ?thesis by simp
 qed
 
 private lemma t_r_bound:
   "18 * 40 * (real t)\<^sup>2 * 2 powr (-real r) \<le> 1"
 proof -
   have "720 * (real t)\<^sup>2 * 2 powr (-real r) \<le> 720 * (81 / (real_of_rat \<delta>)\<^sup>2)\<^sup>2 * 2 powr (-4 * log 2 (1 / real_of_rat \<delta>) - 23)"
     using r_bound t_bound by (intro mult_left_mono mult_mono power_mono powr_mono, auto)
 
   also have "... \<le> 720 * (81 / (real_of_rat \<delta>)\<^sup>2)\<^sup>2 * (2 powr (-4 * log 2 (1 / real_of_rat \<delta>)) * 2 powr (-23))"
     using \<delta>_range by (intro mult_left_mono mult_mono power_mono add_mono)
      (simp_all add:power_le_one powr_diff)
 
   also have "... = 720 * (81\<^sup>2 / (real_of_rat \<delta>)^4) * (2 powr (log 2 ((real_of_rat \<delta>)^4))  * 2 powr (-23))"
     using \<delta>_range by (intro arg_cong2[where f="(*)"])
       (simp_all add:power2_eq_square power4_eq_xxxx log_divide log_powr[symmetric])
 
   also have "... = 720 * 81\<^sup>2 * 2 powr (-23)" using \<delta>_range by simp
 
   also have "... \<le> 1" by simp
 
   finally show ?thesis by simp
 qed
 
 private lemma m_eq_F_0: "real m = of_rat (F 0 as)"
   by (simp add:m_def F_def)
 
 private lemma estimate'_bounds:
   "prob {\<omega>. of_rat \<delta> * real_of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - of_rat (F 0 as)\<bar>} \<le> 1/3"
 proof (cases "card (set as) \<ge> t")
   case True
   define \<delta>' where "\<delta>' = 3 * real_of_rat \<delta> / 4"
   define u where "u = \<lceil>real t * p / (m * (1+\<delta>'))\<rceil>"
   define v where "v = \<lfloor>real t * p / (m * (1-\<delta>'))\<rfloor>"
 
   define has_no_collision where 
     "has_no_collision = (\<lambda>\<omega>. \<forall>x\<in> set as. \<forall>y \<in> set as. (tr_hash x \<omega> = tr_hash y \<omega> \<longrightarrow> x = y) \<or> tr_hash x \<omega> > v)"
 
   have "2 powr (-real r) \<le> 2 powr (-(4 * log 2 (1 / real_of_rat \<delta>) + 23))"
     using r_bound by (intro powr_mono, linarith, simp)
   also have "... = 2 powr (-4 * log 2 (1 /real_of_rat \<delta>) -23)"
     by (rule arg_cong2[where f="(powr)"], auto simp add:algebra_simps)
   also have "... \<le> 2 powr ( -1 * log 2 (1 /real_of_rat \<delta>) -4)"
     using \<delta>_range by (intro powr_mono diff_mono, auto)
   also have "... = 2 powr ( -1 * log 2 (1 /real_of_rat \<delta>)) /  16"
     by (simp add: powr_diff)
   also have "... = real_of_rat \<delta> / 16"
     using \<delta>_range by (simp add:log_divide)
   also have "... < real_of_rat \<delta> / 8"
     using \<delta>_range by (subst pos_divide_less_eq, auto)
   finally have r_le_\<delta>: "2 powr (-real r) < real_of_rat \<delta> / 8"
     by simp
 
   have \<delta>'_gt_0: "\<delta>' > 0" using \<delta>_range by (simp add:\<delta>'_def)
   have "\<delta>' < 3/4" using \<delta>_range by (simp add:\<delta>'_def)+
   also have "... < 1" by simp
   finally have \<delta>'_lt_1: "\<delta>' < 1" by simp
 
   have "t \<le> 81 / (real_of_rat \<delta>)\<^sup>2"
     using t_bound by simp
   also have "... = (81*9/16) / (\<delta>')\<^sup>2"
     by (simp add:\<delta>'_def power2_eq_square)
   also have "... \<le> 46 / \<delta>'\<^sup>2"
     by (intro divide_right_mono, simp, simp)
   finally have t_le_\<delta>': "t \<le> 46/ \<delta>'\<^sup>2" by simp
 
   have "80 \<le> (real_of_rat \<delta>)\<^sup>2 * (80 / (real_of_rat \<delta>)\<^sup>2)" using \<delta>_range by simp
   also have "... \<le> (real_of_rat \<delta>)\<^sup>2 * t"
     by (intro mult_left_mono, simp add:t_def of_nat_ceiling, simp)
   finally have "80 \<le> (real_of_rat \<delta>)\<^sup>2 * t" by simp
   hence t_ge_\<delta>': "45 \<le> t * \<delta>' * \<delta>'" by (simp add:\<delta>'_def power2_eq_square)
 
   have "m \<le> card {..<n}" unfolding m_def using as_range by (intro card_mono, auto)
   also have "... \<le> p" using n_le_p by simp
   finally have m_le_p: "m \<le> p" by simp
 
   hence t_le_m: "t \<le> card (set as)" using True by simp
   have m_ge_0: "real m > 0" using m_def True t_gt_0 by simp
 
   have "v \<le> real t * real p / (real m * (1 - \<delta>'))" by (simp add:v_def)
 
   also have "... \<le> real t * real p / (real m * (1/4))"
     using \<delta>'_lt_1 m_ge_0 \<delta>_range
     by (intro divide_left_mono mult_left_mono mult_nonneg_nonneg mult_pos_pos, simp_all add:\<delta>'_def)
 
   finally have v_ubound: "v \<le> 4 * real t * real p / real m" by (simp add:algebra_simps)
 
   have a_ge_1: "u \<ge> 1" using \<delta>'_gt_0 p_gt_0 m_ge_0 t_gt_0
     by (auto intro!:mult_pos_pos divide_pos_pos simp add:u_def) 
   hence a_ge_0: "u \<ge> 0" by simp
   have "real m * (1 - \<delta>') < real m" using \<delta>'_gt_0 m_ge_0 by simp
   also have "... \<le> 1 * real p" using m_le_p by simp
   also have "... \<le> real t * real p" using t_gt_0 by (intro mult_right_mono, auto)
   finally have " real m * (1 - \<delta>') < real t * real p" by simp
   hence v_gt_0: "v > 0" using mult_pos_pos m_ge_0 \<delta>'_lt_1 by (simp add:v_def)
   hence v_ge_1: "real_of_int v \<ge> 1" by linarith
 
   have "real t \<le> real m" using True m_def by linarith
   also have "... < (1 + \<delta>') * real m" using \<delta>'_gt_0 m_ge_0 by force
   finally have a_le_p_aux: "real t < (1 + \<delta>') * real m"  by simp
 
   have "u \<le> real t * real p / (real m * (1 + \<delta>'))+1" by (simp add:u_def)
   also have "... < real p + 1" 
     using m_ge_0 \<delta>'_gt_0 a_le_p_aux  a_le_p_aux p_gt_0
     by (simp add: pos_divide_less_eq ac_simps) 
   finally have "u \<le> real p" 
     by (metis int_less_real_le not_less of_int_le_iff of_int_of_nat_eq)
   hence u_le_p: "u \<le> int p" by linarith
 
   have "prob {\<omega>. Q u \<omega> \<ge> t} \<le> prob {\<omega> \<in> Sigma_Algebra.space M. abs (real (Q u \<omega>) - 
     expectation (\<lambda>\<omega>. real (Q u \<omega>))) \<ge> 3 * sqrt (m * real_of_int u / p)}"
   proof (rule pmf_mono[OF M_def])
     fix \<omega>
     assume "\<omega> \<in> {\<omega>. t \<le> Q u \<omega>}"
     hence t_le: "t \<le> Q u \<omega>" by simp
     have "real m * real_of_int u / real p \<le> real m * (real t * real p / (real m * (1 + \<delta>'))+1) / real p"
       using m_ge_0 p_gt_0 by (intro divide_right_mono mult_left_mono, simp_all add: u_def)
     also have "... = real m * real t * real p / (real m * (1+\<delta>') * real p) + real m / real p"
       by (simp add:distrib_left add_divide_distrib)
     also have "... = real t / (1+\<delta>') + real m / real p"
       using p_gt_0 m_ge_0 by simp
     also have "... \<le> real t / (1+\<delta>') + 1"
       using m_le_p p_gt_0 by (intro add_mono, auto)
     finally have "real m * real_of_int u / real p \<le> real t / (1 + \<delta>') + 1"
       by simp
 
     hence "3 * sqrt (real m * of_int u / real p) + real m * of_int u / real p \<le> 
       3 * sqrt (t / (1+\<delta>')+1)+(t/(1+\<delta>')+1)"
       by (intro add_mono mult_left_mono real_sqrt_le_mono, auto)
     also have "... \<le> 3 * sqrt (real t+1) + ((t * (1 - \<delta>' / (1+\<delta>'))) + 1)"
       using \<delta>'_gt_0 t_gt_0 by (intro add_mono mult_left_mono real_sqrt_le_mono)
         (simp_all add: pos_divide_le_eq left_diff_distrib)
     also have "... = 3 * sqrt (real t+1) + (t - \<delta>' * t / (1+\<delta>')) + 1" by (simp add:algebra_simps)
     also have "... \<le> 3 * sqrt (46 / \<delta>'\<^sup>2 + 1 / \<delta>'\<^sup>2) + (t - \<delta>' * t/2) + 1 / \<delta>'"
       using \<delta>'_gt_0 t_gt_0 \<delta>'_lt_1 add_pos_pos  t_le_\<delta>'
       by (intro add_mono mult_left_mono real_sqrt_le_mono add_mono)
        (simp_all add: power_le_one pos_le_divide_eq)
     also have "... \<le> (21 / \<delta>' + (t - 45 / (2*\<delta>'))) + 1 / \<delta>'" 
       using \<delta>'_gt_0 t_ge_\<delta>' by (intro add_mono)
          (simp_all add:real_sqrt_divide divide_le_cancel real_le_lsqrt pos_divide_le_eq ac_simps)
     also have "... \<le> t" using \<delta>'_gt_0 by simp
     also have "... \<le> Q u \<omega>" using t_le by simp
     finally have "3 * sqrt (real m * of_int u / real p) + real m * of_int u / real p \<le> Q u \<omega>"
       by simp
     hence " 3 * sqrt (real m * real_of_int u / real p) \<le> \<bar>real (Q u \<omega>) - expectation (\<lambda>\<omega>. real (Q u \<omega>))\<bar>"
       using a_ge_0 u_le_p  True by (simp add:exp_Q abs_ge_iff)
 
     thus "\<omega> \<in> {\<omega> \<in> Sigma_Algebra.space M. 3 * sqrt (real m * real_of_int u / real p) \<le> 
       \<bar>real (Q u \<omega>) - expectation (\<lambda>\<omega>. real (Q u \<omega>))\<bar>}"
       by (simp add: M_def)
   qed
   also have "... \<le> variance  (\<lambda>\<omega>. real (Q u \<omega>)) / (3 * sqrt (real m * of_int u / real p))\<^sup>2"
     using a_ge_1 p_gt_0 m_ge_0 
     by (intro Chebyshev_inequality, simp add:M_def, auto) 
 
   also have "... \<le> (real m * real_of_int u / real p) / (3 * sqrt (real m * of_int u / real p))\<^sup>2"
     using a_ge_0 u_le_p by (intro divide_right_mono var_Q, auto)
 
   also have "... \<le> 1/9" using a_ge_0 by simp
 
   finally have case_1: "prob {\<omega>. Q u \<omega> \<ge> t} \<le> 1/9" by simp
 
   have case_2: "prob {\<omega>. Q v \<omega> < t} \<le> 1/9"
   proof (cases "v \<le> p")
     case True
     have "prob {\<omega>. Q v \<omega> < t} \<le> prob {\<omega> \<in> Sigma_Algebra.space M. abs (real (Q v \<omega>) - expectation (\<lambda>\<omega>. real (Q v \<omega>))) 
       \<ge> 3 * sqrt (m * real_of_int v / p)}"
     proof (rule pmf_mono[OF M_def])
       fix \<omega>
       assume "\<omega> \<in> set_pmf (pmf_of_set space)"
       have "(real t + 3 * sqrt (real t / (1 - \<delta>') )) * (1 - \<delta>') = real t - \<delta>' * t + 3 * ((1-\<delta>') * sqrt( real t / (1-\<delta>') ))"
         by (simp add:algebra_simps)
 
       also have "... = real t - \<delta>' * t + 3 * sqrt (  (1-\<delta>')\<^sup>2 * (real t /  (1-\<delta>')))"
         using \<delta>'_lt_1 by (subst real_sqrt_mult, simp)
 
       also have "... = real t - \<delta>' * t + 3 * sqrt ( real t * (1- \<delta>'))"
         by (simp add:power2_eq_square distrib_left)
 
       also have "... \<le> real t - 45/ \<delta>' + 3 * sqrt ( real t )"
         using \<delta>'_gt_0 t_ge_\<delta>' \<delta>'_lt_1 by (intro add_mono mult_left_mono real_sqrt_le_mono)
          (simp_all add:pos_divide_le_eq ac_simps left_diff_distrib power_le_one)
 
        also have "... \<le> real t - 45/ \<delta>' + 3 * sqrt ( 46 / \<delta>'\<^sup>2)"
          using  t_le_\<delta>' \<delta>'_lt_1 \<delta>'_gt_0
          by (intro add_mono mult_left_mono real_sqrt_le_mono, simp_all add:pos_divide_le_eq power_le_one)
 
       also have "... = real t + (3 * sqrt(46) - 45)/ \<delta>'"
         using \<delta>'_gt_0 by (simp add:real_sqrt_divide diff_divide_distrib)
 
       also have "... \<le> t"
         using \<delta>'_gt_0 by (simp add:pos_divide_le_eq real_le_lsqrt)
 
       finally have aux: "(real t + 3 * sqrt (real t / (1 - \<delta>'))) * (1 - \<delta>') \<le> real t "
         by simp
 
       assume "\<omega> \<in> {\<omega>. Q v \<omega> < t}"
       hence "Q v \<omega> < t" by simp
 
       hence "real (Q v \<omega>) + 3 * sqrt (real m * real_of_int v / real p) 
         \<le> real t - 1 + 3 * sqrt (real m * real_of_int v / real p)"
         using m_le_p p_gt_0 by (intro add_mono, auto simp add: algebra_simps add_divide_distrib)
 
       also have "... \<le> (real t-1) + 3 * sqrt (real m * (real t * real p / (real m * (1- \<delta>'))) / real p)"
         by (intro add_mono mult_left_mono real_sqrt_le_mono divide_right_mono)
          (auto simp add:v_def)
 
       also have "... \<le> real t + 3 * sqrt(real t / (1-\<delta>')) - 1"
         using m_ge_0 p_gt_0 by simp
 
       also have "... \<le> real t / (1-\<delta>')-1" 
         using \<delta>'_lt_1 aux by (simp add: pos_le_divide_eq)   
       also have "... \<le> real m * (real t * real p / (real m * (1-\<delta>'))) / real p - 1"
         using p_gt_0 m_ge_0 by simp
       also have "... \<le> real m * (real t * real p / (real m * (1-\<delta>'))) / real p - real m / real p"
           using m_le_p p_gt_0
           by (intro diff_mono, auto)
       also have "... = real m * (real t * real p / (real m * (1-\<delta>'))-1) / real p" 
           by (simp add: left_diff_distrib right_diff_distrib diff_divide_distrib)
       also have "... \<le>  real m * real_of_int v / real p"      
         by (intro divide_right_mono mult_left_mono, simp_all add:v_def)
 
       finally have "real (Q v \<omega>) + 3 * sqrt (real m * real_of_int v / real p) 
         \<le> real m * real_of_int v / real p" by simp
 
       hence " 3 * sqrt (real m * real_of_int v / real p) \<le> \<bar>real (Q v \<omega>) -expectation (\<lambda>\<omega>. real (Q v \<omega>))\<bar>"  
         using v_gt_0 True by (simp add: exp_Q abs_ge_iff)
 
       thus "\<omega> \<in> {\<omega>\<in> Sigma_Algebra.space M. 3 * sqrt (real m * real_of_int v / real p) \<le> 
         \<bar>real (Q v \<omega>) - expectation (\<lambda>\<omega>. real (Q v \<omega>))\<bar>}" 
         by (simp add:M_def)
     qed
     also have "... \<le> variance (\<lambda>\<omega>. real (Q v \<omega>)) / (3 * sqrt (real m * real_of_int v / real p))\<^sup>2" 
       using v_gt_0 p_gt_0 m_ge_0 
       by (intro Chebyshev_inequality, simp add:M_def, auto)
 
     also have "... \<le> (real m * real_of_int v / real p) / (3 * sqrt (real m * real_of_int v / real p))\<^sup>2"
       using  v_gt_0 True  by (intro divide_right_mono var_Q, auto)
 
     also have "... = 1/9"
       using p_gt_0 v_gt_0 m_ge_0 by (simp add:power2_eq_square)
 
     finally show ?thesis by simp
   next
     case False
     have "prob {\<omega>. Q v \<omega> < t} \<le> prob {\<omega>. False}"
     proof (rule pmf_mono[OF M_def])
       fix \<omega>
       assume a:"\<omega> \<in> {\<omega>. Q v \<omega> < t}"
       assume "\<omega> \<in> set_pmf (pmf_of_set space)"
       hence b:"\<And>x. x < p \<Longrightarrow> hash x \<omega> < p" 
         using hash_range mod_ring_carr by (simp add:M_def measure_pmf_inverse) 
       have "t \<le> card (set as)" using True by simp
       also have "... \<le> Q v \<omega>"
         unfolding Q_def  using b False as_lt_p by (intro card_mono subsetI, simp, force) 
       also have "... < t" using a by simp
       finally have "False" by auto
       thus "\<omega> \<in> {\<omega>. False}" by simp
     qed
     also have "... = 0" by auto
     finally show ?thesis by simp
   qed
 
   have "prob {\<omega>. \<not>has_no_collision \<omega>} \<le>
     prob {\<omega>. \<exists>x \<in> set as. \<exists>y \<in> set as. x \<noteq> y \<and> tr_hash x \<omega> \<le> real_of_int v \<and> tr_hash x \<omega> = tr_hash y \<omega>}"
     by (rule pmf_mono[OF M_def]) (simp add:has_no_collision_def M_def, force) 
 
   also have "... \<le> (5/2) * (real (card (set as)))\<^sup>2 * (real_of_int v)\<^sup>2 * 2 powr - real r / (real p)\<^sup>2 + 1 / real p"
     using collision_prob v_ge_1 by blast
 
   also have "... \<le> (5/2) * (real m)\<^sup>2 * (real_of_int v)\<^sup>2 * 2 powr - real r / (real p)\<^sup>2 + 1 / real p"
     by (intro divide_right_mono add_mono mult_right_mono mult_mono power_mono, simp_all add:m_def)
 
   also have "... \<le> (5/2) * (real m)\<^sup>2 * (4 * real t * real p / real m)\<^sup>2 * (2 powr - real r) / (real p)\<^sup>2 + 1 / real p"
     using v_def v_ge_1 v_ubound
     by (intro add_mono divide_right_mono  mult_right_mono  mult_left_mono, auto)
 
   also have "... = 40 * (real t)\<^sup>2 * (2 powr -real r) + 1 / real p"
     using p_gt_0 m_ge_0 t_gt_0 by (simp add:algebra_simps power2_eq_square)
 
   also have "... \<le> 1/18 + 1/18"
     using t_r_bound p_ge_18 by (intro add_mono, simp_all add: pos_le_divide_eq)
 
   also have "... = 1/9" by simp
 
   finally have case_3: "prob {\<omega>. \<not>has_no_collision \<omega>} \<le> 1/9" by simp
 
   have "prob {\<omega>. real_of_rat \<delta> * of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - of_rat (F 0 as)\<bar>} \<le> 
     prob {\<omega>. Q u \<omega> \<ge> t \<or> Q v \<omega> < t \<or> \<not>(has_no_collision \<omega>)}"
   proof (rule pmf_mono[OF M_def], rule ccontr)
     fix \<omega>
     assume "\<omega> \<in> set_pmf (pmf_of_set space)"
     assume "\<omega> \<in> {\<omega>. real_of_rat \<delta> * real_of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - real_of_rat (F 0 as)\<bar>}"
     hence est: "real_of_rat \<delta> * real_of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - real_of_rat (F 0 as)\<bar>" by simp
     assume "\<omega> \<notin> {\<omega>. t \<le> Q u \<omega> \<or> Q v \<omega> < t \<or> \<not> has_no_collision \<omega>}"
     hence "\<not>( t \<le> Q u \<omega> \<or> Q v \<omega> < t \<or> \<not> has_no_collision \<omega>)" by simp
     hence lb: "Q u \<omega> < t" and ub: "Q v \<omega> \<ge> t" and no_col: "has_no_collision \<omega>" by simp+
 
     define y where "y =  nth_mset (t-1) {#int (hash x \<omega>). x \<in># mset_set (set as)#}"
     define y' where "y' = nth_mset (t-1) {#tr_hash x \<omega>. x \<in># mset_set (set as)#}"
 
     have rank_t_lb: "u \<le> y"
       unfolding y_def using True t_gt_0 lb
       by (intro nth_mset_bound_left, simp_all add:count_less_def swap_filter_image Q_def)
   
     have rank_t_ub: "y \<le> v - 1"
       unfolding y_def using True t_gt_0 ub
       by (intro nth_mset_bound_right, simp_all add:Q_def swap_filter_image count_le_def)
 
     have y_ge_0: "real_of_int y \<ge> 0" using rank_t_lb a_ge_0 by linarith
 
     have "mono (\<lambda>x. truncate_down r (real_of_int x))" 
       by (metis truncate_down_mono mono_def of_int_le_iff)
     hence y'_eq: "y' = truncate_down r y"
       unfolding y_def y'_def  using True t_gt_0
       by (subst nth_mset_commute_mono[where f="(\<lambda>x. truncate_down r (of_int x))"]) 
         (simp_all add: multiset.map_comp comp_def tr_hash_def)
 
     have "real_of_int u * (1 - 2 powr -real r) \<le> real_of_int y * (1 - 2 powr (-real r))"
       using rank_t_lb of_int_le_iff two_pow_r_le_1
       by (intro mult_right_mono, auto)
     also have "... \<le> y'"
       using y'_eq truncate_down_pos[OF y_ge_0] by simp
     finally have rank_t_lb': "u * (1 - 2 powr -real r) \<le> y'" by simp
 
     have "y' \<le> real_of_int y"
       by (subst y'_eq, rule truncate_down_le, simp)
     also have "... \<le> real_of_int (v-1)"
       using rank_t_ub of_int_le_iff by blast
     finally have rank_t_ub': "y' \<le> v-1"
       by simp
 
     have "0 < u * (1-2 powr -real r)"
       using a_ge_1 two_pow_r_le_1 by (intro mult_pos_pos, auto)
     hence y'_pos: "y' > 0" using rank_t_lb' by linarith
 
     have no_col': "\<And>x. x \<le> y' \<Longrightarrow> count {#tr_hash x \<omega>. x \<in># mset_set (set as)#} x \<le> 1"
       using  rank_t_ub' no_col 
       by (simp add:vimage_def card_le_Suc0_iff_eq count_image_mset has_no_collision_def) force
 
     have h_1: "Max (sketch_rv' \<omega>) = y'"
       using True t_gt_0 no_col'
       by (simp add:sketch_rv'_def y'_def nth_mset_max)
 
     have "card (sketch_rv' \<omega>) = card (least ((t-1)+1) (set_mset {#tr_hash x \<omega>. x \<in># mset_set (set as)#}))"
       using t_gt_0 by (simp add:sketch_rv'_def)
     also have "... = (t-1) +1"
       using True t_gt_0 no_col' by (intro nth_mset_max(2), simp_all add:y'_def)
     also have "... = t" using t_gt_0 by simp
     finally have "card (sketch_rv' \<omega>) = t" by simp
     hence h_3: "estimate' (sketch_rv' \<omega>) = real t * real p / y'"
       using h_1 by (simp add:estimate'_def)
 
     have "(real t) * real p \<le>  (1 + \<delta>') * real m * ((real t) * real p / (real m * (1 + \<delta>')))" 
       using \<delta>'_lt_1 m_def True t_gt_0 \<delta>'_gt_0 by auto
     also have "... \<le> (1+\<delta>') * m * u"
       using \<delta>'_gt_0 by (intro mult_left_mono, simp_all add:u_def)
     also have "... < ((1 + real_of_rat \<delta>)*(1-real_of_rat \<delta>/8)) * m * u"
       using True m_def t_gt_0 a_ge_1 \<delta>_range
       by (intro mult_strict_right_mono, auto simp add:\<delta>'_def right_diff_distrib)
     also have "... \<le> ((1 + real_of_rat \<delta>)*(1-2 powr (-r))) * m * u"
       using r_le_\<delta> \<delta>_range a_ge_0 by (intro mult_right_mono mult_left_mono, auto)
     also have "... = (1 + real_of_rat \<delta>) * m * (u * (1-2 powr -real r))" 
       by simp
     also have "... \<le> (1 + real_of_rat \<delta>) * m * y'"
       using \<delta>_range by (intro mult_left_mono rank_t_lb', simp)
     finally have "real t * real p < (1 + real_of_rat \<delta>) * m * y'" by simp
     hence f_1: "estimate' (sketch_rv' \<omega>) < (1 + real_of_rat \<delta>) * m"
       using y'_pos by (simp add: h_3 pos_divide_less_eq)
 
     have "(1 - real_of_rat \<delta>) * m * y' \<le> (1 - real_of_rat \<delta>) * m * v" 
       using \<delta>_range rank_t_ub' y'_pos by (intro mult_mono rank_t_ub', simp_all)
     also have "... = (1-real_of_rat \<delta>) * (real m * v)"
       by simp
     also have "... < (1-\<delta>') * (real m * v)" 
       using \<delta>_range m_ge_0 v_ge_1
       by (intro mult_strict_right_mono mult_pos_pos, simp_all add:\<delta>'_def)
     also have "... \<le> (1-\<delta>') * (real m * (real t * real p / (real m * (1-\<delta>'))))"
       using \<delta>'_gt_0 \<delta>'_lt_1 by (intro mult_left_mono, auto simp add:v_def)
     also have "... = real t * real p"
       using \<delta>'_gt_0 \<delta>'_lt_1 t_gt_0 p_gt_0 m_ge_0 by auto
     finally have "(1 - real_of_rat \<delta>) * m * y' < real t * real p" by simp
     hence f_2: "estimate' (sketch_rv' \<omega>) > (1 - real_of_rat \<delta>) * m"
       using y'_pos by (simp add: h_3 pos_less_divide_eq)
 
     have "abs (estimate' (sketch_rv' \<omega>) - real_of_rat (F 0 as)) < real_of_rat \<delta> * (real_of_rat (F 0 as))"
       using f_1 f_2 by (simp add:abs_less_iff algebra_simps m_eq_F_0)
     thus "False" using est by linarith
   qed
   also have "... \<le> 1/9 + (1/9 + 1/9)"
     by (intro pmf_add_2[OF M_def] case_1 case_2 case_3)
   also have "... = 1/3" by simp
   finally show ?thesis by simp
 next
   case False
   have "prob {\<omega>. real_of_rat \<delta> * of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - of_rat (F 0 as)\<bar>} \<le>
     prob {\<omega>. \<exists>x \<in> set as. \<exists>y \<in> set as. x \<noteq> y \<and> tr_hash x \<omega> \<le> real p \<and> tr_hash x \<omega> = tr_hash y \<omega>}" 
   proof (rule pmf_mono[OF M_def])
     fix \<omega>
     assume a:"\<omega> \<in> {\<omega>. real_of_rat \<delta> * real_of_rat (F 0 as) < \<bar>estimate' (sketch_rv' \<omega>) - real_of_rat (F 0 as)\<bar>}"
     assume b:"\<omega> \<in> set_pmf (pmf_of_set space)" 
     have c: "card (set as) < t" using False by auto
     hence "card ((\<lambda>x. tr_hash x \<omega>) ` set as) < t"
       using card_image_le order_le_less_trans by blast
     hence d:"card (sketch_rv' \<omega>) = card ((\<lambda>x. tr_hash x \<omega>) ` (set as))"
       by (simp add:sketch_rv'_def card_least)
     have "card (sketch_rv' \<omega>) < t"
       by (metis List.finite_set  c d card_image_le  order_le_less_trans)
     hence "estimate' (sketch_rv' \<omega>) = card (sketch_rv' \<omega>)" by (simp add:estimate'_def)
     hence "card (sketch_rv' \<omega>) \<noteq> real_of_rat (F 0 as)"
       using a \<delta>_range by simp 
         (metis abs_zero cancel_comm_monoid_add_class.diff_cancel of_nat_less_0_iff pos_prod_lt zero_less_of_rat_iff)
     hence "card (sketch_rv' \<omega>) \<noteq> card (set as)"
       using m_def m_eq_F_0 by linarith
     hence "\<not>inj_on (\<lambda>x. tr_hash x \<omega>) (set as)"
       using card_image d by auto
     moreover have "tr_hash x \<omega> \<le> real p" if a:"x \<in> set as" for x
     proof -
       have "hash x \<omega> < p" 
         using hash_range as_lt_p a b by (simp add:mod_ring_carr M_def)
       thus "tr_hash x \<omega> \<le> real p" using truncate_down_le by (simp add:tr_hash_def)
     qed
    ultimately show "\<omega> \<in> {\<omega>. \<exists>x \<in> set as. \<exists>y \<in> set as. x \<noteq> y \<and> tr_hash x \<omega> \<le> real p \<and> tr_hash x \<omega> = tr_hash y \<omega>}"
      by (simp add:inj_on_def, blast)
   qed
   also have "... \<le> (5/2) * (real (card (set as)))\<^sup>2 * (real p)\<^sup>2 * 2 powr - real r / (real p)\<^sup>2 + 1 / real p"
     using p_gt_0 by (intro collision_prob, auto)
   also have "... = (5/2) * (real (card (set as)))\<^sup>2 * 2 powr (- real r) + 1 / real p"
     using p_gt_0 by (simp add:ac_simps power2_eq_square)
   also have "... \<le> (5/2) * (real t)\<^sup>2 * 2 powr (-real r) + 1 / real p"
     using False by (intro add_mono mult_right_mono mult_left_mono power_mono, auto)
   also have "... \<le> 1/6 + 1/6"
     using t_r_bound p_ge_18 by (intro add_mono, simp_all)
   also have "... \<le> 1/3" by simp
   finally show ?thesis by simp
 qed
 
 private lemma median_bounds:
   "\<P>(\<omega> in measure_pmf \<Omega>\<^sub>0. \<bar>median s (\<lambda>i. estimate (sketch_rv (\<omega> i))) - F 0 as\<bar> \<le> \<delta> * F 0 as) \<ge> 1 - real_of_rat \<epsilon>"
 proof -
   have "strict_mono_on A real_of_float" for A by (meson less_float.rep_eq strict_mono_onI)
   hence real_g_2: "\<And>\<omega>.  sketch_rv' \<omega> = real_of_float ` sketch_rv \<omega>" 
     by (simp add: sketch_rv'_def sketch_rv_def tr_hash_def least_mono_commute image_comp)
 
   moreover have "inj_on real_of_float A" for A
     using  real_of_float_inject by (simp add:inj_on_def)
   ultimately have card_eq: "\<And>\<omega>. card (sketch_rv \<omega>) = card (sketch_rv' \<omega>)" 
     using real_g_2 by (auto intro!: card_image[symmetric])
 
   have "Max (sketch_rv' \<omega>) = real_of_float (Max (sketch_rv \<omega>))" if a:"card (sketch_rv' \<omega>) \<ge> t" for \<omega> 
   proof -
     have "mono real_of_float"
       using less_eq_float.rep_eq mono_def by blast
     moreover have "finite (sketch_rv \<omega>)"
       by (simp add:sketch_rv_def least_def)
     moreover have " sketch_rv \<omega> \<noteq> {}"
       using card_eq[symmetric] card_gt_0_iff t_gt_0 a by (simp, force)  
     ultimately show ?thesis
       by (subst mono_Max_commute[where f="real_of_float"], simp_all add:real_g_2)
   qed
   hence real_g: "\<And>\<omega>. estimate' (sketch_rv' \<omega>) = real_of_rat (estimate (sketch_rv \<omega>))"
     by (simp add:estimate_def estimate'_def card_eq of_rat_divide of_rat_mult of_rat_add real_of_rat_of_float)
 
   have indep: "prob_space.indep_vars (measure_pmf \<Omega>\<^sub>0) (\<lambda>_. borel) (\<lambda>i \<omega>. estimate' (sketch_rv' (\<omega> i))) {0..<s}"
     unfolding \<Omega>\<^sub>0_def
     by (rule indep_vars_restrict_intro', auto simp add:restrict_dfl_def lessThan_atLeast0)
 
   moreover have "- (18 * ln (real_of_rat \<epsilon>)) \<le> real s"
     using of_nat_ceiling by (simp add:s_def) blast
 
   moreover have "i < s \<Longrightarrow> measure \<Omega>\<^sub>0 {\<omega>. of_rat \<delta> * of_rat (F 0 as) < \<bar>estimate' (sketch_rv' (\<omega> i)) - of_rat (F 0 as)\<bar>} \<le> 1/3"
     for i
     using estimate'_bounds unfolding \<Omega>\<^sub>0_def M_def
     by (subst prob_prod_pmf_slice, simp_all)
  
   ultimately have "1-real_of_rat \<epsilon> \<le> \<P>(\<omega> in measure_pmf \<Omega>\<^sub>0.
       \<bar>median s (\<lambda>i. estimate' (sketch_rv' (\<omega> i))) - real_of_rat (F 0 as)\<bar> \<le>  real_of_rat \<delta> * real_of_rat (F 0 as))"
     using \<epsilon>_range prob_space_measure_pmf
     by (intro prob_space.median_bound_2) auto
   also have "... = \<P>(\<omega> in measure_pmf \<Omega>\<^sub>0. 
       \<bar>median s (\<lambda>i. estimate (sketch_rv (\<omega> i))) - F 0 as\<bar> \<le>  \<delta> * F 0 as)"
     using s_gt_0 median_rat[symmetric] real_g by (intro arg_cong2[where f="measure"]) 
       (simp_all add:of_rat_diff[symmetric] of_rat_mult[symmetric] of_rat_less_eq)
   finally show "\<P>(\<omega> in measure_pmf \<Omega>\<^sub>0. \<bar>median s (\<lambda>i. estimate (sketch_rv (\<omega> i))) - F 0 as\<bar> \<le> \<delta> * F 0 as) \<ge> 1-real_of_rat \<epsilon>"
     by blast
 qed
 
 lemma f0_alg_correct':
   "\<P>(\<omega> in measure_pmf result. \<bar>\<omega> - F 0 as\<bar> \<le> \<delta> * F 0 as) \<ge> 1 - of_rat \<epsilon>"
 proof -
   have f0_result_elim: "\<And>x. f0_result (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i)) =
     return_pmf (median s (\<lambda>i. estimate (sketch_rv (x i))))"
     by (simp add:estimate_def, rule median_cong, simp)
  
   have "result = map_pmf (\<lambda>x. (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i))) \<Omega>\<^sub>0 \<bind> f0_result"
     by (subst result_def, subst f0_alg_sketch, simp)
   also have "... = \<Omega>\<^sub>0 \<bind> (\<lambda>x. return_pmf (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i))) \<bind> f0_result"
     by (simp add:t_def p_def r_def s_def map_pmf_def)
   also have "... = \<Omega>\<^sub>0 \<bind> (\<lambda>x. return_pmf (median s (\<lambda>i. estimate (sketch_rv (x i)))))"
     by (subst bind_assoc_pmf, subst bind_return_pmf, subst f0_result_elim)  simp
   finally have a:"result =  \<Omega>\<^sub>0 \<bind> (\<lambda>x. return_pmf (median s (\<lambda>i. estimate (sketch_rv (x i)))))"
     by simp
 
   show ?thesis
     using median_bounds by (simp add: a map_pmf_def[symmetric])
 qed
 
 private lemma f_subset:
   assumes "g ` A \<subseteq> h ` B"
   shows "(\<lambda>x. f (g x)) ` A \<subseteq> (\<lambda>x. f (h x)) ` B"
   using assms by auto
 
 lemma f0_exact_space_usage':
   defines "\<Omega> \<equiv> fold (\<lambda>a state. state \<bind> f0_update a) as (f0_init \<delta> \<epsilon> n)"
   shows "AE \<omega> in \<Omega>. bit_count (encode_f0_state \<omega>) \<le> f0_space_usage (n, \<epsilon>, \<delta>)"
 proof -
   
   have log_2_4: "log 2 4 = 2" 
     by (metis log2_of_power_eq mult_2 numeral_Bit0 of_nat_numeral power2_eq_square)
 
   have a: "bit_count (F\<^sub>e (float_of (truncate_down r y))) \<le> 
     ereal (12 + 4 * real r + 2 * log 2 (log 2 (n+13)))" if a_1:"y \<in> {..<p}" for y
   proof (cases "y \<ge> 1")
     case True
 
     have aux_1: " 0 < 2 + log 2 (real y)" 
       using True by (intro add_pos_nonneg, auto)
     have aux_2: "0 < 2 + log 2 (real p)"
       using p_gt_1 by (intro add_pos_nonneg, auto)
 
     have "bit_count (F\<^sub>e (float_of (truncate_down r y))) \<le> 
       ereal (10 + 4 * real r + 2 * log 2 (2 + \<bar>log 2 \<bar>real y\<bar>\<bar>))"
       by (rule truncate_float_bit_count)
     also have "... = ereal (10 + 4 * real r + 2 * log 2 (2 + (log 2 (real y))))"
       using True by simp
     also have "... \<le> ereal (10 + 4 * real r + 2 * log 2 (2 + log 2 p))"
       using aux_1 aux_2 True p_gt_0 a_1 by simp
     also have "... \<le> ereal (10 + 4 * real r + 2 * log 2 (log 2 4 + log 2 (2 * n + 40)))"
       using log_2_4 p_le_n p_gt_0
       by (intro ereal_mono add_mono mult_left_mono log_mono of_nat_mono add_pos_nonneg, auto)
     also have "... = ereal (10 + 4 * real r + 2 * log 2 (log 2 (8 * n + 160)))"
       by (simp add:log_mult[symmetric])
     also have "... \<le> ereal (10 + 4 * real r + 2 * log 2 (log 2 ((n+13) powr 2)))"
       by (intro ereal_mono add_mono mult_left_mono log_mono of_nat_mono add_pos_nonneg)
        (auto simp add:power2_eq_square algebra_simps)
     also have "... = ereal (10 +  4 * real r + 2 * log 2 (log 2 4 * log 2 (n + 13)))"
       by (subst log_powr, simp_all add:log_2_4)
     also have "... = ereal (12 +  4 * real r + 2 * log 2 (log 2 (n + 13)))"
       by (subst log_mult, simp_all add:log_2_4)
     finally show ?thesis by simp
   next
     case False
     hence "y = 0" using a_1 by simp
     then show ?thesis by (simp add:float_bit_count_zero)
   qed
 
   have "bit_count (encode_f0_state (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i))) \<le> 
         f0_space_usage (n, \<epsilon>, \<delta>)" if b: "x \<in> {..<s} \<rightarrow>\<^sub>E space" for x
   proof -
     have c: "x \<in> extensional {..<s}" using b by (simp add:PiE_def) 
 
     have d: "sketch_rv (x y) \<subseteq> (\<lambda>k. float_of (truncate_down r k)) ` {..<p} "
       if d_1: "y < s" for y
     proof -
       have "sketch_rv (x y) \<subseteq> (\<lambda>xa. float_of (truncate_down r (hash xa (x y)))) ` set as"
         using least_subset by (auto simp add:sketch_rv_def tr_hash_def) 
       also have "... \<subseteq> (\<lambda>k. float_of (truncate_down r (real k))) ` {..<p}"
         using b hash_range as_lt_p d_1
         by (intro f_subset[where f="\<lambda>x. float_of (truncate_down r (real x))"] image_subsetI)
          (simp add: PiE_iff mod_ring_carr)
       finally show ?thesis
         by simp
     qed
 
     have "\<And>y. y < s \<Longrightarrow> finite (sketch_rv (x y))"
       unfolding sketch_rv_def by (rule finite_subset[OF least_subset], simp)
     moreover have card_sketch: "\<And>y. y < s \<Longrightarrow> card (sketch_rv (x y)) \<le> t "
       by (simp add:sketch_rv_def card_least)
     moreover have "\<And>y z. y < s \<Longrightarrow> z \<in> sketch_rv (x y) \<Longrightarrow> 
       bit_count (F\<^sub>e z) \<le> ereal (12 + 4 * real r + 2 * log 2 (log 2 (real n + 13)))"
       using a d by auto
     ultimately have e: "\<And>y. y < s \<Longrightarrow> bit_count (S\<^sub>e F\<^sub>e (sketch_rv (x y))) 
       \<le> ereal (real t) * (ereal (12 + 4 * real r + 2 * log 2 (log 2 (real (n + 13)))) + 1) + 1"
       using float_encoding by (intro set_bit_count_est, auto)
 
     have f: "\<And>y. y < s \<Longrightarrow> bit_count (P\<^sub>e p 2 (x y)) \<le> ereal (real 2 * (log 2 (real p) + 1))"
       using p_gt_1 b
       by (intro bounded_degree_polynomial_bit_count) (simp_all add:space_def PiE_def Pi_def)
 
     have "bit_count (encode_f0_state (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i))) =
       bit_count (N\<^sub>e s) + bit_count (N\<^sub>e t) +  bit_count (N\<^sub>e p) + bit_count (N\<^sub>e r) +
       bit_count (([0..<s] \<rightarrow>\<^sub>e P\<^sub>e p 2) x) +
       bit_count (([0..<s] \<rightarrow>\<^sub>e S\<^sub>e F\<^sub>e) (\<lambda>i\<in>{..<s}. sketch_rv (x i)))"
       by (simp add:encode_f0_state_def dependent_bit_count lessThan_atLeast0
         s_def[symmetric] t_def[symmetric] p_def[symmetric] r_def[symmetric] ac_simps)
     also have "... \<le> ereal (2* log 2 (real s + 1) + 1) + ereal  (2* log 2 (real t + 1) + 1)
       + ereal (2* log 2 (real p + 1) + 1) + ereal (2 * log 2 (real r + 1) + 1)
       + (ereal (real s) * (ereal (real 2 * (log 2 (real p) + 1)))) 
       + (ereal (real s) * ((ereal (real t) * 
             (ereal (12 + 4 * real r + 2 * log 2 (log 2 (real (n + 13)))) + 1) + 1)))"
       using c e f
       by (intro add_mono exp_golomb_bit_count fun_bit_count_est[where xs="[0..<s]", simplified])
        (simp_all add:lessThan_atLeast0)
     also have "... = ereal ( 4 + 2 * log 2 (real s + 1) + 2 * log 2 (real t + 1) + 
       2 * log 2 (real p + 1) + 2 * log 2 (real r + 1) + real s * (3 + 2 * log 2 (real p) + 
       real t * (13 + (4 * real r + 2 * log 2 (log 2 (real n + 13))))))"
       by (simp add:algebra_simps)
     also have "... \<le> ereal ( 4 + 2 * log 2 (real s + 1)  + 2 * log 2 (real t + 1) + 
       2 * log 2 (2 * (21 + real n)) + 2 * log 2 (real r + 1) + real s * (3 + 2 * log 2 (2 * (21 + real n)) + 
       real t * (13 + (4 * real r + 2 * log 2 (log 2 (real n + 13))))))"
       using p_le_n p_gt_0
       by (intro ereal_mono add_mono mult_left_mono, auto)
     also have "... =  ereal (6 + 2 * log 2 (real s + 1) + 2 * log 2 (real t + 1) + 
       2 * log 2 (21 + real n) + 2 * log 2 (real r + 1) + real s * (5 + 2 * log 2 (21 + real n) + 
       real t * (13 + (4 * real r + 2 * log 2 (log 2 (real n + 13))))))"
       by (subst (1 2) log_mult, auto)
     also have "... \<le> f0_space_usage (n, \<epsilon>, \<delta>)"
       by (simp add:s_def[symmetric] r_def[symmetric] t_def[symmetric] Let_def)
        (simp add:algebra_simps)
     finally show "bit_count (encode_f0_state (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i))) \<le> 
         f0_space_usage (n, \<epsilon>, \<delta>)" by simp
   qed
   hence "\<And>x. x \<in> set_pmf \<Omega>\<^sub>0 \<Longrightarrow>
          bit_count (encode_f0_state (s, t, p, r, x, \<lambda>i\<in>{..<s}. sketch_rv (x i)))  \<le> ereal (f0_space_usage (n, \<epsilon>, \<delta>))"
     by (simp add:\<Omega>\<^sub>0_def set_prod_pmf del:f0_space_usage.simps)
   hence "\<And>y. y \<in> set_pmf \<Omega> \<Longrightarrow> bit_count (encode_f0_state y) \<le> ereal (f0_space_usage (n, \<epsilon>, \<delta>))"
     by (simp add: \<Omega>_def f0_alg_sketch del:f0_space_usage.simps f0_init.simps)
      (metis (no_types, lifting) image_iff pmf.set_map)
   thus ?thesis
     by (simp add: AE_measure_pmf_iff del:f0_space_usage.simps)
 qed
 
 end
 
 text \<open>Main results of this section:\<close>
 
 theorem f0_alg_correct:
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> \<in> {0<..<1}"
   assumes "set as \<subseteq> {..<n}"
   defines "\<Omega> \<equiv> fold (\<lambda>a state. state \<bind> f0_update a) as (f0_init \<delta> \<epsilon> n) \<bind> f0_result"
   shows "\<P>(\<omega> in measure_pmf \<Omega>. \<bar>\<omega> - F 0 as\<bar> \<le> \<delta> * F 0 as) \<ge> 1 - of_rat \<epsilon>"
   using f0_alg_correct'[OF assms(1-3)] unfolding \<Omega>_def by blast
 
 theorem f0_exact_space_usage:
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> \<in> {0<..<1}"
   assumes "set as \<subseteq> {..<n}"
   defines "\<Omega> \<equiv> fold (\<lambda>a state. state \<bind> f0_update a) as (f0_init \<delta> \<epsilon> n)"
   shows "AE \<omega> in \<Omega>. bit_count (encode_f0_state \<omega>) \<le> f0_space_usage (n, \<epsilon>, \<delta>)"
   using f0_exact_space_usage'[OF assms(1-3)] unfolding \<Omega>_def by blast
 
 theorem f0_asymptotic_space_complexity:
   "f0_space_usage \<in> O[at_top \<times>\<^sub>F at_right 0 \<times>\<^sub>F at_right 0](\<lambda>(n, \<epsilon>, \<delta>). ln (1 / of_rat \<epsilon>) * 
   (ln (real n) + 1 / (of_rat \<delta>)\<^sup>2 * (ln (ln (real n)) + ln (1 / of_rat \<delta>))))"
   (is "_ \<in> O[?F](?rhs)")
 proof -
   define n_of :: "nat \<times> rat \<times> rat \<Rightarrow> nat" where "n_of = (\<lambda>(n, \<epsilon>, \<delta>). n)"
   define \<epsilon>_of :: "nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<epsilon>_of = (\<lambda>(n, \<epsilon>, \<delta>). \<epsilon>)"
   define \<delta>_of :: "nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<delta>_of = (\<lambda>(n, \<epsilon>, \<delta>). \<delta>)"
   define t_of where "t_of = (\<lambda>x. nat \<lceil>80 / (real_of_rat (\<delta>_of x))\<^sup>2\<rceil>)"
   define s_of where "s_of = (\<lambda>x. nat \<lceil>-(18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>)"
   define r_of where "r_of = (\<lambda>x. nat (4 * \<lceil>log 2 (1 / real_of_rat (\<delta>_of x))\<rceil> + 23))"
 
   define g where "g = (\<lambda>x. ln (1 / of_rat (\<epsilon>_of x)) * (ln (real (n_of x)) + 
     1 / (of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / of_rat (\<delta>_of x)))))"
 
   have evt: "(\<And>x. 
     0 < real_of_rat (\<delta>_of x) \<and> 0 < real_of_rat (\<epsilon>_of x) \<and> 
     1/real_of_rat (\<delta>_of x) \<ge> \<delta> \<and> 1/real_of_rat (\<epsilon>_of x) \<ge> \<epsilon> \<and>
     real (n_of x) \<ge> n \<Longrightarrow> P x) \<Longrightarrow> eventually P ?F"  (is "(\<And>x. ?prem x \<Longrightarrow> _) \<Longrightarrow> _")
     for \<delta> \<epsilon> n P
     apply (rule eventually_mono[where P="?prem" and Q="P"])
     apply (simp add:\<epsilon>_of_def case_prod_beta' \<delta>_of_def n_of_def)
      apply (intro eventually_conj eventually_prod1' eventually_prod2' 
         sequentially_inf eventually_at_right_less inv_at_right_0_inf)
     by (auto simp add:prod_filter_eq_bot)
 
   have exp_pos: "exp k \<le> real x \<Longrightarrow> x > 0" for k x
     using exp_gt_zero gr0I by force 
 
   have exp_gt_1: "exp 1 \<ge> (1::real)"
     by simp
 
   have 1: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (auto intro!:landau_o.big_mono evt[where \<epsilon>="exp 1"] iffD2[OF ln_ge_iff] simp add:abs_ge_iff)
 
   have 2: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<delta>_of x)))" 
     by (auto intro!:landau_o.big_mono evt[where \<delta>="exp 1"] iffD2[OF ln_ge_iff] simp add:abs_ge_iff)
 
   have 3: " (\<lambda>x. 1) \<in> O[?F](\<lambda>x. ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x)))"
     using exp_pos
     by (intro landau_sum_2 2 evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  iffD2[OF ln_ge_iff], auto)
   have 4: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)" 
     using one_le_power
     by (intro landau_o.big_mono evt[where \<delta>="1"], auto simp add:power_one_over[symmetric])
 
   have "(\<lambda>x. 80 * (1 / (real_of_rat (\<delta>_of x))\<^sup>2)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     by (subst landau_o.big.cmult_in_iff, auto)
   hence 5: "(\<lambda>x. real (t_of x)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     unfolding  t_of_def 
     by (intro landau_real_nat landau_ceil 4, auto)
 
   have "(\<lambda>x. ln (real_of_rat (\<epsilon>_of x))) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (intro landau_o.big_mono evt[where \<epsilon>="1"], auto simp add:ln_div)
   hence 6: "(\<lambda>x. real (s_of x)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     unfolding s_of_def by (intro landau_nat_ceil 1, simp)
 
   have 7: " (\<lambda>x. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
     using exp_pos by (auto intro!: landau_o.big_mono evt[where n="exp 1"] iffD2[OF ln_ge_iff] simp: abs_ge_iff)
 
   have 8:" (\<lambda>_. 1) \<in> 
     O[?F](\<lambda>x. ln (real (n_of x)) + 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     using order_trans[OF exp_gt_1] exp_pos
     by (intro landau_sum_1 7 evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  iffD2[OF ln_ge_iff] 
         mult_nonneg_nonneg add_nonneg_nonneg) auto
 
   have "(\<lambda>x. ln (real (s_of x) + 1)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (intro landau_ln_3 sum_in_bigo 6 1, simp)
 
   hence 9: "(\<lambda>x. log 2 (real (s_of x) + 1)) \<in> O[?F](g)"
     unfolding g_def by (intro landau_o.big_mult_1 8, auto simp:log_def)
   have 10: "(\<lambda>x. 1) \<in> O[?F](g)"
     unfolding g_def by (intro landau_o.big_mult_1 8 1)
 
   have "(\<lambda>x. ln (real (t_of x) + 1)) \<in> 
     O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     using 5 by (intro landau_o.big_mult_1 3 landau_ln_3 sum_in_bigo 4, simp_all)
   hence " (\<lambda>x. log 2 (real (t_of x) + 1)) \<in> 
   O[?F](\<lambda>x. ln (real (n_of x)) + 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     using order_trans[OF exp_gt_1] exp_pos
     by (intro landau_sum_2  evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  iffD2[OF ln_ge_iff] 
         mult_nonneg_nonneg add_nonneg_nonneg) (auto simp add:log_def)
   hence 11: "(\<lambda>x. log 2 (real (t_of x) + 1)) \<in> O[?F](g)"
     unfolding g_def  by (intro landau_o.big_mult_1' 1, auto)
   have " (\<lambda>x. 1) \<in> O[?F](\<lambda>x. real (n_of x))" 
     by (intro landau_o.big_mono evt[where n="1"], auto)
   hence "(\<lambda>x. ln (real (n_of x) + 21)) \<in> O[?F](\<lambda>x. ln (real (n_of x)))" 
     by (intro landau_ln_2[where a="2"] evt[where n="2"] sum_in_bigo, auto)
 
   hence 12: "(\<lambda>x. log 2 (real (n_of x) + 21)) \<in> O[?F](g)"
     unfolding g_def using exp_pos order_trans[OF exp_gt_1]
     by (intro landau_o.big_mult_1' 1 landau_sum_1  evt[where n="exp 1" and \<delta>="1"] 
         ln_ge_zero  iffD2[OF ln_ge_iff] mult_nonneg_nonneg add_nonneg_nonneg)  (auto simp add:log_def)
 
   have "(\<lambda>x. ln (1 / real_of_rat (\<delta>_of x))) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)" 
     by (intro landau_ln_3 evt[where \<delta>="1"] landau_o.big_mono) 
       (auto simp add:power_one_over[symmetric] self_le_power)
   hence " (\<lambda>x. real (nat (4*\<lceil>log 2 (1 / real_of_rat (\<delta>_of x))\<rceil>+23))) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     using 4 by (auto intro!: landau_real_nat sum_in_bigo landau_ceil simp:log_def)
   hence " (\<lambda>x. ln (real (r_of x) + 1)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     unfolding r_of_def
     by (intro landau_ln_3 sum_in_bigo 4, auto)
   hence " (\<lambda>x. log 2 (real (r_of x) + 1)) \<in> 
     O[?F](\<lambda>x. (1 / (real_of_rat (\<delta>_of x))\<^sup>2) * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     by (intro landau_o.big_mult_1 3, simp add:log_def)
   hence " (\<lambda>x. log 2 (real (r_of x) + 1)) \<in> 
     O[?F](\<lambda>x. ln (real (n_of x)) + 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     using exp_pos order_trans[OF exp_gt_1]
     by (intro landau_sum_2 evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  
         iffD2[OF ln_ge_iff] add_nonneg_nonneg mult_nonneg_nonneg) (auto)
   hence 13: "(\<lambda>x. log 2 (real (r_of x) + 1)) \<in> O[?F](g)"
     unfolding g_def  by (intro landau_o.big_mult_1' 1, auto)
   have 14: "(\<lambda>x. 1) \<in> O[?F](\<lambda>x. real (n_of x))" 
     by (intro landau_o.big_mono evt[where n="1"], auto)
 
   have "(\<lambda>x. ln (real (n_of x) + 13)) \<in> O[?F](\<lambda>x. ln (real (n_of x)))" 
     using 14 by (intro landau_ln_2[where a="2"]  evt[where n="2"] sum_in_bigo, auto)
 
   hence "(\<lambda>x. ln (log 2 (real (n_of x) + 13))) \<in> O[?F](\<lambda>x. ln (ln (real (n_of x))))"
     using exp_pos by (intro landau_ln_2[where a="2"] iffD2[OF ln_ge_iff] evt[where n="exp 2"])
         (auto simp add:log_def)
 
   hence "(\<lambda>x. log 2 (log 2 (real (n_of x) + 13))) \<in> O[?F](\<lambda>x. ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x)))"
     using exp_pos by (intro landau_sum_1 evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  iffD2[OF ln_ge_iff])
      (auto simp add:log_def)
 
   moreover have  "(\<lambda>x. real (r_of x)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<delta>_of x)))"
     unfolding r_of_def using 2
     by (auto intro!: landau_real_nat sum_in_bigo landau_ceil simp:log_def)
   hence "(\<lambda>x. real (r_of x)) \<in> O[?F](\<lambda>x. ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x)))"
     using exp_pos 
     by (intro landau_sum_2 evt[where n="exp 1" and \<delta>="1"] ln_ge_zero  iffD2[OF ln_ge_iff], auto)
 
   ultimately have 15:" (\<lambda>x. real (t_of x) * (13 + 4 * real (r_of x) + 2 * log 2 (log 2 (real (n_of x) + 13))))
       \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
     using 5 3 
     by (intro landau_o.mult sum_in_bigo, auto)
 
   have "(\<lambda>x. 5 + 2 * log 2 (21 + real (n_of x)) + real (t_of x) * (13 + 4 * real (r_of x) + 2 * log 2 (log 2 (real (n_of x) + 13))))
       \<in> O[?F](\<lambda>x. ln (real (n_of x)) + 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x))))"
   proof -
     have "\<forall>\<^sub>F x in ?F. 0 \<le> ln (real (n_of x))" 
       by (intro evt[where n="1"] ln_ge_zero, auto)
     moreover have "\<forall>\<^sub>F x in ?F. 0 \<le> 1 / (real_of_rat (\<delta>_of x))\<^sup>2 * (ln (ln (real (n_of x))) + ln (1 / real_of_rat (\<delta>_of x)))"
       using exp_pos
       by (intro evt[where n="exp 1" and \<delta>="1"] mult_nonneg_nonneg add_nonneg_nonneg 
           ln_ge_zero iffD2[OF ln_ge_iff]) auto
     moreover have " (\<lambda>x. ln (21 + real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)))" 
       using 14 by (intro landau_ln_2[where a="2"] sum_in_bigo evt[where n="2"], auto)
     hence "(\<lambda>x. 5 + 2 * log 2 (21 + real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
       using 7  by (intro sum_in_bigo, auto simp add:log_def)
     ultimately show ?thesis
       using 15 by (rule landau_sum)
   qed
 
   hence 16: "(\<lambda>x. real (s_of x) * (5 + 2 * log 2 (21 + real (n_of x)) + real (t_of x) *
     (13 + 4 * real (r_of x) + 2 * log 2 (log 2 (real (n_of x) + 13)))))  \<in> O[?F](g)"
     unfolding g_def
     by (intro landau_o.mult 6, auto)
 
   have "f0_space_usage = (\<lambda>x. f0_space_usage (n_of x, \<epsilon>_of x, \<delta>_of x))"
     by (simp add:case_prod_beta' n_of_def \<epsilon>_of_def \<delta>_of_def)
   also have "... \<in>  O[?F](g)"
     using 9 10 11 12 13 16
     by (simp add:fun_cong[OF s_of_def[symmetric]] fun_cong[OF t_of_def[symmetric]] 
         fun_cong[OF r_of_def[symmetric]] Let_def) (intro sum_in_bigo, auto)
   also have "... = O[?F](?rhs)"
     by (simp add:case_prod_beta' g_def n_of_def \<epsilon>_of_def \<delta>_of_def)
   finally show ?thesis
     by simp
 qed
 
 end
diff --git a/thys/Frequency_Moments/Frequency_Moment_2.thy b/thys/Frequency_Moments/Frequency_Moment_2.thy
--- a/thys/Frequency_Moments/Frequency_Moment_2.thy
+++ b/thys/Frequency_Moments/Frequency_Moment_2.thy
@@ -1,721 +1,721 @@
 section \<open>Frequency Moment $2$\<close>
 
 theory Frequency_Moment_2
   imports
     Universal_Hash_Families.Carter_Wegman_Hash_Family
     Universal_Hash_Families.Universal_Hash_Families_More_Finite_Fields
     Equivalence_Relation_Enumeration.Equivalence_Relation_Enumeration
     Landau_Ext
     Median_Method.Median
     Product_PMF_Ext
     Frequency_Moments 
 begin
 
 text \<open>This section contains a formalization of the algorithm for the second frequency moment.
 It is based on the algorithm described in \<^cite>\<open>\<open>\textsection 2.2\<close> in "alon1999"\<close>.
 The only difference is that the algorithm is adapted to work with prime field of odd order, which
 greatly reduces the implementation complexity.\<close>
 
 fun f2_hash where
   "f2_hash p h k = (if even (ring.hash (mod_ring p) k h) then int p - 1 else - int p - 1)"
 
 type_synonym f2_state = "nat \<times> nat \<times> nat \<times> (nat \<times> nat \<Rightarrow> nat list) \<times> (nat \<times> nat \<Rightarrow> int)"
 
 fun f2_init :: "rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> f2_state pmf" where
   "f2_init \<delta> \<epsilon> n =
     do {
       let s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2\<rceil>;
       let s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil>;
       let p = prime_above (max n 3);
       h \<leftarrow> prod_pmf ({..<s\<^sub>1} \<times> {..<s\<^sub>2}) (\<lambda>_. pmf_of_set (bounded_degree_polynomials (mod_ring p) 4));
       return_pmf (s\<^sub>1, s\<^sub>2, p, h, (\<lambda>_ \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (0 :: int)))
     }"
 
 fun f2_update :: "nat \<Rightarrow> f2_state \<Rightarrow> f2_state pmf" where
   "f2_update x (s\<^sub>1, s\<^sub>2, p, h, sketch) = 
     return_pmf (s\<^sub>1, s\<^sub>2, p, h, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. f2_hash p (h i) x + sketch i)"
 
 fun f2_result :: "f2_state \<Rightarrow> rat pmf" where
   "f2_result (s\<^sub>1, s\<^sub>2, p, h, sketch) = 
     return_pmf (median s\<^sub>2 (\<lambda>i\<^sub>2 \<in> {..<s\<^sub>2}. 
       (\<Sum>i\<^sub>1\<in>{..<s\<^sub>1} . (rat_of_int (sketch (i\<^sub>1, i\<^sub>2)))\<^sup>2) / (((rat_of_nat p)\<^sup>2-1) * rat_of_nat s\<^sub>1)))"
 
 fun f2_space_usage :: "(nat \<times> nat \<times> rat \<times> rat) \<Rightarrow> real" where
   "f2_space_usage (n, m, \<epsilon>, \<delta>) = (
     let s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2 \<rceil> in
     let s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil> in 
     3 +
     2 * log 2 (s\<^sub>1 + 1) +
     2 * log 2 (s\<^sub>2 + 1) +
     2 * log 2 (9 + 2 * real n) +
     s\<^sub>1 * s\<^sub>2 * (5 + 4*log 2 (8 + 2 * real n) + 2 * log 2 (real m * (18 + 4 * real n) + 1 )))"
 
 definition encode_f2_state :: "f2_state \<Rightarrow> bool list option" where
   "encode_f2_state = 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>1. 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>2. 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>p. 
     (List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) \<times>\<^sub>e
     (List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e))))"
 
 lemma "inj_on encode_f2_state (dom encode_f2_state)"
 proof -
   have " is_encoding encode_f2_state"
     unfolding encode_f2_state_def
     by (intro dependent_encoding exp_golomb_encoding fun_encoding list_encoding int_encoding poly_encoding)
       
   thus ?thesis
     by (rule encoding_imp_inj)
 qed
 
 context
   fixes \<epsilon> \<delta> :: rat
   fixes n :: nat
   fixes as :: "nat list"
   fixes result
   assumes \<epsilon>_range: "\<epsilon> \<in> {0<..<1}"
   assumes \<delta>_range: "\<delta> > 0"
   assumes as_range: "set as \<subseteq> {..<n}"
   defines "result \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n) \<bind> f2_result"
 begin  
 
 private definition s\<^sub>1 where "s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2\<rceil>"
 
 lemma s1_gt_0: "s\<^sub>1 > 0"
     using \<delta>_range by (simp add:s\<^sub>1_def)
 
 private definition s\<^sub>2 where "s\<^sub>2 = nat \<lceil>-(18* ln (real_of_rat \<epsilon>))\<rceil>"
 
 lemma s2_gt_0: "s\<^sub>2 > 0"
     using \<epsilon>_range by (simp add:s\<^sub>2_def)
 
 private definition p where "p = prime_above (max n 3)"
  
 lemma p_prime: "Factorial_Ring.prime p" 
   unfolding p_def using prime_above_prime by blast
 
 lemma p_ge_3: "p \<ge> 3"
     unfolding p_def by (meson max.boundedE prime_above_lower_bound)
 
 lemma p_gt_0: "p > 0" using p_ge_3 by linarith
 
 lemma p_gt_1: "p > 1" using p_ge_3 by simp
 
 lemma p_ge_n: "p \<ge> n" unfolding p_def
   by (meson max.boundedE prime_above_lower_bound )
 
 interpretation carter_wegman_hash_family "mod_ring p" 4
   using carter_wegman_hash_familyI[OF mod_ring_is_field mod_ring_finite]
   using p_prime by auto
 
 definition sketch where "sketch = fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
 private definition \<Omega> where"\<Omega> = prod_pmf ({..<s\<^sub>1} \<times> {..<s\<^sub>2}) (\<lambda>_. pmf_of_set space)" 
 private definition \<Omega>\<^sub>p where"\<Omega>\<^sub>p = measure_pmf \<Omega>" 
 private definition sketch_rv where "sketch_rv \<omega> = of_int (sum_list (map (f2_hash p \<omega>) as))^2"
 private definition mean_rv where "mean_rv \<omega> = (\<lambda>i\<^sub>2. (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) / (((of_nat p)\<^sup>2 - 1) * of_nat s\<^sub>1))"
 private definition result_rv where "result_rv \<omega> = median s\<^sub>2 (\<lambda>i\<^sub>2\<in>{..<s\<^sub>2}. mean_rv \<omega> i\<^sub>2)"
 
 lemma mean_rv_alg_sketch:
   "sketch = \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (\<omega> i)) as)))"
 proof -
   have "sketch =  fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
     by (simp add:sketch_def)
   also have "... = \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, 
       \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (\<omega> i)) as)))"
   proof (induction as rule:rev_induct)
     case Nil
     then show ?case 
       by (simp add:s\<^sub>1_def s\<^sub>2_def space_def p_def[symmetric] \<Omega>_def restrict_def Let_def) 
   next
     case (snoc a as)
     have "fold (\<lambda>a state. state \<bind> f2_update a) (as @ [a]) (f2_init \<delta> \<epsilon> n) = \<Omega> \<bind> 
       (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>s \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (\<Sum>x \<leftarrow> as.  f2_hash p (\<omega> s) x)) \<bind> f2_update a)"
       using snoc by (simp add: bind_assoc_pmf restrict_def del:f2_hash.simps f2_init.simps)
     also have "... =  \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (\<Sum>x \<leftarrow> as@[a].  f2_hash p (\<omega> i) x)))"
       by (subst bind_return_pmf) (simp add: add.commute del:f2_hash.simps cong:restrict_cong)
     finally show ?case by blast
   qed
   finally show ?thesis by auto
 qed
 
 lemma distr:  "result = map_pmf result_rv \<Omega>"
 proof -
   have "result = sketch \<bind> f2_result"
     by (simp add:result_def sketch_def)
   also have "... = \<Omega> \<bind> (\<lambda>x. f2_result (s\<^sub>1, s\<^sub>2, p, x, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (x i)) as)))"
     by (simp add: mean_rv_alg_sketch  bind_assoc_pmf bind_return_pmf)
   also have "... = map_pmf result_rv \<Omega>"
     by (simp add:map_pmf_def result_rv_def mean_rv_def sketch_rv_def lessThan_atLeast0 cong:restrict_cong)
   finally show ?thesis by simp
 qed
 
 private lemma f2_hash_pow_exp:
   assumes "k < p"
   shows
     "expectation (\<lambda>\<omega>. real_of_int (f2_hash p \<omega> k) ^m) = 
      ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)"
 proof -
 
   have "odd p" using p_prime p_ge_3 prime_odd_nat assms by simp
   then obtain t where t_def: "p=2*t+1" 
     using oddE by blast
 
   have "Collect even \<inter> {..<2 * t + 1} \<subseteq> (*) 2 ` {..<t + 1}" 
     by (rule in_image_by_witness[where g="\<lambda>x. x div 2"], simp, linarith)
   moreover have " (*) 2 ` {..<t + 1} \<subseteq> Collect even \<inter> {..<2 * t + 1}"
     by (rule image_subsetI, simp)
   ultimately have "card ({k. even k} \<inter> {..<p}) = card ((\<lambda>x. 2*x) ` {..<t+1})"
     unfolding t_def using order_antisym by metis
   also have "... = card {..<t+1}" 
     by (rule card_image, simp add: inj_on_mult)
   also have "... =  t+1" by simp
   finally have card_even: "card ({k. even k} \<inter> {..<p}) = t+1" by simp
   hence "card ({k. even k} \<inter> {..<p}) * 2 = (p+1)" by (simp add:t_def)
   hence prob_even: "prob {\<omega>. hash k \<omega> \<in> Collect even} = (real p + 1)/(2*real p)"
     using assms by (subst prob_range, auto simp:frac_eq_eq p_gt_0 mod_ring_def) 
 
   have "p = card {..<p}" by simp
   also have "... = card (({k. odd k} \<inter> {..<p}) \<union> ({k. even k} \<inter> {..<p}))" 
     by (rule arg_cong[where f="card"], auto)
   also have "... = card ({k. odd k} \<inter> {..<p}) +  card ({k. even k} \<inter> {..<p})"
     by (rule card_Un_disjoint, simp, simp, blast)
   also have "... = card ({k. odd k} \<inter> {..<p}) + t+1"
     by (simp add:card_even)
   finally have "p = card ({k. odd k} \<inter> {..<p}) + t+1"
     by simp
   hence "card ({k. odd k} \<inter> {..<p}) * 2 = (p-1)" 
     by (simp add:t_def)
   hence prob_odd: "prob {\<omega>. hash k \<omega> \<in> Collect odd} = (real p - 1)/(2*real p)"
     using assms by (subst prob_range, auto simp add: frac_eq_eq mod_ring_def)
 
   have "expectation (\<lambda>x. real_of_int (f2_hash p x k) ^ m) =
     expectation (\<lambda>\<omega>. indicator {\<omega>. even (hash k \<omega>)} \<omega> * (real p - 1)^m + 
       indicator {\<omega>. odd (hash k \<omega>)} \<omega> * (-real p - 1)^m)" 
     by (rule Bochner_Integration.integral_cong, simp, simp)
   also have "... = 
      prob {\<omega>. hash  k \<omega> \<in> Collect even}  * (real p - 1) ^ m  + 
      prob {\<omega>. hash  k \<omega> \<in> Collect odd}  * (-real p - 1) ^ m "
     by (simp, simp add:M_def)
   also have "... = (real p + 1) * (real p - 1) ^ m / (2 * real p) + (real p - 1) * (- real p - 1) ^ m / (2 * real p)"
     by (subst prob_even, subst prob_odd, simp)
   also have "... =  
     ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)"
     by (simp add:add_divide_distrib ac_simps)
   finally show "expectation (\<lambda>x. real_of_int (f2_hash p x k) ^ m) = 
     ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)" by simp
 qed
 
 lemma 
   shows var_sketch_rv:"variance sketch_rv \<le> 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2" (is "?A")
   and exp_sketch_rv:"expectation sketch_rv = real_of_rat (F 2 as) * ((real p)\<^sup>2-1)" (is "?B")
 proof -
   define h where "h = (\<lambda>\<omega> x. real_of_int (f2_hash p \<omega> x))"
   define c where "c = (\<lambda>x. real (count_list as x))"
   define r where "r = (\<lambda>(m::nat). ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p))"
   define h_prod where "h_prod = (\<lambda>as \<omega>. prod_list (map (h \<omega>) as))" 
 
   define exp_h_prod :: "nat list \<Rightarrow> real" where "exp_h_prod = (\<lambda>as. (\<Prod>i \<in> set as. r (count_list as i)))"
 
   have f_eq: "sketch_rv = (\<lambda>\<omega>. (\<Sum>x \<in> set as. c x * h \<omega> x)^2)"
     by (rule ext, simp add:sketch_rv_def c_def h_def sum_list_eval del:f2_hash.simps)
 
   have r_one: "r (Suc 0) = 0"
     by (simp add:r_def algebra_simps)
 
   have r_two: "r 2 = (real p^2-1)"
     using p_gt_0 unfolding r_def power2_eq_square 
     by (simp add:nonzero_divide_eq_eq, simp add:algebra_simps)
 
   have"(real p)^2 \<ge> 2^2"
     by (rule power_mono, use p_gt_1 in linarith, simp)
   hence p_square_ge_4: "(real p)\<^sup>2 \<ge> 4" by simp
 
   have "r 4 = (real p)^4+2*(real p)\<^sup>2 - 3" 
     using p_gt_0 unfolding r_def
     by (subst nonzero_divide_eq_eq, auto simp:power4_eq_xxxx power2_eq_square algebra_simps)
   also have "... \<le> (real p)^4+2*(real p)\<^sup>2 + 3"
     by simp
   also have "... \<le> 3 * r 2 * r 2"
     using p_square_ge_4
     by (simp add:r_two power4_eq_xxxx power2_eq_square algebra_simps mult_left_mono)
   finally have r_four_est: "r 4 \<le> 3 * r 2 * r 2"  by simp
 
   have exp_h_prod_elim: "exp_h_prod = (\<lambda>as. prod_list (map (r \<circ> count_list as) (remdups as)))" 
     by (simp add:exp_h_prod_def prod.set_conv_list[symmetric])
 
   have exp_h_prod: "\<And>x. set x \<subseteq> set as \<Longrightarrow> length x \<le> 4 \<Longrightarrow> expectation (h_prod x) = exp_h_prod x"
   proof -
     fix x 
     assume "set x \<subseteq> set as"
     hence x_sub_p: "set x \<subseteq> {..<p}" using as_range p_ge_n by auto
     hence x_le_p: "\<And>k. k \<in> set x \<Longrightarrow> k < p" by auto
     assume "length x \<le> 4"
     hence card_x: "card (set x) \<le> 4" using card_length dual_order.trans by blast
 
     have "set x \<subseteq> carrier (mod_ring p) "
       using x_sub_p by (simp add:mod_ring_def)
 
     hence h_indep: "indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. h \<omega> i ^ count_list x i) (set x)"
       using k_wise_indep_vars_subset[OF k_wise_indep] card_x as_range h_def
       by (auto intro:indep_vars_compose2[where X="hash" and M'=" (\<lambda>_. discrete)"])
 
     have "expectation (h_prod x) = expectation (\<lambda>\<omega>. \<Prod> i \<in> set x. h \<omega> i^(count_list x i))"
       by (simp add:h_prod_def prod_list_eval)
     also have "... = (\<Prod>i \<in> set x. expectation (\<lambda>\<omega>. h \<omega> i^(count_list x i)))"
       by (simp add: indep_vars_lebesgue_integral[OF _ h_indep])
     also have "... = (\<Prod>i \<in> set x. r (count_list x i))"
       using f2_hash_pow_exp x_le_p 
       by (simp add:h_def r_def M_def[symmetric] del:f2_hash.simps)
     also have "... = exp_h_prod x"
       by (simp add:exp_h_prod_def)
     finally show "expectation (h_prod x) = exp_h_prod x" by simp
   qed
 
   have "\<And>x y. kernel_of x = kernel_of y \<Longrightarrow> exp_h_prod x = exp_h_prod y" 
   proof -
     fix x y :: "nat list"
     assume a:"kernel_of x = kernel_of y"
     then obtain f where b:"bij_betw f (set x) (set y)" and c:"\<And>z. z \<in> set x \<Longrightarrow> count_list x z = count_list y (f z)"
       using kernel_of_eq_imp_bij by blast
     have "exp_h_prod x = prod ( (\<lambda>i. r(count_list y i)) \<circ> f) (set x)"
       by (simp add:exp_h_prod_def c)
     also have "... = (\<Prod>i \<in> f ` (set x). r(count_list y i))"
       by (metis b bij_betw_def prod.reindex)
     also have "... = exp_h_prod y"
       unfolding exp_h_prod_def
       by (rule prod.cong, metis b bij_betw_def) simp
     finally show "exp_h_prod x = exp_h_prod y" by simp
   qed
 
   hence exp_h_prod_cong: "\<And>p x. of_bool (kernel_of x = kernel_of p) * exp_h_prod p = 
     of_bool (kernel_of x = kernel_of p) * exp_h_prod x" 
     by (metis (full_types) of_bool_eq_0_iff vector_space_over_itself.scale_zero_left)
 
   have c:"(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * r) = r"
     if a:"length xs = n" for xs :: "nat list" and n and r :: real
   proof -
     have "(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * 1) = (1::real)"
       using equiv_rels_2[OF a[symmetric]] by (simp add:equiv_rels_def comp_def) 
     thus "(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * r) = (r::real)" 
       by (simp add:sum_list_mult_const)
   qed
 
   have "expectation sketch_rv = (\<Sum>i\<in>set as. (\<Sum>j\<in>set as. c i * c j * expectation (h_prod [i,j])))"
     by (simp add:f_eq h_prod_def power2_eq_square sum_distrib_left sum_distrib_right Bochner_Integration.integral_sum algebra_simps)
   also have "... = (\<Sum>i\<in>set as. (\<Sum>j\<in>set as. c i * c j * exp_h_prod [i,j]))"
     by (simp add:exp_h_prod)
   also have "... = (\<Sum>i \<in> set as. (\<Sum>j \<in> set as.  
     c i * c j * (sum_list (map (\<lambda>p. of_bool (kernel_of [i,j] = kernel_of p) * exp_h_prod p) (enum_rgfs 2)))))"
     by (subst exp_h_prod_cong, simp add:c)
   also have "... = (\<Sum>i\<in>set as. c i * c i * r 2)"
     by (simp add: numeral_eq_Suc kernel_of_eq All_less_Suc exp_h_prod_elim r_one distrib_left sum.distrib sum_collapse)
   also have "... = real_of_rat (F 2 as) * ((real p)^2-1)"
     by (simp add: sum_distrib_right[symmetric] c_def F_def power2_eq_square of_rat_sum of_rat_mult r_two)
   finally show b:?B by simp
 
   have "expectation (\<lambda>x. (sketch_rv x)\<^sup>2) = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as.
     c i1 * c i2 * c i3 * c i4 * expectation (h_prod [i1, i2, i3, i4])))))"
     by (simp add:f_eq h_prod_def power4_eq_xxxx sum_distrib_left sum_distrib_right Bochner_Integration.integral_sum algebra_simps)
   also have "... = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as. 
     c i1 * c i2 * c i3 * c i4 * exp_h_prod [i1,i2,i3,i4]))))"
     by (simp add:exp_h_prod)
   also have "... = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as. 
     c i1 * c i2 * c i3 * c i4 * 
     (sum_list (map (\<lambda>p. of_bool (kernel_of [i1,i2,i3,i4] = kernel_of p) * exp_h_prod p) (enum_rgfs 4)))))))"
     by (subst exp_h_prod_cong, simp add:c)
   also have "... = 
     3 * (\<Sum>i \<in> set as. (\<Sum>j \<in> set as. c i^2 * c j^2 * r 2 * r 2)) + ((\<Sum> i \<in> set as. c i^4 * r 4) - 3 *  (\<Sum> i \<in> set as. c i ^ 4 * r 2 * r 2))"
     apply (simp add: numeral_eq_Suc exp_h_prod_elim r_one) (* large intermediate terms *)
     apply (simp add: kernel_of_eq All_less_Suc numeral_eq_Suc distrib_left sum.distrib sum_collapse neq_commute of_bool_not_iff)
     apply (simp add: algebra_simps sum_subtractf sum_collapse)
     apply (simp add: sum_distrib_left algebra_simps)
     done
   also have "... = 3 * (\<Sum>i \<in> set as. c i^2 * r 2)^2 + (\<Sum> i \<in> set as. c i ^ 4 * (r 4 - 3 * r 2 * r 2))"
     by (simp add:power2_eq_square sum_distrib_left algebra_simps sum_subtractf)
   also have "... = 3 * (\<Sum>i \<in> set as. c i^2)^2 * (r 2)^2 + (\<Sum>i \<in> set as. c i ^ 4 * (r 4 - 3 * r 2 * r 2))"
     by (simp add:power_mult_distrib sum_distrib_right[symmetric])
   also have "... \<le> 3 * (\<Sum>i \<in> set as. c i^2)^2 * (r 2)^2 + (\<Sum>i \<in> set as. c i ^ 4 * 0)"
     using r_four_est  
     by (auto intro!: sum_nonpos simp add:mult_nonneg_nonpos)
   also have "... = 3 * (real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2" 
     by (simp add:c_def r_two F_def of_rat_sum of_rat_power)
   finally have "expectation (\<lambda>x. (sketch_rv x)\<^sup>2) \<le> 3 * (real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2"
     by simp
   
   thus "variance sketch_rv \<le> 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2"
      by (simp add: variance_eq, simp add:power_mult_distrib b)
 qed
 
 lemma space_omega_1 [simp]: "Sigma_Algebra.space \<Omega>\<^sub>p = UNIV"
     by (simp add:\<Omega>\<^sub>p_def)
 
 interpretation \<Omega>: prob_space "\<Omega>\<^sub>p"
   by (simp add:\<Omega>\<^sub>p_def prob_space_measure_pmf)
 
 lemma integrable_\<Omega>:
   fixes f :: "((nat \<times> nat) \<Rightarrow> (nat list)) \<Rightarrow> real"
   shows "integrable \<Omega>\<^sub>p f"
   unfolding \<Omega>\<^sub>p_def \<Omega>_def
   by (rule integrable_measure_pmf_finite, auto intro:finite_PiE simp:set_prod_pmf)
 
 lemma sketch_rv_exp:
   assumes "i\<^sub>2 < s\<^sub>2"
   assumes "i\<^sub>1 \<in> {0..<s\<^sub>1}"
   shows "\<Omega>.expectation (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) = real_of_rat (F 2 as) * ((real p)\<^sup>2 - 1)"
 proof -
   have "\<Omega>.expectation (\<lambda>\<omega>.  (sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) :: real) = expectation sketch_rv"
     using integrable_\<Omega> integrable_M assms
     unfolding \<Omega>_def \<Omega>\<^sub>p_def M_def
     by (subst expectation_Pi_pmf_slice, auto)
   also have "... = (real_of_rat (F 2 as)) * ((real p)\<^sup>2 - 1)"
     using exp_sketch_rv by simp
   finally show ?thesis by simp
 qed
 
 lemma sketch_rv_var:
   assumes "i\<^sub>2 < s\<^sub>2"
   assumes "i\<^sub>1 \<in> {0..<s\<^sub>1}"
   shows "\<Omega>.variance (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) \<le> 2 * (real_of_rat (F 2 as))\<^sup>2 * ((real p)\<^sup>2 - 1)\<^sup>2"
 proof -
   have "\<Omega>.variance (\<lambda>\<omega>. (sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2)) :: real)) = variance sketch_rv"
     using integrable_\<Omega> integrable_M assms
     unfolding \<Omega>_def \<Omega>\<^sub>p_def M_def
     by (subst variance_prod_pmf_slice, auto)
   also have "... \<le>  2 * (real_of_rat (F 2 as))\<^sup>2 * ((real p)\<^sup>2 - 1)\<^sup>2"
     using var_sketch_rv by simp
   finally show ?thesis by simp
 qed
 
 lemma mean_rv_exp:
   assumes "i < s\<^sub>2"
   shows "\<Omega>.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = real_of_rat (F 2 as)"
 proof -
   have a:"(real p)\<^sup>2 > 1" using p_gt_1 by simp
 
   have "\<Omega>.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. \<Omega>.expectation (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i)))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)"
     using assms integrable_\<Omega> by (simp add:mean_rv_def)
   also have "... = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. real_of_rat (F 2 as) * ((real p)\<^sup>2 - 1)) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)" 
     using sketch_rv_exp[OF assms] by simp
   also have "... = real_of_rat (F 2 as)"
     using s1_gt_0 a by simp
   finally show ?thesis by simp
 qed
 
 lemma mean_rv_var:
   assumes "i < s\<^sub>2"
   shows "\<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) \<le> (real_of_rat (\<delta> * F 2 as))\<^sup>2 / 3"
 proof -
   have a: "\<Omega>.indep_vars (\<lambda>_. borel) (\<lambda>i\<^sub>1 x. sketch_rv (x (i\<^sub>1, i))) {0..<s\<^sub>1}"
     using assms
     unfolding \<Omega>\<^sub>p_def \<Omega>_def
     by (intro indep_vars_restrict_intro'[where f="fst"])
      (auto simp add: restrict_dfl_def case_prod_beta lessThan_atLeast0)
 
   have p_sq_ne_1: "(real p)^2 \<noteq> 1" 
     by (metis p_gt_1 less_numeral_extra(4) of_nat_power one_less_power pos2 semiring_char_0_class.of_nat_eq_1_iff)
 
   have s1_bound: " 6 / (real_of_rat \<delta>)\<^sup>2 \<le> real s\<^sub>1"
     unfolding s\<^sub>1_def
     by  (metis (mono_tags, opaque_lifting) of_rat_ceiling of_rat_divide of_rat_numeral_eq of_rat_power real_nat_ceiling_ge)
 
   have "\<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) = \<Omega>.variance (\<lambda>\<omega>. \<Sum>i\<^sub>1 = 0..<s\<^sub>1. sketch_rv (\<omega> (i\<^sub>1, i))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
     unfolding mean_rv_def by (subst \<Omega>.variance_divide[OF integrable_\<Omega>], simp)
   also have "... = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. \<Omega>.variance (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i)))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
-    by (subst \<Omega>.var_sum_all_indep[OF _ _ integrable_\<Omega> a]) (auto simp: \<Omega>_def \<Omega>\<^sub>p_def)
+    by (subst \<Omega>.bienaymes_identity_full_indep[OF _ _ integrable_\<Omega> a]) (auto simp: \<Omega>_def \<Omega>\<^sub>p_def)
   also have "... \<le>  (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2)  / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
     by (rule divide_right_mono, rule sum_mono[OF sketch_rv_var[OF assms]], auto)
   also have "... = 2 * (real_of_rat (F 2 as)^2) / real s\<^sub>1"
     using p_sq_ne_1 s1_gt_0 by (subst frac_eq_eq, auto simp:power2_eq_square)
   also have "... \<le> 2 * (real_of_rat (F 2 as)^2) / (6 / (real_of_rat \<delta>)\<^sup>2)"
     using  s1_gt_0 \<delta>_range by (intro divide_left_mono mult_pos_pos s1_bound) auto
   also have "... = (real_of_rat (\<delta> * F 2 as))\<^sup>2 / 3"
     by (simp add:of_rat_mult algebra_simps)
   finally show ?thesis by simp
 qed
 
 lemma mean_rv_bounds:
   assumes "i < s\<^sub>2"
   shows "\<Omega>.prob {\<omega>. real_of_rat \<delta> * real_of_rat (F 2 as) < \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>} \<le> 1/3"
 proof (cases "as = []")
   case True
   then show ?thesis
     using assms by (subst mean_rv_def, subst sketch_rv_def, simp add:F_def)
 next
   case False
   hence "F 2 as > 0" using F_gr_0 by auto
 
   hence a: "0 < real_of_rat (\<delta> * F 2 as)"
     using \<delta>_range by simp
   have [simp]: "(\<lambda>\<omega>. mean_rv \<omega> i) \<in> borel_measurable \<Omega>\<^sub>p"
     by (simp add:\<Omega>_def \<Omega>\<^sub>p_def)
   have "\<Omega>.prob {\<omega>. real_of_rat \<delta> * real_of_rat (F 2 as) < \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>} \<le> 
       \<Omega>.prob {\<omega>. real_of_rat (\<delta> * F 2 as) \<le> \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>}"
     by (rule \<Omega>.pmf_mono[OF \<Omega>\<^sub>p_def], simp add:of_rat_mult)
   also have "... \<le>  \<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) / (real_of_rat (\<delta> * F 2 as))\<^sup>2"
     using \<Omega>.Chebyshev_inequality[where a="real_of_rat (\<delta> * F 2 as)" and f="\<lambda>\<omega>. mean_rv \<omega> i",simplified] 
       a prob_space_measure_pmf[where p="\<Omega>"] mean_rv_exp[OF assms] integrable_\<Omega> by simp
   also have "... \<le> ((real_of_rat (\<delta> * F 2 as))\<^sup>2/3) / (real_of_rat (\<delta> * F 2 as))\<^sup>2"
     by (rule divide_right_mono, rule mean_rv_var[OF assms], simp)
   also  have "... = 1/3" using a by force
   finally show ?thesis by blast
 qed
 
 lemma f2_alg_correct':
    "\<P>(\<omega> in measure_pmf result. \<bar>\<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as) \<ge> 1-of_rat \<epsilon>"
 proof -
   have a: "\<Omega>.indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. mean_rv \<omega> i) {0..<s\<^sub>2}" 
     using s1_gt_0 unfolding \<Omega>\<^sub>p_def \<Omega>_def
     by (intro indep_vars_restrict_intro'[where f="snd"])
       (auto simp: \<Omega>\<^sub>p_def \<Omega>_def mean_rv_def restrict_dfl_def)
 
   have b: "- 18 * ln (real_of_rat \<epsilon>) \<le> real s\<^sub>2" 
     unfolding  s\<^sub>2_def using of_nat_ceiling by auto
 
   have "1 - of_rat \<epsilon> \<le> \<Omega>.prob {\<omega>.  \<bar>median s\<^sub>2 (mean_rv \<omega>) -  real_of_rat (F 2 as) \<bar> \<le> of_rat \<delta> * of_rat (F 2 as)}"
     using \<epsilon>_range \<Omega>.median_bound_2[OF _ a b, where \<delta>="real_of_rat \<delta> * real_of_rat (F 2 as)"
         and \<mu>="real_of_rat (F 2 as)"] mean_rv_bounds
     by simp
   also have "... = \<Omega>.prob {\<omega>.  \<bar>real_of_rat (result_rv \<omega>) - of_rat (F 2 as) \<bar> \<le> of_rat \<delta> * of_rat (F 2 as)}"
     by (simp add:result_rv_def median_restrict lessThan_atLeast0 median_rat[OF s2_gt_0]
          mean_rv_def sketch_rv_def of_rat_divide of_rat_sum of_rat_mult of_rat_diff of_rat_power)
   also have "... = \<Omega>.prob {\<omega>. \<bar>result_rv \<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as} " 
     by (simp add:of_rat_less_eq of_rat_mult[symmetric]  of_rat_diff[symmetric] set_eq_iff)
   finally have "\<Omega>.prob {y. \<bar>result_rv y - F 2 as\<bar> \<le> \<delta> * F 2 as} \<ge> 1-of_rat \<epsilon> " by simp
   thus ?thesis by (simp add: distr \<Omega>\<^sub>p_def)
 qed
 
 lemma f2_exact_space_usage':
    "AE \<omega> in sketch . bit_count (encode_f2_state \<omega>) \<le> f2_space_usage (n, length as, \<epsilon>, \<delta>)"
 proof -
   have "p \<le> 2 * max n 3 + 2"
     by (subst p_def, rule prime_above_upper_bound)
   also have "... \<le> 2 * n + 8"
     by (cases "n \<le> 2", simp_all)
   finally have p_bound: "p \<le> 2 * n + 8" 
     by simp
   have "bit_count (N\<^sub>e p) \<le> ereal (2 * log 2 (real p + 1) + 1)"
     by (rule exp_golomb_bit_count)
   also have "... \<le> ereal (2 * log 2 (2 * real n + 9) + 1)"
     using p_bound by simp
   finally have p_bit_count: "bit_count (N\<^sub>e p) \<le> ereal (2 * log 2 (2 * real n + 9) + 1)"
     by simp
 
   have a: "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. 
       sum_list (map (f2_hash p (y i)) as))) \<le> ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))"
     if a:"y\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2} \<rightarrow>\<^sub>E bounded_degree_polynomials (mod_ring p) 4" for y
   proof -
     have "y \<in> extensional ({..<s\<^sub>1} \<times> {..<s\<^sub>2})" using a PiE_iff by blast
     hence y_ext: "y \<in> extensional (set (List.product [0..<s\<^sub>1] [0..<s\<^sub>2]))"
       by (simp add:lessThan_atLeast0)
 
     have h_bit_count_aux: "bit_count (P\<^sub>e p 4 (y x)) \<le> ereal (4 + 4 * log 2 (8 + 2 * real n))"
       if b:"x \<in>  set (List.product [0..<s\<^sub>1] [0..<s\<^sub>2])" for x
     proof -
       have "y x \<in> bounded_degree_polynomials (mod_ring p) 4"
         using b a by force
       hence "bit_count (P\<^sub>e p 4 (y x)) \<le> ereal (real 4 * (log 2 (real p) + 1))"
         by (rule bounded_degree_polynomial_bit_count[OF p_gt_1] )
       also have "... \<le> ereal (real 4 * (log 2 (8 + 2 * real n) + 1) )"
         using p_gt_0 p_bound by simp
       also have "... \<le> ereal (4 + 4 * log 2 (8 + 2 * real n))"
         by simp
       finally show ?thesis
         by blast
     qed
 
     have h_bit_count: 
       "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) y) \<le> ereal (real s\<^sub>1 * real s\<^sub>2 * (4 + 4 * log 2 (8 + 2 * real n)))"
       using fun_bit_count_est[where e="P\<^sub>e p 4", OF y_ext h_bit_count_aux]
       by simp
 
     have sketch_bit_count_aux:
       "bit_count (I\<^sub>e (sum_list (map (f2_hash p (y x)) as))) \<le> ereal (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1))" (is "?lhs \<le> ?rhs")
       if " x \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2}" for x
     proof -
       have "\<bar>sum_list (map (f2_hash p (y x)) as)\<bar> \<le> sum_list (map (abs \<circ> (f2_hash p (y x))) as)" 
         by (subst map_map[symmetric])  (rule sum_list_abs)
       also have "... \<le>  sum_list (map (\<lambda>_. (int p+1)) as)"
         by (rule sum_list_mono) (simp add:p_gt_0) 
       also have "... = int (length as) * (int p+1)"
         by (simp add: sum_list_triv)
       also have "... \<le> int (length as) * (9+2*(int n))"
         using p_bound by (intro mult_mono, auto)
       finally  have "\<bar>sum_list (map (f2_hash p (y x)) as)\<bar> \<le> int (length as) * (9 + 2 * int n)" by simp
       hence "?lhs \<le> ereal (2 * log 2 (real_of_int (2* (int (length as) * (9 + 2 * int n)) + 1)) + 1)"
         by (rule int_bit_count_est)
       also have "... = ?rhs" by (simp add:algebra_simps)
       finally show "?thesis" by simp
     qed
 
     have 
       "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as)))
       \<le> ereal (real (length (List.product [0..<s\<^sub>1] [0..<s\<^sub>2]))) * (ereal (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))"
       by (intro fun_bit_count_est)  
        (simp_all add:extensional_def lessThan_atLeast0 sketch_bit_count_aux del:f2_hash.simps)
     also have "... = ereal (real s\<^sub>1 * real s\<^sub>2 * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))"
       by simp
     finally have sketch_bit_count: 
        "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le>
       ereal (real s\<^sub>1 * real s\<^sub>2 * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))" by simp
 
     have "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le> 
       bit_count (N\<^sub>e s\<^sub>1) + bit_count (N\<^sub>e s\<^sub>2) +bit_count (N\<^sub>e p) +
       bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) y) +
       bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as)))"   
       by (simp add:Let_def s\<^sub>1_def s\<^sub>2_def encode_f2_state_def dependent_bit_count add.assoc)
     also have "... \<le> ereal (2 * log 2 (real s\<^sub>1 + 1) + 1) + ereal (2 * log 2 (real s\<^sub>2 + 1) + 1) + ereal (2 * log 2 (2 * real n + 9) + 1) + 
       (ereal (real s\<^sub>1 * real s\<^sub>2) * (4 + 4 * log 2 (8 + 2 * real n))) + 
       (ereal (real s\<^sub>1 * real s\<^sub>2) * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1) ))"
       by (intro add_mono exp_golomb_bit_count p_bit_count, auto intro: h_bit_count sketch_bit_count)
     also have "... = ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))"
       by (simp add:distrib_left add.commute s\<^sub>1_def[symmetric] s\<^sub>2_def[symmetric] Let_def)
     finally show "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le>  
       ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))" 
       by simp
   qed
 
   have "set_pmf \<Omega> = {..<s\<^sub>1} \<times> {..<s\<^sub>2} \<rightarrow>\<^sub>E bounded_degree_polynomials (mod_ring p) 4"
     by (simp add: \<Omega>_def set_prod_pmf) (simp add: space_def)
   thus ?thesis
     by (simp  add:mean_rv_alg_sketch AE_measure_pmf_iff del:f2_space_usage.simps, metis a)
 qed
 
 end
 
 
 text \<open>Main results of this section:\<close>
 
 theorem f2_alg_correct:
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> > 0"
   assumes "set as \<subseteq> {..<n}"
   defines "\<Omega> \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n) \<bind> f2_result"
   shows "\<P>(\<omega> in measure_pmf \<Omega>. \<bar>\<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as) \<ge> 1-of_rat \<epsilon>"
   using f2_alg_correct'[OF assms(1,2,3)] \<Omega>_def by auto
 
 theorem f2_exact_space_usage:
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> > 0"
   assumes "set as \<subseteq> {..<n}"
   defines "M \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
   shows "AE \<omega> in M. bit_count (encode_f2_state \<omega>) \<le> f2_space_usage (n, length as, \<epsilon>, \<delta>)"
   using f2_exact_space_usage'[OF assms(1,2,3)]
   by (subst (asm) sketch_def[OF assms(1,2,3)], subst M_def, simp)
 
 theorem f2_asymptotic_space_complexity:
   "f2_space_usage \<in> O[at_top \<times>\<^sub>F at_top \<times>\<^sub>F at_right 0 \<times>\<^sub>F at_right 0](\<lambda> (n, m, \<epsilon>, \<delta>). 
   (ln (1 / of_rat \<epsilon>)) / (of_rat \<delta>)\<^sup>2 * (ln (real n) + ln (real m)))"
   (is "_ \<in> O[?F](?rhs)")
 proof -
   define n_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "n_of = (\<lambda>(n, m, \<epsilon>, \<delta>). n)"
   define m_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "m_of = (\<lambda>(n, m, \<epsilon>, \<delta>). m)"
   define \<epsilon>_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<epsilon>_of = (\<lambda>(n, m, \<epsilon>, \<delta>). \<epsilon>)"
   define \<delta>_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<delta>_of = (\<lambda>(n, m, \<epsilon>, \<delta>). \<delta>)"
 
   define g where "g = (\<lambda>x. (1/ (of_rat (\<delta>_of x))\<^sup>2) * (ln (1 / of_rat (\<epsilon>_of x))) * (ln (real (n_of x)) + ln (real (m_of x))))"
 
   have evt: "(\<And>x. 
     0 < real_of_rat (\<delta>_of x) \<and> 0 < real_of_rat (\<epsilon>_of x) \<and> 
     1/real_of_rat (\<delta>_of x) \<ge> \<delta> \<and> 1/real_of_rat (\<epsilon>_of x) \<ge> \<epsilon> \<and>
     real (n_of x) \<ge> n \<and> real (m_of x) \<ge> m\<Longrightarrow> P x) 
     \<Longrightarrow> eventually P ?F"  (is "(\<And>x. ?prem x \<Longrightarrow> _) \<Longrightarrow> _")
     for \<delta> \<epsilon> n m P
     apply (rule eventually_mono[where P="?prem" and Q="P"])
     apply (simp add:\<epsilon>_of_def case_prod_beta' \<delta>_of_def n_of_def m_of_def)
      apply (intro eventually_conj eventually_prod1' eventually_prod2' 
         sequentially_inf eventually_at_right_less inv_at_right_0_inf)
     by (auto simp add:prod_filter_eq_bot)
 
   have unit_1: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     using one_le_power
     by (intro landau_o.big_mono evt[where \<delta>="1"], auto simp add:power_one_over[symmetric])
 
   have unit_2: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (intro landau_o.big_mono  evt[where \<epsilon>="exp 1"])
      (auto intro!:iffD2[OF ln_ge_iff] simp add:abs_ge_iff)
 
   have unit_3: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x))"
     by (intro landau_o.big_mono evt, auto)
 
   have unit_4: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (m_of x))"
     by (intro landau_o.big_mono evt, auto)
 
   have unit_5: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
     by (auto intro!: landau_o.big_mono evt[where n="exp 1"])
       (metis abs_ge_self linorder_not_le ln_ge_iff not_exp_le_zero order.trans)
 
   have unit_6: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_1 evt unit_5 iffD2[OF ln_ge_iff], auto)
 
   have unit_7: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / real_of_rat (\<epsilon>_of x))"
     by (intro landau_o.big_mono  evt[where \<epsilon>="1"], auto)
  
   have unit_8: "(\<lambda>_. 1) \<in> O[?F](g)" 
     unfolding g_def by (intro landau_o.big_mult_1 unit_1 unit_2 unit_6)
 
   have unit_9: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x) * real (m_of x))"
     by (intro landau_o.big_mult_1 unit_3 unit_4)
 
   have " (\<lambda>x. 6 * (1 / (real_of_rat (\<delta>_of x))\<^sup>2)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     by (subst landau_o.big.cmult_in_iff, simp_all)
   hence l1: "(\<lambda>x. real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     by (intro landau_real_nat  landau_rat_ceil[OF unit_1]) (simp_all add:of_rat_divide of_rat_power)
 
   have "(\<lambda>x. - ( ln (real_of_rat (\<epsilon>_of x)))) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (intro landau_o.big_mono evt) (subst ln_div, auto)
   hence l2: "(\<lambda>x. real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     by (intro landau_real_nat landau_ceil[OF unit_2], simp)
 
   have l3_aux: " (\<lambda>x. real (m_of x) * (18 + 4 * real (n_of x)) + 1) \<in> O[?F](\<lambda>x. real (n_of x) * real (m_of x))"
     by (rule sum_in_bigo[OF _unit_9], subst mult.commute)
       (intro landau_o.mult sum_in_bigo, auto simp:unit_3)
 
   have "(\<lambda>x. ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x) * real (m_of x)))"
      apply (rule landau_ln_2[where a="2"], simp, simp)
       apply (rule evt[where m="2" and n="1"])
      apply (metis dual_order.trans mult_left_mono mult_of_nat_commute of_nat_0_le_iff verit_prod_simplify(1))
     using l3_aux by simp
   also have "(\<lambda>x. ln (real (n_of x) * real (m_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln(real (m_of x)))"
     by (intro landau_o.big_mono evt[where m="1" and n="1"], auto simp add:ln_mult)
   finally have l3: "(\<lambda>x. ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     using  landau_o.big_trans by simp
 
   have l4: "(\<lambda>x. ln (8 + 2 * real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_1  evt[where n="2"] landau_ln_2[where a="2"] iffD2[OF ln_ge_iff])
      (auto intro!: sum_in_bigo simp add:unit_3)
 
   have l5: "(\<lambda>x. ln (9 + 2 * real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_1  evt[where n="2"] landau_ln_2[where a="2"] iffD2[OF ln_ge_iff])
      (auto intro!: sum_in_bigo simp add:unit_3)
 
   have l6: "(\<lambda>x. ln (real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>) + 1)) \<in> O[?F](g)"
     unfolding g_def
     by (intro landau_o.big_mult_1 landau_ln_3 sum_in_bigo unit_6 unit_2 l1 unit_1, simp)
 
   have l7: "(\<lambda>x. ln (9 + 2 * real (n_of x))) \<in> O[?F](g)"
     unfolding g_def
     by (intro landau_o.big_mult_1' unit_1 unit_2 l5)
 
   have l8: "(\<lambda>x. ln (real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>) + 1) ) \<in> O[?F](g)"
     unfolding g_def
     by (intro landau_o.big_mult_1 unit_6 landau_o.big_mult_1' unit_1 landau_ln_3 sum_in_bigo l2 unit_2) simp
 
   have l9: "(\<lambda>x. 5 + 4 * ln (8 + 2 * real (n_of x)) / ln 2 + 2 * ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1) / ln 2)
       \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro sum_in_bigo, auto simp: l3 l4 unit_6)
 
   have l10: "(\<lambda>x. real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>) * real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>) * 
       (5 + 4 * ln (8 + 2 * real (n_of x)) / ln 2 + 2 * ln(real (m_of x) * (18 + 4 * real (n_of x)) + 1) / ln 2))
       \<in> O[?F](g)"
     unfolding g_def by (intro landau_o.mult, auto simp: l1 l2 l9)
 
   have "f2_space_usage = (\<lambda>x. f2_space_usage (n_of x, m_of x, \<epsilon>_of x, \<delta>_of x))"
     by (simp add:case_prod_beta' n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def)
   also have "... \<in> O[?F](g)"
     by (auto intro!:sum_in_bigo simp:Let_def log_def l6 l7 l8 l10 unit_8)
   also have "... = O[?F](?rhs)"
     by (simp add:case_prod_beta' g_def n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def)
   finally show ?thesis by simp
 qed
 
 end
diff --git a/thys/Frequency_Moments/Frequency_Moment_k.thy b/thys/Frequency_Moments/Frequency_Moment_k.thy
--- a/thys/Frequency_Moments/Frequency_Moment_k.thy
+++ b/thys/Frequency_Moments/Frequency_Moment_k.thy
@@ -1,1015 +1,1015 @@
 section \<open>Frequency Moment $k$\<close>
 
 theory Frequency_Moment_k
   imports 
     Frequency_Moments
     Landau_Ext 
     Lp.Lp
     Median_Method.Median
     Product_PMF_Ext 
 begin
 
 text \<open>This section contains a formalization of the algorithm for the $k$-th frequency moment.
 It is based on the algorithm described in \<^cite>\<open>\<open>\textsection 2.1\<close> in "alon1999"\<close>.\<close>
 
 type_synonym fk_state = "nat \<times> nat \<times> nat \<times> nat \<times> (nat \<times> nat \<Rightarrow> (nat \<times> nat))"
 
 fun fk_init :: "nat \<Rightarrow> rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> fk_state pmf" where
   "fk_init k \<delta> \<epsilon> n =
     do {
       let s\<^sub>1 = nat \<lceil>3 * real k * n powr (1-1/real k) / (real_of_rat \<delta>)\<^sup>2\<rceil>;
       let s\<^sub>2 = nat \<lceil>-18 * ln (real_of_rat \<epsilon>)\<rceil>;
       return_pmf (s\<^sub>1, s\<^sub>2, k, 0, (\<lambda>_ \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. (0,0)))
     }"
 
 fun fk_update :: "nat \<Rightarrow> fk_state \<Rightarrow> fk_state pmf" where
   "fk_update a (s\<^sub>1, s\<^sub>2, k, m, r) = 
     do {
       coins \<leftarrow> prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. bernoulli_pmf (1/(real m+1)));
       return_pmf (s\<^sub>1, s\<^sub>2, k, m+1, \<lambda>i \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. 
         if coins i then 
           (a,0) 
         else (
           let (x,l) = r i in (x, l + of_bool (x=a))
         )
       )
     }"
 
 fun fk_result :: "fk_state \<Rightarrow> rat pmf" where
   "fk_result (s\<^sub>1, s\<^sub>2, k, m, r) = 
     return_pmf (median s\<^sub>2 (\<lambda>i\<^sub>2 \<in> {0..<s\<^sub>2}.
       (\<Sum>i\<^sub>1\<in>{0..<s\<^sub>1}. rat_of_nat (let t = snd (r (i\<^sub>1, i\<^sub>2)) + 1 in m * (t^k - (t - 1)^k))) / (rat_of_nat s\<^sub>1))
     )"
 
 lemma bernoulli_pmf_1: "bernoulli_pmf 1 = return_pmf True"
   by (rule pmf_eqI, simp add:indicator_def)
 
 fun fk_space_usage :: "(nat \<times> nat \<times> nat \<times> rat \<times> rat) \<Rightarrow> real" where
   "fk_space_usage (k, n, m, \<epsilon>, \<delta>) = (
     let s\<^sub>1 = nat \<lceil>3*real k* (real n) powr (1-1/ real k) / (real_of_rat \<delta>)\<^sup>2 \<rceil> in
     let s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil> in 
     4 +
     2 * log 2 (s\<^sub>1 + 1) +
     2 * log 2 (s\<^sub>2 + 1) +
     2 * log 2 (real k + 1) +
     2 * log 2 (real m + 1) +
     s\<^sub>1 * s\<^sub>2 * (2 + 2 * log 2 (real n+1) + 2 * log 2 (real m+1)))"
 
 definition encode_fk_state :: "fk_state \<Rightarrow> bool list option" where
   "encode_fk_state = 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>1. 
     N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>2. 
     N\<^sub>e \<times>\<^sub>e  
     N\<^sub>e \<times>\<^sub>e  
     (List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e (N\<^sub>e \<times>\<^sub>e N\<^sub>e))))"
 
 lemma "inj_on encode_fk_state (dom encode_fk_state)"
 proof -
   have "is_encoding encode_fk_state"
     by (simp add:encode_fk_state_def)
      (intro dependent_encoding exp_golomb_encoding fun_encoding)
 
   thus ?thesis by (rule encoding_imp_inj)
 qed
 
 text \<open>This is an intermediate non-parallel form @{term "fk_update"} used only in the correctness proof.\<close>
 
 fun fk_update_2 :: "'a \<Rightarrow> (nat \<times> 'a \<times> nat) \<Rightarrow> (nat \<times> 'a \<times> nat) pmf" where
   "fk_update_2 a (m,x,l) = 
     do {
       coin \<leftarrow> bernoulli_pmf (1/(real m+1));
       return_pmf (m+1,if coin then (a,0) else (x, l + of_bool (x=a)))
     }"
 
 definition sketch where "sketch as i = (as ! i, count_list (drop (i+1) as) (as ! i))"
 
 lemma fk_update_2_distr:
   assumes "as \<noteq> []"
   shows "fold (\<lambda>x s. s \<bind> fk_update_2 x) as (return_pmf (0,0,0)) =
   pmf_of_set {..<length as} \<bind> (\<lambda>k. return_pmf (length as, sketch as k))"
   using assms
 proof (induction as rule:rev_nonempty_induct)
   case (single x)
   show ?case using single 
     by (simp add:bind_return_pmf pmf_of_set_singleton bernoulli_pmf_1 lessThan_def sketch_def) 
 next
   case (snoc x xs)
   let ?h = "(\<lambda>xs k. count_list (drop (Suc k) xs) (xs ! k))"
   let ?q = "(\<lambda>xs k. (length xs, sketch xs k))"
 
   have non_empty: " {..<Suc (length xs)} \<noteq> {}" " {..<length xs} \<noteq> {}" using snoc by auto
 
   have fk_update_2_eta:"fk_update_2 x = (\<lambda>a. fk_update_2 x (fst a, fst (snd a), snd (snd a)))" 
     by auto
 
   have "pmf_of_set {..<length xs} \<bind> (\<lambda>k. bernoulli_pmf (1 / (real (length xs) + 1)) \<bind>
     (\<lambda>coin. return_pmf (if coin then length xs else k))) = 
     bernoulli_pmf (1 / (real (length xs) + 1)) \<bind> (\<lambda>y. pmf_of_set {..<length xs} \<bind>
       (\<lambda>k. return_pmf (if y then length xs else k)))"
     by (subst bind_commute_pmf, simp)
   also have "... = pmf_of_set {..<length xs + 1}"
     using snoc(1) non_empty
     by (intro pmf_eqI, simp add: pmf_bind measure_pmf_of_set)
      (simp add:indicator_def algebra_simps frac_eq_eq)
   finally have b: "pmf_of_set {..<length xs} \<bind> (\<lambda>k. bernoulli_pmf (1 / (real (length xs) + 1)) \<bind>
     (\<lambda>coin. return_pmf (if coin then length xs else k))) = pmf_of_set {..<length xs +1}" by simp
    
   have "fold (\<lambda>x s. (s \<bind> fk_update_2 x)) (xs@[x]) (return_pmf (0,0,0)) =
     (pmf_of_set {..<length xs} \<bind> (\<lambda>k. return_pmf (length xs, sketch xs k))) \<bind> fk_update_2 x"
     using snoc by (simp add:case_prod_beta')
   also have "... = (pmf_of_set {..<length xs} \<bind> (\<lambda>k. return_pmf (length xs, sketch xs k))) \<bind> 
     (\<lambda>(m,a,l). bernoulli_pmf (1 / (real m + 1)) \<bind> (\<lambda>coin. 
     return_pmf (m + 1, if coin then (x, 0) else (a, (l + of_bool (a = x))))))"
     by (subst fk_update_2_eta, subst fk_update_2.simps, simp add:case_prod_beta')
   also have "... = pmf_of_set {..<length xs} \<bind> (\<lambda>k. bernoulli_pmf (1 / (real (length xs) + 1)) \<bind>
     (\<lambda>coin. return_pmf (length xs + 1, if coin then (x, 0) else (xs ! k, ?h xs k + of_bool (xs ! k = x)))))"
     by (subst bind_assoc_pmf, simp add: bind_return_pmf sketch_def)
   also have "... = pmf_of_set {..<length xs} \<bind> (\<lambda>k. bernoulli_pmf (1 / (real (length xs) + 1)) \<bind>
     (\<lambda>coin. return_pmf (if coin then length xs else k) \<bind> (\<lambda>k'. return_pmf (?q (xs@[x]) k'))))"
     using non_empty
     by (intro bind_pmf_cong, auto simp add:bind_return_pmf nth_append count_list_append sketch_def)
   also have "... = pmf_of_set {..<length xs} \<bind> (\<lambda>k. bernoulli_pmf (1 / (real (length xs) + 1)) \<bind>
     (\<lambda>coin. return_pmf (if coin then length xs else k))) \<bind> (\<lambda>k'. return_pmf (?q (xs@[x]) k'))"
     by (subst bind_assoc_pmf, subst bind_assoc_pmf, simp)
   also have "... = pmf_of_set {..<length (xs@[x])} \<bind> (\<lambda>k'. return_pmf (?q (xs@[x]) k'))"
     by (subst b, simp)
   finally show ?case by simp
 qed
 
 context
   fixes \<epsilon> \<delta> :: rat
   fixes n k :: nat
   fixes as
   assumes k_ge_1: "k \<ge> 1"
   assumes \<epsilon>_range: "\<epsilon> \<in> {0<..<1}"
   assumes \<delta>_range: "\<delta> > 0"
   assumes as_range: "set as \<subseteq> {..<n}"
 begin
 
 definition s\<^sub>1 where "s\<^sub>1 = nat \<lceil>3 * real k * (real n) powr (1-1/real k) / (real_of_rat \<delta>)\<^sup>2\<rceil>"
 definition s\<^sub>2 where "s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil>"
 
 definition "M\<^sub>1 = {(u, v). v < count_list as u}"
 definition "\<Omega>\<^sub>1 = measure_pmf (pmf_of_set M\<^sub>1)"
 
 definition "M\<^sub>2 = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. pmf_of_set M\<^sub>1)"
 definition "\<Omega>\<^sub>2 = measure_pmf M\<^sub>2"
 
 interpretation prob_space "\<Omega>\<^sub>1"
   unfolding \<Omega>\<^sub>1_def by (simp add:prob_space_measure_pmf)
 
 interpretation \<Omega>\<^sub>2:prob_space "\<Omega>\<^sub>2"
   unfolding \<Omega>\<^sub>2_def by (simp add:prob_space_measure_pmf)
 
 lemma split_space: "(\<Sum>a\<in>M\<^sub>1. f (snd a)) = (\<Sum>u \<in> set as. (\<Sum>v \<in>{0..<count_list as u}. f v))"
 proof -
   define A where "A = (\<lambda>u. {u} \<times> {v. v < count_list as u})"
 
   have a: "inj_on snd (A x)" for x 
     by (simp add:A_def inj_on_def) 
 
   have "\<And>u v. u < count_list as v \<Longrightarrow> v \<in> set as"
     by (subst count_list_gr_1, force)
   hence "M\<^sub>1 = \<Union> (A ` set as)"
     by (auto simp add:set_eq_iff A_def M\<^sub>1_def)
   hence "(\<Sum>a\<in>M\<^sub>1. f (snd a)) = sum (f \<circ> snd)  (\<Union> (A ` set as))"
     by (intro sum.cong, auto)
   also have "... = sum (\<lambda>x. sum (f \<circ> snd) (A x)) (set as)"
     by (rule sum.UNION_disjoint, simp, simp add:A_def, simp add:A_def, blast) 
   also have "... = sum (\<lambda>x. sum f (snd ` A x)) (set as)"
     by (intro sum.cong, auto simp add:sum.reindex[OF a])
   also have "... = (\<Sum>u \<in> set as. (\<Sum>v \<in>{0..<count_list as u}. f v))"
     unfolding A_def by (intro sum.cong, auto)
   finally show ?thesis by blast
 qed
 
 lemma
   assumes "as \<noteq> []"
   shows fin_space: "finite M\<^sub>1" 
     and non_empty_space: "M\<^sub>1 \<noteq> {}"
     and card_space: "card M\<^sub>1 = length as"
 proof -
   have "M\<^sub>1 \<subseteq> set as \<times> {k. k < length as}"
   proof (rule subsetI)
     fix x
     assume a:"x \<in> M\<^sub>1"
     have "fst x \<in> set as"
       using a by (simp add:case_prod_beta count_list_gr_1 M\<^sub>1_def)
     moreover have "snd x < length as"
       using a count_le_length order_less_le_trans
       by (simp add:case_prod_beta M\<^sub>1_def) fast
     ultimately show "x \<in> set as \<times> {k. k < length as}"
       by (simp add:mem_Times_iff)
   qed
   thus fin_space: "finite M\<^sub>1"
     using finite_subset by blast
 
   have "(as ! 0, 0) \<in> M\<^sub>1" 
     using assms(1) unfolding M\<^sub>1_def
     by (simp, metis count_list_gr_1 gr0I length_greater_0_conv not_one_le_zero nth_mem)
   thus "M\<^sub>1 \<noteq> {}" by blast
 
   show "card M\<^sub>1 = length as"
     using fin_space split_space[where f="\<lambda>_. (1::nat)"]
     by (simp add:sum_count_set[where X="set as" and xs="as", simplified])
 qed
 
 lemma
   assumes "as \<noteq> []"
   shows integrable_1: "integrable \<Omega>\<^sub>1 (f :: _ \<Rightarrow> real)" and
     integrable_2: "integrable \<Omega>\<^sub>2 (g :: _ \<Rightarrow> real)"
 proof -
   have fin_omega: "finite (set_pmf (pmf_of_set M\<^sub>1))"
     using fin_space[OF assms] non_empty_space[OF assms] by auto
   thus "integrable \<Omega>\<^sub>1 f"
     unfolding \<Omega>\<^sub>1_def
     by (rule integrable_measure_pmf_finite)
 
   have "finite (set_pmf M\<^sub>2)"
     unfolding M\<^sub>2_def using fin_omega
     by (subst set_prod_pmf) (auto intro:finite_PiE)
 
   thus "integrable \<Omega>\<^sub>2 g"
     unfolding \<Omega>\<^sub>2_def by (intro integrable_measure_pmf_finite)
 qed
 
 lemma sketch_distr:
   assumes "as \<noteq> []"
   shows "pmf_of_set {..<length as} \<bind> (\<lambda>k. return_pmf (sketch as k)) = pmf_of_set M\<^sub>1"
 proof -
   have "x < y \<Longrightarrow> y < length as \<Longrightarrow> 
     count_list (drop (y+1) as) (as ! y) < count_list (drop (x+1) as) (as ! y)" for x y
     by (intro count_list_lt_suffix suffix_drop_drop, simp_all)
      (metis Suc_diff_Suc diff_Suc_Suc diff_add_inverse lessI less_natE)
   hence a1: "inj_on (sketch as) {k. k < length as}"
     unfolding sketch_def by (intro inj_onI) (metis Pair_inject mem_Collect_eq nat_neq_iff)
 
   have "x < length as \<Longrightarrow> count_list (drop (x+1) as) (as ! x) < count_list as (as ! x)" for x
     by (rule count_list_lt_suffix, auto simp add:suffix_drop)
   hence "sketch as ` {k. k < length as} \<subseteq> M\<^sub>1"
     by (intro image_subsetI, simp add:sketch_def M\<^sub>1_def)
   moreover have "card M\<^sub>1 \<le> card (sketch as ` {k. k < length as})"
     by (simp add: card_space[OF assms(1)] card_image[OF a1])
   ultimately have "sketch as ` {k. k < length as} = M\<^sub>1"
     using fin_space[OF assms(1)] by (intro card_seteq, simp_all)
   hence "bij_betw (sketch as) {k. k < length as} M\<^sub>1"
     using a1 by (simp add:bij_betw_def)
   hence "map_pmf (sketch as) (pmf_of_set {k. k < length as}) = pmf_of_set M\<^sub>1"
     using assms by (intro map_pmf_of_set_bij_betw, auto)
   thus ?thesis by (simp add: sketch_def map_pmf_def lessThan_def)
 qed
 
 lemma fk_update_distr:
   "fold (\<lambda>x s. s \<bind> fk_update x) as (fk_init k \<delta> \<epsilon> n) = 
   prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. fold (\<lambda>x s. s \<bind> fk_update_2 x) as (return_pmf (0,0,0))) 
     \<bind> (\<lambda>x. return_pmf (s\<^sub>1,s\<^sub>2,k, length as, \<lambda>i\<in>{0..<s\<^sub>1}\<times>{0..<s\<^sub>2}. snd (x i)))"
 proof (induction as rule:rev_induct)
   case Nil
   then show ?case 
     by (auto simp:Let_def s\<^sub>1_def[symmetric] s\<^sub>2_def[symmetric] bind_return_pmf)
 next
   case (snoc x xs)
 
   have fk_update_2_eta:"fk_update_2 x = (\<lambda>a. fk_update_2 x (fst a, fst (snd a), snd (snd a)))" 
     by auto
 
   have a: "fk_update x (s\<^sub>1, s\<^sub>2, k, length xs, \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (f i)) =
     prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>i. fk_update_2 x (f i)) \<bind> 
     (\<lambda>a. return_pmf (s\<^sub>1,s\<^sub>2, k, Suc (length xs), \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (a i)))"
     if b: "f \<in> set_pmf (prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) 
                   (\<lambda>_. fold (\<lambda>a s. s \<bind> fk_update_2 a) xs (return_pmf (0, 0, 0))))" for f
   proof -
     have c:"fst (f i) = length xs" if d:"i \<in> {0..<s\<^sub>1} \<times>{0..<s\<^sub>2}" for i
     proof (cases "xs = []")
       case True
       then show ?thesis using b d by (simp add: set_Pi_pmf)
     next  
       case False
       hence "{..<length xs} \<noteq> {}" by force
       thus ?thesis using b d 
         by (simp add:set_Pi_pmf fk_update_2_distr[OF False] PiE_dflt_def) force
     qed
     show ?thesis
       apply (subst fk_update_2_eta, subst fk_update_2.simps, simp)
       apply (simp add: Pi_pmf_bind_return[where d'="undefined"] bind_assoc_pmf)
       apply (rule bind_pmf_cong, simp add:c cong:Pi_pmf_cong)
       by (auto simp add:bind_return_pmf case_prod_beta)
   qed
  
   have "fold (\<lambda>x s. s \<bind> fk_update x) (xs @ [x]) (fk_init k \<delta> \<epsilon> n) = 
      prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. fold (\<lambda>x s. s \<bind> fk_update_2 x) xs (return_pmf (0,0,0))) 
     \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1,s\<^sub>2,k, length xs, \<lambda>i\<in>{0..<s\<^sub>1}\<times>{0..<s\<^sub>2}. snd (\<omega> i)) \<bind> fk_update x)"
     using snoc
     by (simp add:restrict_def bind_assoc_pmf del:fk_init.simps)
   also have "... =  prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) 
     (\<lambda>_. fold (\<lambda>a s. s \<bind> fk_update_2 a) xs (return_pmf (0, 0, 0))) \<bind>
     (\<lambda>f. prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>i. fk_update_2 x (f i)) \<bind>
     (\<lambda>a. return_pmf (s\<^sub>1, s\<^sub>2, k, Suc (length xs), \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (a i))))"
     using a
     by (intro bind_pmf_cong, simp_all add:bind_return_pmf del:fk_update.simps)
   also have "... =  prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) 
     (\<lambda>_. fold (\<lambda>a s. s \<bind> fk_update_2 a) xs (return_pmf (0, 0, 0))) \<bind>
     (\<lambda>f. prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>i. fk_update_2 x (f i))) \<bind>
     (\<lambda>a. return_pmf (s\<^sub>1, s\<^sub>2, k, Suc (length xs), \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (a i)))"
     by (simp add:bind_assoc_pmf)
   also have "... = (prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) 
     (\<lambda>_. fold (\<lambda>a s. s \<bind> fk_update_2 a) (xs@[x]) (return_pmf (0,0,0))) 
     \<bind> (\<lambda>a. return_pmf (s\<^sub>1,s\<^sub>2,k, length (xs@[x]), \<lambda>i\<in>{0..<s\<^sub>1}\<times>{0..<s\<^sub>2}. snd (a i))))"
     by (simp, subst Pi_pmf_bind, auto)
 
   finally show ?case by blast
 qed
 
 lemma power_diff_sum:
   fixes a b :: "'a :: {comm_ring_1,power}"
   assumes "k > 0"
   shows "a^k - b^k = (a-b) * (\<Sum>i = 0..<k. a ^ i * b ^ (k - 1 - i))" (is "?lhs = ?rhs")
 proof -
   have insert_lb: "m < n \<Longrightarrow> insert m {Suc m..<n} = {m..<n}" for m n :: nat
     by auto
 
   have "?rhs = sum (\<lambda>i. a * (a^i * b^(k-1-i))) {0..<k} - 
     sum (\<lambda>i. b * (a^i * b^(k-1-i))) {0..<k}"
     by (simp add: sum_distrib_left[symmetric] algebra_simps)
   also have "... = sum ((\<lambda>i. (a^i * b^(k-i))) \<circ> (\<lambda>i. i+1)) {0..<k} - 
     sum (\<lambda>i. (a^i * (b^(1+(k-1-i))))) {0..<k}"
     by (simp add:algebra_simps)
   also have "... = sum ((\<lambda>i. (a^i * b^(k-i))) \<circ> (\<lambda>i. i+1)) {0..<k} - 
     sum (\<lambda>i. (a^i * b^(k-i))) {0..<k}"
     by (intro arg_cong2[where f="(-)"] sum.cong arg_cong2[where f="(*)"] 
         arg_cong2[where f="(\<lambda>x y. x ^ y)"]) auto
   also have "... = sum (\<lambda>i. (a^i * b^(k-i))) (insert k {1..<k}) - 
     sum (\<lambda>i. (a^i * b^(k-i))) (insert 0 {Suc 0..<k})"
     using assms
     by (subst sum.reindex[symmetric], simp, subst insert_lb, auto)
   also have "... = ?lhs"
     by simp
   finally show ?thesis by presburger
 qed
 
 lemma power_diff_est:
   assumes "k > 0"
   assumes "(a :: real) \<ge> b"
   assumes "b \<ge> 0"
   shows "a^k -b^k \<le> (a-b) * k * a^(k-1)"
 proof -
   have " \<And>i. i < k \<Longrightarrow> a ^ i * b ^ (k - 1 - i) \<le> a ^ i * a ^ (k-1-i)"
     using assms by (intro mult_left_mono power_mono) auto
   also have "\<And>i. i < k \<Longrightarrow> a ^ i * a ^ (k - 1 - i) = a ^ (k - Suc 0)"
     using assms(1) by (subst power_add[symmetric], simp)
   finally have a: "\<And>i. i < k \<Longrightarrow> a ^ i * b ^ (k - 1 - i) \<le> a ^ (k - Suc 0)"
     by blast
   have "a^k - b^k = (a-b) * (\<Sum>i = 0..<k. a ^ i * b ^ (k - 1 - i))"
     by (rule power_diff_sum[OF assms(1)])
   also have "... \<le> (a-b) * (\<Sum>i = 0..<k.  a^(k-1))"
     using a assms by (intro mult_left_mono sum_mono, auto)
   also have "... = (a-b) * (k * a^(k-Suc 0))"
     by simp
   finally show ?thesis by simp
 qed
 
 text \<open>Specialization of the Hoelder inquality for sums.\<close>
 lemma Holder_inequality_sum:
   assumes "p > (0::real)" "q > 0" "1/p + 1/q = 1"
   assumes "finite A"
   shows "\<bar>\<Sum>x\<in>A. f x * g x\<bar> \<le> (\<Sum>x\<in>A. \<bar>f x\<bar> powr p) powr (1/p) * (\<Sum>x\<in>A. \<bar>g x\<bar> powr q) powr (1/q)"
 proof -
   have "\<bar>LINT x|count_space A. f x * g x\<bar> \<le> 
     (LINT x|count_space A. \<bar>f x\<bar> powr p) powr (1 / p) * 
     (LINT x|count_space A. \<bar>g x\<bar> powr q) powr (1 / q)"
     using assms integrable_count_space
     by (intro Lp.Holder_inequality, auto)
   thus ?thesis
     using assms by (simp add: lebesgue_integral_count_space_finite[symmetric])
 qed
 
 lemma real_count_list_pos:
   assumes "x \<in> set as"
   shows "real (count_list as x) > 0"
   using count_list_gr_1 assms by force
 
 lemma fk_estimate:
   assumes "as \<noteq> []"
   shows "length as * of_rat (F (2*k-1) as) \<le> n powr (1 - 1 / real k) * (of_rat (F k as))^2"
   (is "?lhs \<le> ?rhs")
 proof (cases "k \<ge> 2")
   case True
   define M where "M = Max (count_list as ` set as)" 
   have "M \<in> count_list as ` set as"
     unfolding M_def using assms by (intro Max_in, auto)
   then obtain m where m_in: "m \<in> set as" and m_def: "M = count_list as m"
     by blast
 
   have a: "real M > 0" using m_in count_list_gr_1 by (simp add:m_def, force)
   have b: "2*k-1 = (k-1) + k" by simp
 
   have " 0 < real (count_list as m)" 
     using m_in count_list_gr_1 by force
   hence "M powr k = real (count_list as m) ^ k"
     by (simp add: powr_realpow m_def)
   also have "... \<le> (\<Sum>x\<in>set as. real (count_list as x) ^ k)"
     using m_in by (intro member_le_sum, simp_all)
   also have "... \<le> real_of_rat (F k as)"
     by (simp add:F_def of_rat_sum of_rat_power)
   finally have d: "M powr k \<le> real_of_rat (F k as)" by simp
 
   have e: "0 \<le> real_of_rat (F k as)" 
     using F_gr_0[OF assms(1)] by (simp add: order_le_less)
 
   have "real (k - 1) / real k + 1 = real (k - 1) / real k + real k / real k"
     using assms True by simp
   also have "... =  real (2 * k - 1) / real k"
     using b by (subst add_divide_distrib[symmetric], force)
   finally have f: "real (k - 1) / real k + 1 = real (2 * k - 1) / real k"
     by blast
 
   have "real_of_rat (F (2*k-1) as) = 
     (\<Sum>x\<in>set as. real (count_list as x) ^ (k - 1) * real (count_list as x) ^ k)" 
     using b by (simp add:F_def of_rat_sum sum_distrib_left of_rat_mult power_add of_rat_power)
   also have "... \<le> (\<Sum>x\<in>set as. real M ^ (k - 1) * real (count_list as x) ^ k)"
     by (intro sum_mono mult_right_mono power_mono of_nat_mono) (auto simp:M_def)
   also have "... = M powr (k-1) * of_rat (F k as)" using a
     by (simp add:sum_distrib_left F_def of_rat_mult of_rat_sum of_rat_power powr_realpow)
   also have "... = (M powr k) powr (real (k - 1) / real k) * of_rat (F k as) powr 1"
     using e by (simp add:powr_powr)
   also have "... \<le>  (real_of_rat (F k as)) powr ((k-1)/k) * (real_of_rat (F k as) powr 1)"
     using d by (intro mult_right_mono powr_mono2, auto)
   also have "... = (real_of_rat (F k as)) powr ((2*k-1) / k)"
     by (subst powr_add[symmetric], subst f, simp)
   finally have a: "real_of_rat (F (2*k-1) as) \<le> (real_of_rat (F k as)) powr ((2*k-1) / k)"
     by blast
 
   have g: "card (set as) \<le> n"
     using card_mono[OF _ as_range] by simp
 
   have "length as = abs (sum (\<lambda>x. real (count_list as x)) (set as))"
     by (subst of_nat_sum[symmetric], simp add: sum_count_set)
   also have "... \<le> card (set as) powr ((k-Suc 0)/k) * 
     (sum (\<lambda>x. \<bar>real (count_list as x)\<bar> powr k) (set as)) powr (1/k)"
     using assms True
     by (intro Holder_inequality_sum[where p="k/(k-1)" and q="k" and f="\<lambda>_.1", simplified])
      (auto simp add:algebra_simps add_divide_distrib[symmetric])
   also have "... = (card (set as)) powr ((k-1) / real k) * of_rat (F k as) powr (1/ k)"
     using real_count_list_pos
     by (simp add:F_def of_rat_sum of_rat_power powr_realpow)
   also have "... = (card (set as)) powr (1 - 1 / real k) * of_rat (F k as) powr (1/ k)"
     using k_ge_1
     by (subst of_nat_diff[OF k_ge_1], subst diff_divide_distrib, simp)
   also have "... \<le> n powr (1 - 1 / real k) * of_rat (F k as) powr (1/ k)"
     using k_ge_1 g
     by (intro mult_right_mono powr_mono2, auto)
   finally have h: "length as \<le> n powr (1 - 1 / real k) * of_rat (F k as) powr (1/real k)"
     by blast
 
   have i:"1 / real k + real (2 * k - 1) / real k = real 2"
     using True by (subst add_divide_distrib[symmetric], simp_all add:of_nat_diff)
 
   have "?lhs \<le> n powr (1 - 1/k) * of_rat (F k as) powr (1/k) * (of_rat (F k as)) powr ((2*k-1) / k)"
     using a h F_ge_0 by (intro mult_mono mult_nonneg_nonneg, auto)
   also have "... = ?rhs"
     using i F_gr_0[OF assms] by (simp add:powr_add[symmetric] powr_realpow[symmetric])
   finally show ?thesis
     by blast
 next
   case False
   have "n = 0 \<Longrightarrow> False"
     using as_range assms by auto
   hence "n > 0" 
     by auto
   moreover have "k = 1"
     using assms k_ge_1 False by linarith
   moreover have "length as = real_of_rat (F (Suc 0) as)"
     by (simp add:F_def sum_count_set of_nat_sum[symmetric] del:of_nat_sum)
   ultimately show ?thesis
     by (simp add:power2_eq_square)
 qed
 
 definition result
   where "result a = of_nat (length as) * of_nat (Suc (snd a) ^ k - snd a ^ k)"
 
 lemma result_exp_1:
   assumes "as \<noteq> []"
   shows "expectation result = real_of_rat (F k as)"
 proof -
   have "expectation result = (\<Sum>a\<in>M\<^sub>1. result a * pmf (pmf_of_set M\<^sub>1) a)"
     unfolding \<Omega>\<^sub>1_def using non_empty_space assms fin_space
     by (subst integral_measure_pmf_real) auto
   also have "... = (\<Sum>a\<in>M\<^sub>1. result a / real (length as))"
    using non_empty_space assms fin_space card_space by simp
   also have "... = (\<Sum>a\<in>M\<^sub>1. real (Suc (snd a) ^ k - snd a ^ k))"
     using assms by (simp add:result_def)
   also have "... = (\<Sum>u\<in>set as. \<Sum>v = 0..<count_list as u. real (Suc v ^ k) - real (v ^ k))"
     using k_ge_1 by (subst split_space, simp add:of_nat_diff)
   also have "... = (\<Sum>u\<in>set as. real (count_list as u)^k)"
     using k_ge_1 by (subst sum_Suc_diff') (auto simp add:zero_power)
   also have "... = of_rat (F k as)"
     by (simp add:F_def of_rat_sum of_rat_power)
   finally show ?thesis by simp
 qed
 
 lemma result_var_1:
   assumes "as \<noteq> []"
   shows "variance result \<le> (of_rat (F k as))\<^sup>2 * k * n powr (1 - 1 / real k)"
 proof -  
   have k_gt_0: "k > 0" using k_ge_1 by linarith
 
   have c:"real (Suc v ^ k) - real (v ^ k) \<le> k * real (count_list as a) ^ (k - Suc 0)"
     if c_1: "v < count_list as a" for a v
   proof -
     have "real (Suc v ^ k) - real (v ^ k) \<le> (real (v+1) - real v) * k * (1 + real v) ^ (k - Suc 0)"
       using k_gt_0 power_diff_est[where a="Suc v" and b="v"] by simp
     moreover have "(real (v+1) - real v) = 1" by auto
     ultimately have "real (Suc v ^ k) - real (v ^ k) \<le> k * (1 + real v) ^ (k - Suc 0)"
       by auto
     also have "... \<le> k * real (count_list as a) ^ (k- Suc 0)"
       using c_1 by (intro mult_left_mono power_mono, auto)
     finally show ?thesis by blast
   qed
       
   have "length as * (\<Sum>a\<in> M\<^sub>1. (real (Suc (snd a)  ^ k - (snd a) ^ k))\<^sup>2) =
     length as * (\<Sum>a\<in> set as. (\<Sum>v \<in> {0..<count_list as a}. 
     real (Suc v ^ k - v ^ k) * real (Suc v ^ k - v^k)))"
     by (subst split_space, simp add:power2_eq_square)
   also have "... \<le> length as * (\<Sum>a\<in> set as. (\<Sum>v \<in> {0..<count_list as a}. 
     k * real (count_list as a) ^ (k-1) * real (Suc v ^ k - v ^ k)))"
     using c by (intro mult_left_mono sum_mono mult_right_mono) (auto simp:power_mono of_nat_diff)
   also have "... = length as * k * (\<Sum>a\<in> set as. real (count_list as a) ^ (k-1) * 
     (\<Sum>v \<in> {0..<count_list as a}. real (Suc v ^ k) - real (v ^ k)))"
     by (simp add:sum_distrib_left ac_simps of_nat_diff power_mono)
   also have "... = length as * k * (\<Sum>a\<in> set as. real (count_list as a ^ (2*k-1)))"
     using assms k_ge_1
     by (subst sum_Suc_diff', auto simp: zero_power[OF k_gt_0] mult_2 power_add[symmetric])
   also have "... = k * (length as * of_rat (F (2*k-1) as))"
     by (simp add:sum_distrib_left[symmetric] F_def of_rat_sum of_rat_power)
   also have "... \<le> k * (of_rat (F k as)^2 * n powr (1 - 1 / real k))"
     using fk_estimate[OF assms] by (intro mult_left_mono) (auto simp: mult.commute)
   finally have b: "real (length as) * (\<Sum>a\<in> M\<^sub>1. (real (Suc (snd a) ^ k - (snd a) ^ k))\<^sup>2) \<le> 
     k * ((of_rat (F k as))\<^sup>2 * n powr (1 - 1 / real k))"
     by blast
 
   have "expectation (\<lambda>\<omega>. (result \<omega> :: real)^2) - (expectation result)^2 \<le> expectation (\<lambda>\<omega>. result \<omega>^2)"
     by simp
   also have "... = (\<Sum>a\<in>M\<^sub>1. (length as * real (Suc (snd a) ^ k - snd a ^ k))\<^sup>2 * pmf (pmf_of_set M\<^sub>1) a)"
     using fin_space non_empty_space assms unfolding \<Omega>\<^sub>1_def result_def
     by (subst integral_measure_pmf_real[where A="M\<^sub>1"], auto)
   also have "... = (\<Sum>a\<in>M\<^sub>1. length as * (real (Suc (snd a) ^ k - snd a ^ k))\<^sup>2)"
     using assms non_empty_space fin_space by (subst pmf_of_set)
      (simp_all add:card_space power_mult_distrib power2_eq_square ac_simps)
   also have "... \<le> k * ((of_rat (F k as))\<^sup>2 * n powr (1 - 1 / real k))"
     using b by (simp add:sum_distrib_left[symmetric])
   also have "... = of_rat (F k as)^2 * k * n powr (1 - 1 / real k)"
     by (simp add:ac_simps)
   finally have "expectation (\<lambda>\<omega>. result \<omega>^2) - (expectation result)^2 \<le> 
     of_rat (F k as)^2 * k * n powr (1 - 1 / real k)"
     by blast
 
   thus ?thesis
     using integrable_1[OF assms] by (simp add:variance_eq)
 qed
 
 theorem fk_alg_sketch:
   assumes "as \<noteq> []"
   shows "fold (\<lambda>a state. state \<bind> fk_update a) as (fk_init k \<delta> \<epsilon> n) = 
     map_pmf (\<lambda>x. (s\<^sub>1,s\<^sub>2,k,length as, x)) M\<^sub>2" (is "?lhs = ?rhs")
 proof -
   have "?lhs = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) 
     (\<lambda>_. fold (\<lambda>x s. s \<bind> fk_update_2 x) as (return_pmf (0, 0, 0))) \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (x i)))"
     by (subst fk_update_distr, simp)
   also have "... = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. pmf_of_set {..<length as} \<bind> 
     (\<lambda>k. return_pmf (length as, sketch as k))) \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (x i)))"
     by (subst fk_update_2_distr[OF assms], simp)
   also have "... = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. pmf_of_set {..<length as} \<bind> 
     (\<lambda>k. return_pmf (sketch as k)) \<bind> (\<lambda>s. return_pmf (length as, s))) \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (x i)))"
     by (subst bind_assoc_pmf, subst bind_return_pmf, simp)
   also have "... = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. pmf_of_set {..<length as} \<bind> 
     (\<lambda>k. return_pmf (sketch as k))) \<bind>
     (\<lambda>x. return_pmf (\<lambda>i \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. (length as, x i))) \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, \<lambda>i\<in>{0..<s\<^sub>1} \<times> {0..<s\<^sub>2}. snd (x i)))"
     by (subst Pi_pmf_bind_return[where d'="undefined"], simp, simp add:restrict_def)
   also have "... = prod_pmf ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2}) (\<lambda>_. pmf_of_set {..<length as} \<bind> 
     (\<lambda>k. return_pmf (sketch as k))) \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, restrict x ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2})))"
     by (subst bind_assoc_pmf, simp add:bind_return_pmf cong:restrict_cong)
   also have "... = M\<^sub>2 \<bind>
     (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, restrict x ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2})))"
     by (subst sketch_distr[OF assms], simp add:M\<^sub>2_def)
   also have "... = M\<^sub>2 \<bind> (\<lambda>x. return_pmf (s\<^sub>1, s\<^sub>2, k, length as, x))"
     by (rule bind_pmf_cong, auto simp add:PiE_dflt_def M\<^sub>2_def set_Pi_pmf) 
   also have "... = ?rhs"
     by (simp add:map_pmf_def)
   finally show ?thesis by simp
 qed
 
 definition mean_rv 
   where "mean_rv \<omega> i\<^sub>2 = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. result (\<omega> (i\<^sub>1, i\<^sub>2))) / of_nat s\<^sub>1"
 
 definition median_rv 
     where "median_rv \<omega> = median s\<^sub>2 (\<lambda>i\<^sub>2. mean_rv \<omega> i\<^sub>2)"
 
 lemma fk_alg_correct':
   defines "M \<equiv> fold (\<lambda>a state. state \<bind> fk_update a) as (fk_init k \<delta> \<epsilon> n) \<bind> fk_result"
   shows "\<P>(\<omega> in measure_pmf M. \<bar>\<omega> - F k as\<bar> \<le> \<delta> * F k as) \<ge> 1 - of_rat \<epsilon>"
 proof (cases "as = []")
   case True
   have a: "nat \<lceil>- (18 * ln (real_of_rat \<epsilon>))\<rceil> > 0"  using \<epsilon>_range by simp 
   show ?thesis using True \<epsilon>_range 
     by (simp add:F_def M_def bind_return_pmf median_const[OF a] Let_def)
 next
   case False
 
   have "set as \<noteq> {}" using assms False by blast
   hence n_nonzero: "n > 0" using as_range by fastforce
 
   have fk_nonzero: "F k as > 0"
     using F_gr_0[OF False] by simp
 
   have s1_nonzero: "s\<^sub>1 > 0"
     using \<delta>_range k_ge_1 n_nonzero by (simp add:s\<^sub>1_def)
   have s2_nonzero: "s\<^sub>2 > 0"
     using \<epsilon>_range by (simp add:s\<^sub>2_def) 
 
   have real_of_rat_mean_rv: "\<And>x i. mean_rv x = (\<lambda>i. real_of_rat (mean_rv x i))"
     by (rule ext, simp add:of_rat_divide of_rat_sum of_rat_mult result_def mean_rv_def)
   have real_of_rat_median_rv: "\<And>x. median_rv x = real_of_rat (median_rv x)"
     unfolding median_rv_def using s2_nonzero
     by (subst real_of_rat_mean_rv, simp add: median_rat median_restrict)
 
 
   have space_\<Omega>\<^sub>2: "space \<Omega>\<^sub>2 = UNIV" by (simp add:\<Omega>\<^sub>2_def)
 
   have fk_result_eta: "fk_result = (\<lambda>(x,y,z,u,v). fk_result (x,y,z,u,v))" 
     by auto 
 
   have a:"fold (\<lambda>x state. state \<bind> fk_update x) as (fk_init k \<delta> \<epsilon> n) = 
     map_pmf (\<lambda>x. (s\<^sub>1,s\<^sub>2,k,length as, x)) M\<^sub>2"
     by (subst fk_alg_sketch[OF False]) (simp add:s\<^sub>1_def[symmetric] s\<^sub>2_def[symmetric])
 
   have "M =  map_pmf (\<lambda>x. (s\<^sub>1, s\<^sub>2, k, length as, x)) M\<^sub>2 \<bind> fk_result"
     by (subst M_def, subst a, simp)
   also have "... = M\<^sub>2 \<bind> return_pmf \<circ> median_rv"
     by (subst fk_result_eta)
      (auto simp add:map_pmf_def bind_assoc_pmf bind_return_pmf median_rv_def mean_rv_def comp_def 
        M\<^sub>1_def result_def median_restrict)
   finally have b: "M = M\<^sub>2 \<bind> return_pmf \<circ> median_rv"
     by simp
 
   have result_exp: 
     "i\<^sub>1 < s\<^sub>1 \<Longrightarrow> i\<^sub>2 < s\<^sub>2 \<Longrightarrow> \<Omega>\<^sub>2.expectation (\<lambda>x. result (x (i\<^sub>1, i\<^sub>2))) = real_of_rat (F k as)"
     for i\<^sub>1 i\<^sub>2
     unfolding \<Omega>\<^sub>2_def M\<^sub>2_def
     using integrable_1[OF False] result_exp_1[OF False]
     by (subst expectation_Pi_pmf_slice, auto simp:\<Omega>\<^sub>1_def)
 
 
   have result_var: "\<Omega>\<^sub>2.variance (\<lambda>\<omega>. result (\<omega> (i\<^sub>1, i\<^sub>2))) \<le> of_rat (\<delta> * F k as)^2 * real s\<^sub>1 / 3" 
     if result_var_assms: "i\<^sub>1 < s\<^sub>1" "i\<^sub>2 < s\<^sub>2" for i\<^sub>1 i\<^sub>2
   proof -
     have "3 * real k * n powr (1 - 1 / real k) =
       (of_rat \<delta>)\<^sup>2 * (3 * real k * n powr (1 - 1 / real k) / (of_rat \<delta>)\<^sup>2)"
       using \<delta>_range by simp
     also have "... \<le>  (real_of_rat \<delta>)\<^sup>2 * (real s\<^sub>1)"
       unfolding s\<^sub>1_def
       by (intro mult_mono of_nat_ceiling, simp_all)
     finally have f2_var_2: "3 * real k * n powr (1 - 1 / real k) \<le> (of_rat \<delta>)\<^sup>2 * (real s\<^sub>1)"
       by blast
 
     have "\<Omega>\<^sub>2.variance (\<lambda>\<omega>. result (\<omega> (i\<^sub>1, i\<^sub>2)) :: real)  = variance result"
       using result_var_assms integrable_1[OF False]
       unfolding \<Omega>\<^sub>2_def M\<^sub>2_def \<Omega>\<^sub>1_def 
       by (subst variance_prod_pmf_slice, auto)
     also have "... \<le> of_rat (F k as)^2 * real k * n powr (1 - 1 / real k)"
       using assms False result_var_1 \<Omega>\<^sub>1_def by simp
     also have "... =
       of_rat (F k as)^2 * (real k * n powr (1 - 1 / real k))"
       by (simp add:ac_simps)
     also have "... \<le> of_rat (F k as)^2 * (of_rat \<delta>^2 * (real s\<^sub>1 / 3))"
       using f2_var_2 by (intro mult_left_mono, auto) 
     also have "... = of_rat (F k as * \<delta>)^2 * (real s\<^sub>1 / 3)"
       by (simp add: of_rat_mult power_mult_distrib) 
     also have "... = of_rat (\<delta> * F k as)^2 * real s\<^sub>1 / 3"
       by (simp add:ac_simps)
     finally show ?thesis
       by simp
   qed
 
   have mean_rv_exp: "\<Omega>\<^sub>2.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = real_of_rat (F k as)"
     if mean_rv_exp_assms: "i < s\<^sub>2" for i
   proof -
     have "\<Omega>\<^sub>2.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = \<Omega>\<^sub>2.expectation (\<lambda>\<omega>. \<Sum>n = 0..<s\<^sub>1. result (\<omega> (n, i)) / real s\<^sub>1)"
       by (simp add:mean_rv_def sum_divide_distrib)
     also have "... = (\<Sum>n = 0..<s\<^sub>1. \<Omega>\<^sub>2.expectation (\<lambda>\<omega>. result (\<omega> (n, i))) / real s\<^sub>1)"
       using integrable_2[OF False]
       by (subst Bochner_Integration.integral_sum, auto)
     also have "... = of_rat (F k as)"
       using s1_nonzero mean_rv_exp_assms
       by (simp add:result_exp)
     finally show ?thesis by simp
   qed
 
   have mean_rv_var: "\<Omega>\<^sub>2.variance (\<lambda>\<omega>. mean_rv \<omega> i) \<le> real_of_rat (\<delta> * F k as)^2/3" 
     if mean_rv_var_assms: "i < s\<^sub>2" for i
   proof -
     have a:"\<Omega>\<^sub>2.indep_vars (\<lambda>_. borel) (\<lambda>n x. result (x (n, i)) / real s\<^sub>1) {0..<s\<^sub>1}"
       unfolding \<Omega>\<^sub>2_def M\<^sub>2_def using mean_rv_var_assms
       by (intro indep_vars_restrict_intro'[where f="fst"], simp, simp add:restrict_dfl_def, simp, simp)
     have "\<Omega>\<^sub>2.variance (\<lambda>\<omega>. mean_rv \<omega> i) = \<Omega>\<^sub>2.variance (\<lambda>\<omega>. \<Sum>j = 0..<s\<^sub>1. result (\<omega> (j, i)) / real s\<^sub>1)"
       by (simp add:mean_rv_def sum_divide_distrib)
     also have "... = (\<Sum>j = 0..<s\<^sub>1. \<Omega>\<^sub>2.variance (\<lambda>\<omega>. result (\<omega> (j, i)) / real s\<^sub>1))"
       using a integrable_2[OF False]
-      by (subst \<Omega>\<^sub>2.var_sum_all_indep, auto simp add:\<Omega>\<^sub>2_def)
+      by (subst \<Omega>\<^sub>2.bienaymes_identity_full_indep, auto simp add:\<Omega>\<^sub>2_def)
     also have "... = (\<Sum>j = 0..<s\<^sub>1. \<Omega>\<^sub>2.variance (\<lambda>\<omega>. result (\<omega> (j, i))) / real s\<^sub>1^2)"
       using integrable_2[OF False]
       by (subst \<Omega>\<^sub>2.variance_divide, auto)
     also have "... \<le> (\<Sum>j = 0..<s\<^sub>1. ((real_of_rat (\<delta> * F k as))\<^sup>2 * real s\<^sub>1 / 3) / (real s\<^sub>1^2))"
       using result_var[OF _ mean_rv_var_assms]
       by (intro sum_mono divide_right_mono, auto)
     also have "... = real_of_rat (\<delta> * F k as)^2/3"
       using s1_nonzero
       by (simp add:algebra_simps power2_eq_square)
     finally show ?thesis by simp
   qed
 
   have "\<Omega>\<^sub>2.prob {y. of_rat (\<delta> * F k as) < \<bar>mean_rv y i - real_of_rat (F k as)\<bar>} \<le> 1/3" 
     (is "?lhs \<le> _") if c_assms: "i < s\<^sub>2" for i
   proof -
     define a where "a = real_of_rat (\<delta> * F k as)"
     have c: "0 < a" unfolding  a_def
       using assms \<delta>_range fk_nonzero
       by (metis zero_less_of_rat_iff mult_pos_pos)
     have "?lhs \<le> \<Omega>\<^sub>2.prob {y \<in> space \<Omega>\<^sub>2. a \<le> \<bar>mean_rv y i -  \<Omega>\<^sub>2.expectation (\<lambda>\<omega>. mean_rv \<omega> i)\<bar>}"
       by (intro \<Omega>\<^sub>2.pmf_mono[OF \<Omega>\<^sub>2_def], simp add:a_def mean_rv_exp[OF c_assms] space_\<Omega>\<^sub>2) 
     also have "... \<le> \<Omega>\<^sub>2.variance (\<lambda>\<omega>. mean_rv \<omega> i)/a^2"
       by (intro \<Omega>\<^sub>2.Chebyshev_inequality integrable_2 c False)  (simp add:\<Omega>\<^sub>2_def)
     also have "... \<le> 1/3" using c
       using mean_rv_var[OF c_assms] 
       by (simp add:algebra_simps, simp add:a_def)
     finally show ?thesis
       by blast
   qed
 
   moreover have "\<Omega>\<^sub>2.indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. mean_rv \<omega> i) {0..<s\<^sub>2}"
     using s1_nonzero unfolding \<Omega>\<^sub>2_def M\<^sub>2_def
     by (intro indep_vars_restrict_intro'[where f="snd"] finite_cartesian_product)
      (simp_all add:mean_rv_def restrict_dfl_def space_\<Omega>\<^sub>2)
   moreover have " - (18 * ln (real_of_rat \<epsilon>)) \<le> real s\<^sub>2"
     by (simp add:s\<^sub>2_def, linarith)
   ultimately have "1 - of_rat \<epsilon> \<le> 
     \<Omega>\<^sub>2.prob {y \<in> space \<Omega>\<^sub>2. \<bar>median s\<^sub>2 (mean_rv y) - real_of_rat (F k as)\<bar> \<le> of_rat (\<delta> * F k as)}" 
     using \<epsilon>_range
     by (intro \<Omega>\<^sub>2.median_bound_2, simp_all add:space_\<Omega>\<^sub>2)
   also have "... = \<Omega>\<^sub>2.prob {y. \<bar>median_rv y - real_of_rat (F k as)\<bar> \<le> real_of_rat (\<delta> * F k as)}" 
     by (simp add:median_rv_def space_\<Omega>\<^sub>2)
   also have "... =  \<Omega>\<^sub>2.prob {y. \<bar>median_rv y - F k as\<bar> \<le> \<delta> * F k as}"
     by (simp add:real_of_rat_median_rv of_rat_less_eq flip: of_rat_diff)
   also have "... = \<P>(\<omega> in measure_pmf M. \<bar>\<omega> - F k as\<bar> \<le> \<delta> * F k as)"
     by (simp add: b comp_def map_pmf_def[symmetric] \<Omega>\<^sub>2_def)
   finally show ?thesis by simp
 qed
 
 lemma fk_exact_space_usage':
   defines "M \<equiv> fold (\<lambda>a state. state \<bind> fk_update a) as (fk_init k \<delta> \<epsilon> n)"
   shows "AE \<omega> in M. bit_count (encode_fk_state \<omega>) \<le> fk_space_usage (k, n, length as, \<epsilon>, \<delta>)"
     (is "AE \<omega> in M. (_  \<le> ?rhs)")
 proof -
   define H where "H = (if as = [] then return_pmf (\<lambda>i\<in> {0..<s\<^sub>1}\<times>{0..<s\<^sub>2}. (0,0)) else M\<^sub>2)"
 
   have a:"M = map_pmf (\<lambda>x.(s\<^sub>1,s\<^sub>2,k,length as, x)) H"
   proof (cases "as \<noteq> []")
     case True
     then show ?thesis 
       unfolding M_def fk_alg_sketch[OF True] H_def
       by (simp add:M\<^sub>2_def)
   next
     case False
     then show ?thesis
       by (simp add:H_def M_def s\<^sub>1_def[symmetric] Let_def s\<^sub>2_def[symmetric] map_pmf_def bind_return_pmf)
   qed
 
   have "bit_count (encode_fk_state (s\<^sub>1, s\<^sub>2, k, length as, y)) \<le> ?rhs"
     if b:"y \<in> set_pmf H" for y
   proof -
     have b0:" as \<noteq> [] \<Longrightarrow> y \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2} \<rightarrow>\<^sub>E M\<^sub>1"
       using b non_empty_space fin_space by (simp add:H_def M\<^sub>2_def set_prod_pmf)
 
     have "bit_count ((N\<^sub>e \<times>\<^sub>e N\<^sub>e) (y x)) \<le> 
       ereal (2 * log 2 (real n + 1) + 1) + ereal (2 * log 2 (real (length as) + 1) + 1)"
       (is "_ \<le> ?rhs1")
       if b1_assms: "x \<in> {0..<s\<^sub>1}\<times>{0..<s\<^sub>2}" for x
     proof -
       have "fst (y x) \<le> n"
       proof (cases "as = []")
         case True
         then show ?thesis using b b1_assms by (simp add:H_def)
       next
         case False
         hence "1 \<le> count_list as (fst (y x))"
           using b0 b1_assms by (simp add:PiE_iff case_prod_beta M\<^sub>1_def, fastforce)
         hence "fst (y x) \<in> set as"
           using count_list_gr_1 by metis
         then show ?thesis 
           by (meson lessThan_iff less_imp_le_nat subsetD as_range)
       qed
       moreover have "snd (y x) \<le> length as" 
       proof (cases "as = []")
         case True
         then show ?thesis using b b1_assms by (simp add:H_def)
       next
         case False
         hence "(y x) \<in> M\<^sub>1"
           using b0 b1_assms by auto
         hence "snd (y x) \<le> count_list as (fst (y x))"
           by (simp add:M\<^sub>1_def case_prod_beta)
         then show ?thesis using count_le_length by (metis order_trans)
       qed
       ultimately have "bit_count (N\<^sub>e (fst (y x))) + bit_count (N\<^sub>e (snd (y x))) \<le> ?rhs1"
         using exp_golomb_bit_count_est  by (intro add_mono, auto)
       thus ?thesis
         by (subst dependent_bit_count_2, simp)
     qed
 
     moreover have "y \<in> extensional ({0..<s\<^sub>1} \<times> {0..<s\<^sub>2})"
       using b0 b PiE_iff by (cases "as = []", auto simp:H_def PiE_iff)
 
     ultimately have "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e N\<^sub>e \<times>\<^sub>e N\<^sub>e) y) \<le> 
       ereal (real s\<^sub>1 * real s\<^sub>2) * (ereal (2 * log 2 (real n + 1) + 1) +
       ereal (2 * log 2 (real (length as) + 1) + 1))"
       by (intro fun_bit_count_est[where xs="(List.product [0..<s\<^sub>1] [0..<s\<^sub>2])", simplified], auto)
     hence "bit_count (encode_fk_state (s\<^sub>1, s\<^sub>2, k, length as, y)) \<le> 
        ereal (2 * log 2 (real s\<^sub>1 + 1) + 1) + 
       (ereal (2 * log 2 (real s\<^sub>2 + 1) + 1) +  
       (ereal (2 * log 2 (real k + 1) + 1) + 
       (ereal (2 * log 2 (real (length as) + 1) + 1) +  
       (ereal (real s\<^sub>1 * real s\<^sub>2) * (ereal (2 * log 2 (real n+1) + 1) + 
        ereal (2 * log 2 (real (length as)+1) + 1))))))"
       unfolding encode_fk_state_def dependent_bit_count
       by (intro add_mono exp_golomb_bit_count, auto)
     also have "... \<le> ?rhs" 
       by (simp add: s\<^sub>1_def[symmetric] s\<^sub>2_def[symmetric] Let_def) (simp add:ac_simps)
     finally show "bit_count (encode_fk_state (s\<^sub>1, s\<^sub>2, k, length as, y)) \<le> ?rhs"
       by blast
   qed
   thus ?thesis
     by (simp add: a AE_measure_pmf_iff del:fk_space_usage.simps)
 qed
 
 end
 
 text \<open>Main results of this section:\<close>
 
 theorem fk_alg_correct:
   assumes "k \<ge> 1"
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> > 0"
   assumes "set as \<subseteq> {..<n}"
   defines "M \<equiv> fold (\<lambda>a state. state \<bind> fk_update a) as (fk_init k \<delta> \<epsilon> n) \<bind> fk_result"
   shows "\<P>(\<omega> in measure_pmf M. \<bar>\<omega> - F k as\<bar> \<le> \<delta> * F k as) \<ge> 1 - of_rat \<epsilon>"
   unfolding M_def using fk_alg_correct'[OF assms(1-4)] by blast
 
 theorem fk_exact_space_usage:
   assumes "k \<ge> 1"
   assumes "\<epsilon> \<in> {0<..<1}"
   assumes "\<delta> > 0"
   assumes "set as \<subseteq> {..<n}"
   defines "M \<equiv> fold (\<lambda>a state. state \<bind> fk_update a) as (fk_init k \<delta> \<epsilon> n)"
   shows "AE \<omega> in M. bit_count (encode_fk_state \<omega>) \<le> fk_space_usage (k, n, length as, \<epsilon>, \<delta>)"
   unfolding M_def using fk_exact_space_usage'[OF assms(1-4)] by blast
 
 theorem fk_asymptotic_space_complexity:
   "fk_space_usage \<in> 
   O[at_top \<times>\<^sub>F at_top \<times>\<^sub>F at_top \<times>\<^sub>F at_right (0::rat) \<times>\<^sub>F at_right (0::rat)](\<lambda> (k, n, m, \<epsilon>, \<delta>).
   real k * real n powr (1-1/ real k) / (of_rat \<delta>)\<^sup>2 * (ln (1 / of_rat \<epsilon>)) * (ln (real n) + ln (real m)))"
   (is "_ \<in> O[?F](?rhs)")
 proof -
   define k_of :: "nat \<times> nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "k_of = (\<lambda>(k, n, m, \<epsilon>, \<delta>). k)"
   define n_of :: "nat \<times> nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "n_of = (\<lambda>(k, n, m, \<epsilon>, \<delta>). n)"
   define m_of :: "nat \<times> nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "m_of = (\<lambda>(k, n, m, \<epsilon>, \<delta>). m)"
   define \<epsilon>_of :: "nat \<times> nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<epsilon>_of = (\<lambda>(k, n, m, \<epsilon>, \<delta>). \<epsilon>)"
   define \<delta>_of :: "nat \<times> nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<delta>_of = (\<lambda>(k, n, m, \<epsilon>, \<delta>). \<delta>)"
 
   define g1 where 
     "g1 = (\<lambda>x. real (k_of x)*(real (n_of x)) powr (1-1/ real (k_of x)) * (1 / of_rat (\<delta>_of x)^2))"
 
   define g where 
     "g = (\<lambda>x. g1 x * (ln (1 / of_rat (\<epsilon>_of x))) * (ln (real (n_of x)) + ln (real (m_of x))))"
 
   define s1_of where "s1_of = (\<lambda>x. 
     nat \<lceil>3 * real (k_of x) * real (n_of x) powr (1 - 1 / real (k_of x)) / (real_of_rat (\<delta>_of x))\<^sup>2\<rceil>)"
   define s2_of where "s2_of = (\<lambda>x. nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>)"
 
   have evt: "(\<And>x. 
     0 < real_of_rat (\<delta>_of x) \<and> 0 < real_of_rat (\<epsilon>_of x) \<and> 
     1/real_of_rat (\<delta>_of x) \<ge> \<delta> \<and> 1/real_of_rat (\<epsilon>_of x) \<ge> \<epsilon> \<and>
     real (n_of x) \<ge> n \<and> real (k_of x) \<ge> k \<and> real (m_of x) \<ge> m\<Longrightarrow> P x) 
     \<Longrightarrow> eventually P ?F"  (is "(\<And>x. ?prem x \<Longrightarrow> _) \<Longrightarrow> _")
     for \<delta> \<epsilon> n k m P
     apply (rule eventually_mono[where P="?prem" and Q="P"])
     apply (simp add:\<epsilon>_of_def case_prod_beta' \<delta>_of_def n_of_def k_of_def m_of_def)
      apply (intro eventually_conj eventually_prod1' eventually_prod2'
         sequentially_inf eventually_at_right_less inv_at_right_0_inf)
     by (auto simp add:prod_filter_eq_bot)
 
   have 1: 
     "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x))"
     "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (m_of x))"
     "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (k_of x))"
     by (intro landau_o.big_mono eventually_mono[OF evt], auto)+
 
 
   have "(\<lambda>x. ln (real (m_of x) + 1)) \<in> O[?F](\<lambda>x. ln (real (m_of x)))"
     by (intro landau_ln_2[where a="2"] evt[where m="2"] sum_in_bigo 1, auto)
   hence 2: " (\<lambda>x. log 2 (real (m_of x) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_2  eventually_mono[OF evt[where n="1" and m="1"]])
      (auto simp add:log_def)
 
   have 3: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))" 
     using order_less_le_trans[OF exp_gt_zero] ln_ge_iff
     by (intro landau_o.big_mono  evt[where \<epsilon>="exp 1"])
      (simp add: abs_ge_iff, blast)
 
   have 4: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
     using one_le_power
     by (intro landau_o.big_mono evt[where \<delta>="1"])
      (simp add:power_one_over[symmetric], blast)
 
   have "(\<lambda>x. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
     using order_less_le_trans[OF exp_gt_zero] ln_ge_iff
     by (intro landau_o.big_mono  evt[where n="exp 1"])
      (simp add: abs_ge_iff, blast)
 
   hence 5: "(\<lambda>x. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_1 evt[where n="1" and m="1"], auto)
 
   have "(\<lambda>x. -ln(of_rat (\<epsilon>_of x))) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))" 
     by (intro landau_o.big_mono evt) (auto simp add:ln_div)
   hence 6: "(\<lambda>x. real (s2_of x)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     unfolding s2_of_def
     by (intro landau_nat_ceil 3, simp)
 
   have 7: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x) powr (1 - 1 / real (k_of x)))"
     by (intro landau_o.big_mono evt[where n="1" and k="1"])
      (auto simp add: ge_one_powr_ge_zero)
 
   have 8: "(\<lambda>_. 1) \<in> O[?F](g1)"
     unfolding g1_def by (intro landau_o.big_mult_1 1 7 4)
 
   have "(\<lambda>x. 3 * (real (k_of x) * (n_of x) powr (1 - 1 / real (k_of x)) / (of_rat (\<delta>_of x))\<^sup>2))
     \<in> O[?F](g1)"
     by (subst landau_o.big.cmult_in_iff, simp, simp add:g1_def)
   hence 9: "(\<lambda>x. real (s1_of x)) \<in> O[?F](g1)"
     unfolding s1_of_def by (intro landau_nat_ceil 8, auto simp:ac_simps)
 
   have 10: "(\<lambda>_. 1) \<in> O[?F](g)" 
     unfolding g_def by (intro landau_o.big_mult_1 8 3 5)
   
   have "(\<lambda>x. real (s1_of x)) \<in> O[?F](g)"
     unfolding g_def by (intro landau_o.big_mult_1 5 3 9)
   hence "(\<lambda>x. ln (real (s1_of x) + 1)) \<in> O[?F](g)"
     using 10 by (intro landau_ln_3 sum_in_bigo, auto)
   hence 11: "(\<lambda>x. log 2 (real (s1_of x) + 1)) \<in> O[?F](g)"
     by (simp add:log_def)
 
   have 12: " (\<lambda>x. ln (real (s2_of x) + 1)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
     using evt[where \<epsilon>="2"] 6 3
     by (intro landau_ln_3 sum_in_bigo, auto)
 
   have 13: "(\<lambda>x. log 2 (real (s2_of x) + 1)) \<in> O[?F](g)" 
     unfolding g_def 
     by (rule landau_o.big_mult_1, rule landau_o.big_mult_1', auto simp add: 8 5 12 log_def)
 
   have "(\<lambda>x. real (k_of x)) \<in> O[?F](g1)"
     unfolding g1_def using 7 4
     by (intro landau_o.big_mult_1, simp_all)
   hence "(\<lambda>x. log 2 (real (k_of x) + 1)) \<in> O[?F](g1)"
     by (simp add:log_def) (intro landau_ln_3 sum_in_bigo 8, auto)
   hence 14: "(\<lambda>x. log 2 (real (k_of x) + 1)) \<in> O[?F](g)"
     unfolding g_def  by (intro landau_o.big_mult_1 3 5)
 
   have 15: "(\<lambda>x. log 2 (real (m_of x) + 1)) \<in> O[?F](g)"
     unfolding g_def using 2 8 3
     by (intro landau_o.big_mult_1', simp_all)
 
   have "(\<lambda>x. ln (real (n_of x) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
     by (intro landau_ln_2[where a="2"] eventually_mono[OF evt[where n="2"]] sum_in_bigo 1, auto)
   hence " (\<lambda>x. log 2 (real (n_of x) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
     by (intro landau_sum_1 evt[where n="1" and m="1"])
      (auto simp add:log_def)
   hence 16: "(\<lambda>x. real (s1_of x) * real (s2_of x) *
     (2 + 2 * log 2 (real (n_of x) + 1) + 2 * log 2 (real (m_of x) + 1))) \<in> O[?F](g)" 
     unfolding g_def using 9 6 5 2
     by (intro landau_o.mult sum_in_bigo, auto)
 
   have "fk_space_usage = (\<lambda>x. fk_space_usage (k_of x, n_of x, m_of x, \<epsilon>_of x, \<delta>_of x))"
     by (simp add:case_prod_beta' k_of_def n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def)
   also have "... \<in> O[?F](g)"
     using 10 11 13 14 15 16
     by (simp add:fun_cong[OF s1_of_def[symmetric]] fun_cong[OF s2_of_def[symmetric]] Let_def)
      (intro sum_in_bigo, auto)
   also have "... = O[?F](?rhs)"
     by (simp add:case_prod_beta' g1_def g_def n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def k_of_def)
   finally show ?thesis by simp
 qed
 
 end
diff --git a/thys/Frequency_Moments/Probability_Ext.thy b/thys/Frequency_Moments/Probability_Ext.thy
--- a/thys/Frequency_Moments/Probability_Ext.thy
+++ b/thys/Frequency_Moments/Probability_Ext.thy
@@ -1,328 +1,82 @@
 section \<open>Probability Spaces\<close>
 
 text \<open>Some additional results about probability spaces in addition to "HOL-Probability".\<close>
 
 theory Probability_Ext
   imports
     "HOL-Probability.Stream_Space"
+    Concentration_Inequalities.Bienaymes_Identity
     Universal_Hash_Families.Carter_Wegman_Hash_Family
     Frequency_Moments_Preliminary_Results
 begin
 
-text \<open>Random variables that depend on disjoint sets of the components of a product space are
-independent.\<close>
-
-lemma make_ext: 
-  assumes "\<And>x. P x = P (restrict x I)" 
-  shows "(\<forall>x \<in> Pi I A. P x) = (\<forall>x \<in> PiE I A. P x)"
-  using assms by (simp add:PiE_def Pi_def set_eq_iff, force)
+text \<open>The following aliases are here to prevent possible merge-conflicts. The lemmas have been
+moved to @{theory Concentration_Inequalities.Bienaymes_Identity} and/or
+@{theory Concentration_Inequalities.Concentration_Inequalities_Preliminary}.\<close>
 
-lemma PiE_reindex:
-  assumes "inj_on f I"
-  shows "PiE I (A \<circ> f) = (\<lambda>a. restrict (a \<circ> f) I) ` PiE (f ` I) A" (is "?lhs = ?g ` ?rhs")
-proof -
-  have "?lhs \<subseteq> ?g` ?rhs"
-  proof (rule subsetI)
-    fix x
-    assume a:"x \<in> Pi\<^sub>E I (A \<circ> f)"
-    define y where y_def: "y = (\<lambda>k. if k \<in> f ` I then x (the_inv_into I f k) else undefined)"
-    have b:"y \<in> PiE (f ` I) A" 
-      using a assms the_inv_into_f_eq[OF assms]
-      by (simp add: y_def PiE_iff extensional_def)
-    have c: "x = (\<lambda>a. restrict (a \<circ> f) I) y"
-      using a assms the_inv_into_f_eq extensional_arb
-      by (intro ext, simp add:y_def PiE_iff, fastforce) 
-    show "x \<in> ?g ` ?rhs" using b c by blast
-  qed
-  moreover have "?g ` ?rhs \<subseteq> ?lhs"
-    by (rule image_subsetI, simp add:Pi_def PiE_def)
-  ultimately show ?thesis by blast
-qed
+lemmas make_ext = forall_Pi_to_PiE
+lemmas PiE_reindex = PiE_reindex
 
 context prob_space
 begin
 
-lemma indep_sets_reindex:
-  assumes "inj_on f I"
-  shows "indep_sets A (f ` I) = indep_sets (\<lambda>i. A (f i)) I"
-proof -
-  have a:"\<And>J g. J \<subseteq> I \<Longrightarrow> (\<Prod>j \<in> f ` J. g j) = (\<Prod>j \<in> J. g (f j))"
-    by (metis assms prod.reindex_cong subset_inj_on)
-
-  have "J \<subseteq> I \<Longrightarrow> (\<Pi>\<^sub>E i \<in> J. A (f i)) = (\<lambda>a. restrict (a \<circ> f) J) ` PiE (f ` J) A" for J
-    using assms inj_on_subset 
-    by (subst PiE_reindex[symmetric]) auto
-
-  hence b:"\<And>P J. J \<subseteq> I \<Longrightarrow>  (\<And>x. P x = P (restrict x J)) \<Longrightarrow> (\<forall>A' \<in> \<Pi>\<^sub>E i \<in> J. A (f i). P A') =  (\<forall>A'\<in>PiE (f ` J) A. P (A' \<circ> f))"
-    by simp
-
-  have c:"\<And>J. J \<subseteq> I \<Longrightarrow> finite (f ` J) = finite J" 
-    by (meson assms finite_image_iff inj_on_subset)
-
-  show ?thesis
-    by (simp add:indep_sets_def all_subset_image a c)
-     (simp add:make_ext b cong:restrict_cong)+
-qed
-
-lemma indep_vars_cong_AE:
-  assumes "AE x in M. (\<forall>i \<in> I. X' i x = Y' i x)"
-  assumes "indep_vars M' X' I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> random_variable (M' i) (Y' i)"
-  shows "indep_vars M' Y' I"
-proof (cases "I \<noteq> {}")
-  case True
-
-  have a: "AE x in M. (\<lambda>i\<in>I. Y' i x) = (\<lambda>i\<in>I. X' i x)"
-    by (rule AE_mp[OF assms(1)], rule AE_I2, simp cong:restrict_cong)
-  have b: "\<And>i. i \<in> I \<Longrightarrow> random_variable (M' i) (X' i)" 
-    using assms(2) by (simp add:indep_vars_def2)
-  have c: "\<And>x. x \<in> I \<Longrightarrow> AE xa in M. X' x xa = Y' x xa" 
-    by (rule AE_mp[OF assms(1)], rule AE_I2, simp)
-
-  have "distr M (Pi\<^sub>M I M') (\<lambda>x. \<lambda>i\<in>I. Y' i x) = distr M (Pi\<^sub>M I M') (\<lambda>x. \<lambda>i\<in>I. X' i x)"
-    by (intro distr_cong_AE measurable_restrict a b assms(3)) auto
-  also have "... =  Pi\<^sub>M I (\<lambda>i. distr M (M' i) (X' i))"
-    using assms True b by (subst indep_vars_iff_distr_eq_PiM'[symmetric]) auto
-  also have "... =  Pi\<^sub>M I (\<lambda>i. distr M (M' i) (Y' i))"
-    by (intro PiM_cong distr_cong_AE c assms(3) b) auto
-  finally have "distr M (Pi\<^sub>M I M') (\<lambda>x. \<lambda>i\<in>I. Y' i x) = Pi\<^sub>M I (\<lambda>i. distr M (M' i) (Y' i))"
-    by simp
-
-  thus ?thesis
-    using True assms(3)
-    by (subst indep_vars_iff_distr_eq_PiM') auto
-next
-  case False
-  then show ?thesis
-    by (simp add:indep_vars_def2 indep_sets_def)
-qed
-
-lemma indep_vars_reindex:
-  assumes "inj_on f I"
-  assumes "indep_vars M' X' (f ` I)"
-  shows "indep_vars (M' \<circ> f) (\<lambda>k \<omega>. X' (f k) \<omega>) I"
-  using assms by (simp add:indep_vars_def2 indep_sets_reindex)
-
-lemma variance_divide:
-  fixes f :: "'a \<Rightarrow> real"
-  assumes "integrable M f"
-  shows "variance (\<lambda>\<omega>. f \<omega> / r) = variance f / r^2"
-  using assms
-  by (subst Bochner_Integration.integral_divide[OF assms(1)])
-    (simp add:diff_divide_distrib[symmetric] power2_eq_square algebra_simps)
+lemmas indep_sets_reindex = indep_sets_reindex
+lemmas indep_vars_cong_AE = indep_vars_cong_AE
+lemmas indep_vars_reindex = indep_vars_reindex
+lemmas variance_divide = variance_divide
+lemmas covariance_def = covariance_def
+lemmas real_prod_integrable = cauchy_schwartz(1)
+lemmas covariance_eq = covariance_eq
+lemmas covar_integrable = covar_integrable
+lemmas sum_square_int = sum_square_int
+lemmas var_sum_1 = bienaymes_identity
+lemmas covar_self_eq = covar_self_eq
+lemmas covar_indep_eq_zero = covar_indep_eq_zero
+lemmas var_sum_2 = bienaymes_identity_2
+lemmas var_sum_pairwise_indep = bienaymes_identity_pairwise_indep
+lemmas indep_var_from_indep_vars = indep_var_from_indep_vars
+lemmas var_sum_pairwise_indep_2 = bienaymes_identity_pairwise_indep_2
+lemmas var_sum_all_indep = bienaymes_identity_full_indep
 
 lemma pmf_mono:
   assumes "M = measure_pmf p"
   assumes "\<And>x. x \<in> P \<Longrightarrow> x \<in> set_pmf p \<Longrightarrow> x \<in> Q"
   shows "prob P \<le> prob Q"
 proof -
   have "prob P = prob (P \<inter> (set_pmf p))"
     by (rule  measure_pmf_eq[OF assms(1)], blast)
   also have "... \<le> prob Q"
     using assms by (intro finite_measure.finite_measure_mono, auto)
   finally show ?thesis by simp
 qed
 
 lemma pmf_add:
   assumes "M = measure_pmf p"
   assumes  "\<And>x. x \<in> P \<Longrightarrow> x \<in> set_pmf p \<Longrightarrow> x \<in> Q \<or> x \<in> R"
   shows "prob P \<le> prob Q + prob R"
 proof -
   have [simp]:"events = UNIV" by (subst assms(1), simp)
   have "prob P \<le> prob (Q \<union> R)"
     using assms by (intro pmf_mono[OF assms(1)], blast)
   also have "... \<le> prob Q + prob R"
     by (rule measure_subadditive, auto)
   finally show ?thesis by simp
 qed
 
 lemma pmf_add_2:
   assumes "M = measure_pmf p"
   assumes "prob {\<omega>. P \<omega>} \<le> r1"
   assumes "prob {\<omega>. Q \<omega>} \<le> r2"
   shows "prob {\<omega>. P \<omega> \<or> Q \<omega>} \<le> r1 + r2" (is "?lhs \<le> ?rhs")
 proof -
   have "?lhs \<le> prob {\<omega>. P \<omega>} + prob {\<omega>. Q \<omega>}"
     by (intro pmf_add[OF assms(1)], auto)
   also have "... \<le> ?rhs"
     by (intro add_mono assms(2-3))
   finally show ?thesis
     by simp
 qed
 
-definition covariance where 
-  "covariance f g = expectation (\<lambda>\<omega>. (f \<omega> - expectation f) * (g \<omega> - expectation g))"
-
-lemma real_prod_integrable:
-  fixes f g :: "'a \<Rightarrow> real"
-  assumes [measurable]: "f \<in> borel_measurable M" "g \<in> borel_measurable M"
-  assumes sq_int: "integrable M (\<lambda>\<omega>. f \<omega>^2)" "integrable M (\<lambda>\<omega>. g \<omega>^2)"
-  shows "integrable M (\<lambda>\<omega>. f \<omega> * g \<omega>)"
-  unfolding integrable_iff_bounded
-proof
-  have "(\<integral>\<^sup>+ \<omega>. ennreal (norm (f \<omega> * g \<omega>)) \<partial>M)\<^sup>2 = (\<integral>\<^sup>+ \<omega>. ennreal \<bar>f \<omega>\<bar> * ennreal \<bar>g \<omega>\<bar> \<partial>M)\<^sup>2" 
-    by (simp add: abs_mult ennreal_mult)
-  also have "... \<le>  (\<integral>\<^sup>+ \<omega>. ennreal \<bar>f \<omega>\<bar>^2 \<partial>M) * (\<integral>\<^sup>+ \<omega>. ennreal \<bar>g \<omega>\<bar>^2 \<partial>M)"
-    by (rule Cauchy_Schwarz_nn_integral, auto)
-  also have "... < \<infinity>" 
-    using sq_int by (auto simp: integrable_iff_bounded ennreal_power ennreal_mult_less_top)
-  finally have "(\<integral>\<^sup>+ x. ennreal (norm (f x * g x)) \<partial>M)\<^sup>2 < \<infinity>" 
-    by simp
-  thus "(\<integral>\<^sup>+ x. ennreal (norm (f x * g x)) \<partial>M) < \<infinity>" 
-    by (simp add: power_less_top_ennreal)
-qed auto
-
-lemma covariance_eq:
-  fixes f :: "'a \<Rightarrow> real"
-  assumes "f \<in> borel_measurable M" "g \<in> borel_measurable M"
-  assumes "integrable M (\<lambda>\<omega>. f \<omega>^2)" "integrable M (\<lambda>\<omega>. g \<omega>^2)"
-  shows "covariance f g = expectation (\<lambda>\<omega>. f \<omega> * g \<omega>) - expectation f * expectation g"
-proof -
-  have "integrable M f" using square_integrable_imp_integrable assms by auto
-  moreover have "integrable M g" using square_integrable_imp_integrable assms by auto
-  ultimately show ?thesis
-    using assms real_prod_integrable
-    by (simp add:covariance_def algebra_simps prob_space)
-qed
-
-lemma covar_integrable:
-  fixes f g :: "'a \<Rightarrow> real"
-  assumes "f \<in> borel_measurable M" "g \<in> borel_measurable M"
-  assumes "integrable M (\<lambda>\<omega>. f \<omega>^2)" "integrable M (\<lambda>\<omega>. g \<omega>^2)"
-  shows "integrable M (\<lambda>\<omega>. (f \<omega> - expectation f) * (g \<omega> - expectation g))"
-proof -
-  have "integrable M f" using square_integrable_imp_integrable assms by auto
-  moreover have "integrable M g" using square_integrable_imp_integrable assms by auto
-  ultimately show ?thesis using assms real_prod_integrable by (simp add: algebra_simps)
-qed
-
-lemma sum_square_int:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  shows "integrable M (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)\<^sup>2)"
-proof -
-  have " integrable M (\<lambda>\<omega>. \<Sum>i\<in>I. \<Sum>j\<in>I. f j \<omega> * f i \<omega>)"
-    using assms
-    by (intro Bochner_Integration.integrable_sum real_prod_integrable, auto)
-  thus ?thesis
-    by (simp add:power2_eq_square sum_distrib_left sum_distrib_right)
-qed
-
-lemma var_sum_1:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  shows 
-    "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = (\<Sum>i \<in> I. (\<Sum>j \<in> I. covariance (f i) (f j)))"
-proof -
-  have a:"\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. (f i \<omega> - expectation (f i)) * (f j \<omega> - expectation (f j)))" 
-    using assms covar_integrable by simp
-  have "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = expectation (\<lambda>\<omega>. (\<Sum>i\<in>I. f i \<omega> - expectation (f i))\<^sup>2)"
-    using square_integrable_imp_integrable[OF assms(2,3)]
-    by (simp add: Bochner_Integration.integral_sum  sum_subtractf)
-  also have "... = expectation (\<lambda>\<omega>. (\<Sum>i \<in> I. (\<Sum>j \<in> I. (f i \<omega> - expectation (f i)) *  (f j \<omega> - expectation (f j)))))"
-    by (simp add: power2_eq_square sum_distrib_right sum_distrib_left mult.commute)
-  also have "... = (\<Sum>i \<in> I. (\<Sum>j \<in> I. covariance (f i) (f j)))"
-    using a by (simp add: Bochner_Integration.integral_sum covariance_def) 
-  finally show ?thesis by simp
-qed
-
-lemma covar_self_eq:
-  fixes f :: "'a \<Rightarrow> real"
-  shows "covariance f f = variance f"
-  by (simp add:covariance_def power2_eq_square)
-
-lemma covar_indep_eq_zero:
-  fixes f g :: "'a \<Rightarrow> real"
-  assumes "integrable M f"
-  assumes "integrable M g"
-  assumes "indep_var borel f borel g"
-  shows "covariance f g = 0"
-proof -
-  have a:"indep_var borel ((\<lambda>t. t - expectation f) \<circ> f) borel ((\<lambda>t. t - expectation g) \<circ> g)"
-    by (rule indep_var_compose[OF assms(3)], auto)
-
-  have b:"expectation (\<lambda>\<omega>. (f \<omega> - expectation f) * (g \<omega> - expectation g)) = 0" 
-    using a assms by (subst indep_var_lebesgue_integral, auto simp add:comp_def prob_space)
-
-  thus ?thesis by (simp add:covariance_def)
-qed
-
-lemma var_sum_2:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  shows "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = 
-      (\<Sum>i \<in> I. variance (f i)) + (\<Sum>i \<in> I. \<Sum>j \<in> I - {i}. covariance (f i) (f j))"
-proof -
-  have "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = (\<Sum>i\<in>I. \<Sum>j\<in>I. covariance (f i) (f j))"
-    by (simp add: var_sum_1[OF assms(1,2,3)])
-  also have "... = (\<Sum>i\<in>I. covariance (f i) (f i) + (\<Sum>j\<in>I-{i}. covariance (f i) (f j)))"
-    using assms by (subst sum.insert[symmetric], auto simp add:insert_absorb)
-  also have "... = (\<Sum>i\<in>I. variance (f i)) +  (\<Sum>i \<in> I. (\<Sum>j\<in>I-{i}. covariance (f i) (f j)))"
-    by (simp add: covar_self_eq[symmetric] sum.distrib)
-  finally show ?thesis by simp
-qed
-
-lemma var_sum_pairwise_indep:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  assumes "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> indep_var borel (f i) borel (f j)"
-  shows "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = (\<Sum>i \<in> I. variance (f i))"
-proof -
-  have "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I - {i} \<Longrightarrow> covariance (f i) (f j) = 0" 
-    using covar_indep_eq_zero assms(4) square_integrable_imp_integrable[OF assms(2,3)] by auto
-  hence a:"(\<Sum>i \<in> I. \<Sum>j \<in> I - {i}. covariance (f i) (f j)) = 0"
-    by simp
-  thus ?thesis by (simp add: var_sum_2[OF assms(1,2,3)])
-qed
-
-lemma indep_var_from_indep_vars:
-  assumes "i \<noteq> j"
-  assumes "indep_vars (\<lambda>_. M') f {i, j}" 
-  shows "indep_var M' (f i) M' (f j)"
-proof -
-  have a:"inj (case_bool i j)" using assms(1) 
-    by (simp add: bool.case_eq_if inj_def)
-  have b:"range (case_bool i j) = {i,j}" 
-    by (simp add: UNIV_bool insert_commute)
-  have c:"indep_vars (\<lambda>_. M') f (range (case_bool i j))" using assms(2) b by simp
-
-  have "True = indep_vars (\<lambda>x. M') (\<lambda>x. f (case_bool i j x)) UNIV" 
-    using indep_vars_reindex[OF a c]
-    by (simp add:comp_def)
-  also have "... = indep_vars (\<lambda>x. case_bool M' M' x) (\<lambda>x. case_bool (f i) (f j) x) UNIV"
-    by (rule indep_vars_cong, auto simp:bool.case_distrib bool.case_eq_if)
-  also have "... = ?thesis"
-    by (simp add: indep_var_def)
-  finally show ?thesis by simp
-qed
-
-lemma var_sum_pairwise_indep_2:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  assumes "\<And>J. J \<subseteq> I \<Longrightarrow> card J = 2 \<Longrightarrow> indep_vars (\<lambda> _. borel) f J"
-  shows "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = (\<Sum>i \<in> I. variance (f i))"
-  using assms(4)
-  by (intro var_sum_pairwise_indep[OF assms(1,2,3)] indep_var_from_indep_vars, auto)
-
-lemma var_sum_all_indep:
-  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> real"
-  assumes "finite I"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> borel_measurable M"
-  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable M (\<lambda>\<omega>. f i \<omega>^2)"
-  assumes "indep_vars (\<lambda> _. borel) f I"
-  shows "variance (\<lambda>\<omega>. (\<Sum>i \<in> I. f i \<omega>)) = (\<Sum>i \<in> I. variance (f i))"
-  by (intro var_sum_pairwise_indep_2[OF assms(1,2,3)] indep_vars_subset[OF assms(4)],  auto)
-
 end
 
 end
diff --git a/thys/Frequency_Moments/ROOT b/thys/Frequency_Moments/ROOT
--- a/thys/Frequency_Moments/ROOT
+++ b/thys/Frequency_Moments/ROOT
@@ -1,26 +1,27 @@
 chapter AFP
 
 session Frequency_Moments = "HOL-Probability" +
   options [timeout = 1200]
   sessions
     Bertrands_Postulate
+    Concentration_Inequalities
     Equivalence_Relation_Enumeration
     "HOL-Algebra"
     Interpolation_Polynomials_HOL_Algebra
     Lp
     Prefix_Free_Code_Combinators
     Median_Method
     Universal_Hash_Families
   theories
     Frequency_Moments_Preliminary_Results
     Frequency_Moments
     Frequency_Moment_0
     Frequency_Moment_2
     Frequency_Moment_k
     Landau_Ext
     K_Smallest
     Probability_Ext
     Product_PMF_Ext
   document_files
     "root.tex"
     "root.bib"
diff --git a/thys/Graph_Theory/Euler.thy b/thys/Graph_Theory/Euler.thy
--- a/thys/Graph_Theory/Euler.thy
+++ b/thys/Graph_Theory/Euler.thy
@@ -1,676 +1,666 @@
 (* Title:  Euler.thy
    Author: Lars Noschinski, TU München
 *)
 theory Euler imports
   Arc_Walk
   Digraph_Component
   Digraph_Isomorphism
 begin
 
 section \<open>Euler Trails in Digraphs\<close>
 
 text \<open>
   In this section we prove the well-known theorem characterizing the
   existence of an Euler Trail in an directed graph
 \<close>
 
 subsection \<open>Trails and Euler Trails\<close>
 
 definition (in pre_digraph) euler_trail :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
   "euler_trail u p v \<equiv> trail u p v \<and> set p = arcs G \<and> set (awalk_verts u p) = verts G"
 
 context wf_digraph begin
 
 (* XXX move; notused*)
-lemma finite_distinct:
-  assumes "finite A" shows "finite {p. distinct p \<and> set p \<subseteq> A}"
-proof -
-  have "{p. distinct p \<and> set p \<subseteq> A} \<subseteq> {p. set p \<subseteq> A \<and> length p \<le> card A}"
-    using assms by (auto simp: distinct_card[symmetric] intro: card_mono)
-  also have "finite ..."
-    using assms by (simp add: finite_lists_length_le)
-  finally (finite_subset) show ?thesis .
-qed
-
-(* XXX move; notused*)
 lemma (in fin_digraph) trails_finite: "finite {p. \<exists>u v. trail u p v}"
 proof -
-  have "{p. \<exists>u v. trail u p v} \<subseteq> {p. distinct p \<and> set p \<subseteq> arcs G}"
+  have "{p. \<exists>u v. trail u p v} \<subseteq> {p. set p \<subseteq> arcs G \<and> distinct p}"
     by (auto simp: trail_def)
-  with finite_arcs finite_distinct show ?thesis by (blast intro: finite_subset)
+  with finite_subset_distinct[OF finite_arcs] show ?thesis
+    using finite_subset by blast 
 qed
 (* XXX: simplify apath_finite proof? *)
 
 lemma rotate_awalkE:
   assumes "awalk u p u" "w \<in> set (awalk_verts u p)"
   obtains q r where "p = q @ r" "awalk w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
 proof -
   from assms obtain q r where A: "p = q @ r" and A': "awalk u q w" "awalk w r u"
     by atomize_elim (rule awalk_decomp)
   
   then have B: "awalk w (r @ q) w" by auto
 
   have C: "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
     using \<open>awalk u p u\<close> A A' by (auto simp: set_awalk_verts_append)
 
   from A B C show ?thesis ..
 qed
 
 lemma rotate_trailE:
   assumes "trail u p u" "w \<in> set (awalk_verts u p)"
   obtains q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
   using assms by - (rule rotate_awalkE[where u=u and p=p and w=w], auto simp: trail_def)
 
 lemma rotate_trailE':
   assumes "trail u p u" "w \<in> set (awalk_verts u p)"
   obtains q where "trail w q w" "set q = set p" "set (awalk_verts w q) = set (awalk_verts u p)"
 proof -
   from assms obtain q r where "p = q @ r" "trail w (r @ q) w" "set (awalk_verts w (r @ q)) = set (awalk_verts u p)"
     by (rule rotate_trailE)
   then have "set (r @ q) = set p" by auto
   show ?thesis by (rule that) fact+
 qed
 
 lemma sym_reachableI_in_awalk:
   assumes walk: "awalk u p v" and
     w1: "w1 \<in> set (awalk_verts u p)" and w2: "w2 \<in> set (awalk_verts u p)"
   shows "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2"
 proof -
   from walk w1 obtain q r where "p = q @ r" "awalk u q w1" "awalk w1 r v"
     by (atomize_elim) (rule awalk_decomp)
   then have w2_in: "w2 \<in> set (awalk_verts u q) \<union> set (awalk_verts w1 r)"
     using w2 by (auto simp: set_awalk_verts_append)
 
   show ?thesis
   proof cases
     assume A: "w2 \<in> set (awalk_verts u q)"
     obtain s where "awalk w2 s w1"
       using awalk_decomp[OF \<open>awalk u q w1\<close> A] by blast
     then have "w2 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w1" 
       by (intro reachable_awalkI reachable_mk_symmetricI)
     with symmetric_mk_symmetric show ?thesis by (rule symmetric_reachable)
   next
     assume "w2 \<notin> set (awalk_verts u q)"
     then have A: "w2 \<in> set (awalk_verts w1 r)"
       using w2_in by blast
     obtain s where "awalk w1 s w2"
       using awalk_decomp[OF \<open>awalk w1 r v\<close> A] by blast
     then show "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2" 
       by (intro reachable_awalkI reachable_mk_symmetricI)
   qed
 qed
 
 lemma euler_imp_connected:
   assumes "euler_trail u p v" shows "connected G"
 proof -
   { have "verts G \<noteq> {}" using assms unfolding euler_trail_def trail_def by auto }
   moreover
   { fix w1 w2 assume "w1 \<in> verts G" "w2 \<in> verts G"
     then have "awalk u p v " "w1 \<in> set (awalk_verts u p)" "w2 \<in> set (awalk_verts u p)"
       using assms by (auto simp: euler_trail_def trail_def)
     then have "w1 \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> w2" by (rule sym_reachableI_in_awalk) }
   ultimately show "connected G" by (rule connectedI)
 qed
 
 end
 
 
 
 subsection \<open>Arc Balance of Walks\<close>
 
 context pre_digraph begin
 
 (* XXX change order of arguments? *)
 definition arc_set_balance :: "'a \<Rightarrow> 'b set \<Rightarrow> int" where
   "arc_set_balance w A = int (card (in_arcs G w \<inter> A)) - int (card (out_arcs G w \<inter> A))"
 
 definition  arc_set_balanced :: "'a \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> bool" where
   "arc_set_balanced u A v \<equiv>
       if u = v then (\<forall>w \<in> verts G. arc_set_balance w A = 0)
       else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> arc_set_balance w A = 0)
         \<and> arc_set_balance u A = -1
         \<and> arc_set_balance v A = 1"
 
 abbreviation arc_balance :: "'a \<Rightarrow> 'b awalk \<Rightarrow> int" where
   "arc_balance w p \<equiv> arc_set_balance w (set p)"
 
 abbreviation arc_balanced :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
   "arc_balanced u p v \<equiv> arc_set_balanced u (set p) v"
 
 lemma arc_set_balanced_all:
   "arc_set_balanced u (arcs G) v =
       (if u = v then (\<forall>w \<in> verts G. in_degree G w = out_degree G w)
       else (\<forall>w \<in> verts G. (w \<noteq> u \<and> w \<noteq> v) \<longrightarrow> in_degree G w = out_degree G w)
         \<and> in_degree G u + 1 = out_degree G u
         \<and> out_degree G v + 1 = in_degree G v)"
   unfolding arc_set_balanced_def arc_set_balance_def in_degree_def out_degree_def by auto
 
 end
 
 context wf_digraph begin
 
 
 (* XXX tune assumption? e \<notin> set es oder so? *)
 lemma arc_balance_Cons:
   assumes "trail u (e # es) v"
   shows "arc_set_balance w (insert e (set es)) = arc_set_balance w {e} + arc_balance w es"
 proof -
   from assms have "e \<notin> set es" "e \<in> arcs G" by (auto simp: trail_def)
 
   with \<open>e \<notin> set es\<close> show ?thesis
     apply (cases "w = tail G e")
      apply (case_tac [!] "w = head G e")
        apply (auto simp: arc_set_balance_def)
     done
 qed
 
 lemma arc_balancedI_trail:
   assumes "trail u p v" shows "arc_balanced u p v"
   using assms
 proof (induct p arbitrary: u)
   case Nil then show ?case by (auto simp: arc_set_balanced_def arc_set_balance_def trail_def)
 next
   case (Cons e es)
   then have "arc_balanced (head G e) es v" "u = tail G e" "e \<in> arcs G"
     by (auto simp: awalk_Cons_iff trail_def)
   moreover
   have "\<And>w. arc_balance w [e] = (if w = tail G e \<and> tail G e \<noteq> head G e then -1
       else if w = head G e \<and> tail G e \<noteq> head G e then 1 else 0)"
       using \<open>e \<in> _\<close> by (case_tac "w = tail G e") (auto simp: arc_set_balance_def)
   ultimately show ?case
     by (auto simp: arc_set_balanced_def arc_balance_Cons[OF \<open>trail u _ _\<close>])
 qed
 
 lemma trail_arc_balanceE:
   assumes "trail u p v"
   obtains "\<And>w. \<lbrakk> u = v \<or> (w \<noteq> u \<and> w \<noteq> v); w \<in> verts G \<rbrakk>
       \<Longrightarrow> arc_balance w p = 0"
     and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance u p = - 1"
     and "\<lbrakk> u \<noteq> v \<rbrakk> \<Longrightarrow> arc_balance v p = 1"
   using arc_balancedI_trail[OF assms] unfolding arc_set_balanced_def by (intro that) (metis,presburger+)
 
 end
 
 
 
 subsection \<open>Closed Euler Trails\<close>
 
 lemma (in wf_digraph) awalk_vertex_props:
   assumes "awalk u p v" "p \<noteq> []"
   assumes "\<And>w. w \<in> set (awalk_verts u p) \<Longrightarrow> P w \<or> Q w"
   assumes "P u" "Q v"
   shows "\<exists>e \<in> set p. P (tail G e) \<and> Q (head G e)"
   using assms(2,1,3-)
 proof (induct p arbitrary: u rule: list_nonempty_induct)
   case (cons e es)
   show ?case
   proof (cases "P (tail G e) \<and> Q (head G e)")
     case False
     then have "P (head G e) \<or> Q (head G e)"
       using cons.prems(1) cons.prems(2)[of "head G e"]
       by (auto simp: awalk_Cons_iff set_awalk_verts)
     then have "P (tail G e) \<and> P (head G e)"
       using False using cons.prems(1,3) by auto
     
     then have "\<exists>e \<in> set es. P (tail G e) \<and> Q (head G e)"
       using cons by (auto intro: cons simp: awalk_Cons_iff)
     then show ?thesis by auto
   qed auto
 qed (simp add: awalk_simps)
 
 lemma (in wf_digraph) connected_verts:
   assumes "connected G" "arcs G \<noteq> {}"
   shows "verts G = tail G ` arcs G \<union> head G ` arcs G"
 proof -
   { assume "verts G = {}" then have ?thesis by (auto dest: tail_in_verts) }
   moreover
   { assume "\<exists>v. verts G = {v}"
     then obtain v where "verts G = {v}" by (auto simp: card_Suc_eq)
     moreover
     with \<open>arcs G \<noteq> {}\<close> obtain e where "e \<in> arcs G" "tail G e = v" "head G e = v"
       by (auto dest: tail_in_verts head_in_verts)
     moreover have "tail G ` arcs G \<union> head G ` arcs G \<subseteq> verts G" by auto 
     ultimately have ?thesis by auto }
   moreover
   { assume A: "\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and> u \<noteq> v"
     { fix u assume "u \<in> verts G"
 
       interpret S: pair_wf_digraph "mk_symmetric G" by rule
       from A obtain v where "v \<in> verts G" "u \<noteq> v" by blast
       then obtain p where "S.awalk u p v"
         using \<open>connected G\<close> \<open>u \<in> verts G\<close> by (auto elim: connected_awalkE)
       with \<open>u \<noteq> v\<close> obtain e where "e \<in> parcs (mk_symmetric G)" "fst e = u"
         by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
       then obtain e' where "tail G e' = u \<or> head G e' = u" "e' \<in> arcs G"
         by (force simp: parcs_mk_symmetric)
       then have "u \<in> tail G ` arcs G \<union> head G `arcs G" by auto }
     then have ?thesis by auto }
   ultimately show ?thesis by blast
 qed
 
 lemma (in wf_digraph) connected_arcs_empty:
   assumes "connected G" "arcs G = {}" "verts G \<noteq> {}" obtains v where "verts G = {v}"
 proof (atomize_elim, rule ccontr)
   assume A: "\<not> (\<exists>v. verts G = {v})"
 
   interpret S: pair_wf_digraph "mk_symmetric G" by rule
 
   from \<open>verts G \<noteq> {}\<close> obtain u where "u \<in> verts G" by auto
   with A obtain v where "v \<in> verts G" "u \<noteq> v" by auto
 
   from \<open>connected G\<close> \<open>u \<in> verts G\<close> \<open>v \<in> verts G\<close>
   obtain p where "S.awalk u p v"
     using \<open>connected G\<close> \<open>u \<in> verts G\<close> by (auto elim: connected_awalkE)
   with \<open>u \<noteq> v\<close> obtain e where "e \<in> parcs (mk_symmetric G)"
     by (metis S.awalk_Cons_iff S.awalk_empty_ends list_exhaust2)
   with \<open>arcs G = {}\<close> show False
     by (auto simp: parcs_mk_symmetric)
 qed
 
 lemma (in wf_digraph) euler_trail_conv_connected:
   assumes "connected G"
   shows "euler_trail u p v \<longleftrightarrow> trail u p v \<and> set p = arcs G" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?R show ?L
   proof cases
     assume "p = []" with assms \<open>?R\<close> show ?thesis
       by (auto simp: euler_trail_def trail_def awalk_def elim: connected_arcs_empty)
   next
     assume "p \<noteq> []" then have "arcs G \<noteq> {}" using \<open>?R\<close> by auto
     with assms \<open>?R\<close> \<open>p \<noteq> []\<close> show ?thesis
       by (auto simp: euler_trail_def trail_def set_awalk_verts_not_Nil connected_verts)
   qed
 qed (simp add: euler_trail_def)
 
 lemma (in wf_digraph) awalk_connected:
   assumes "connected G" "awalk u p v" "set p \<noteq> arcs G"
   shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
 proof (rule ccontr)
   assume A: "\<not>?thesis"
 
   obtain e where "e \<in> arcs G - set p"
     using assms by (auto simp: trail_def)
   with A have "tail G e \<notin> set (awalk_verts u p)" "tail G e \<in> verts G"
     by auto
 
   interpret S: pair_wf_digraph "mk_symmetric G" ..
 
   have "u \<in> verts G" using \<open>awalk u p v\<close> by (auto simp: awalk_hd_in_verts)
   with \<open>tail G e \<in> _\<close> and \<open>connected G\<close>
   obtain q where q: "S.awalk u q (tail G e)"
     by (auto elim: connected_awalkE)
 
   have "u \<in> set (awalk_verts u p)"
     using \<open>awalk u p v\<close> by (auto simp: set_awalk_verts)
 
   have "q \<noteq> []" using \<open>u \<in> set _\<close> \<open>tail G e \<notin> _\<close> q by auto
 
   have "\<exists>e \<in> set q. fst e \<in> set (awalk_verts u p) \<and> snd e \<notin> set (awalk_verts u p)"
     by (rule S.awalk_vertex_props[OF \<open>S.awalk _ _ _\<close> \<open>q \<noteq> []\<close>]) (auto simp: \<open>u \<in> set _\<close> \<open>tail G e \<notin> _\<close>)
   then obtain se' where se': "se' \<in> set q" "fst se' \<in> set (awalk_verts u p)" "snd se' \<notin> set (awalk_verts u p)"
     by auto
 
   from se' have "se' \<in> parcs (mk_symmetric G)" using q by auto
   then obtain e' where "e' \<in> arcs G" "(tail G e' = fst se' \<and> head G e' = snd se') \<or> (tail G e' = snd se' \<and> head G e' = fst se')"
     by (auto simp: parcs_mk_symmetric)
   moreover
   then have "e' \<notin> set p" using se' \<open>awalk u p v\<close>
     by (auto dest: awalk_verts_arc2 awalk_verts_arc1)
   ultimately show False using se'
     using A by auto
 qed
 
 lemma (in wf_digraph) trail_connected:
   assumes "connected G" "trail u p v" "set p \<noteq> arcs G"
   shows "\<exists>e. e \<in> arcs G - set p \<and> (tail G e \<in> set (awalk_verts u p) \<or> head G e \<in> set (awalk_verts u p))"
   using assms by (intro awalk_connected) (auto simp: trail_def)
 
 theorem (in fin_digraph) closed_euler1:
   assumes con: "connected G"
   assumes deg: "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u"
   shows "\<exists>u p. euler_trail u p u"
 proof -
   from con obtain u where "u \<in> verts G" by (auto simp: connected_def strongly_connected_def)
   then have "trail u [] u" by (auto simp: trail_def awalk_simps)
   moreover
   { fix u p v assume  "trail u p v"
     then have "\<exists>u' p' v'. euler_trail u' p' v'"
     proof (induct "card (arcs G) - length p" arbitrary: u p v)
       case 0
       then have "u \<in> verts G" by (auto simp: trail_def)
 
       have "set p \<subseteq> arcs G" using \<open>trail u p v\<close> by (auto simp: trail_def)
       with 0 have "set p = arcs G"
         by (auto simp: trail_def distinct_card[symmetric] card_seteq)
       then have "euler_trail u p v"
         using 0 by (simp add: euler_trail_conv_connected[OF con])
       then show ?case by blast
     next
       case (Suc n)
       then have neq: "set p \<noteq> arcs G" "u \<in> verts G"
         by (auto simp: trail_def distinct_card[symmetric])
 
       show ?case
       proof (cases "u = v")
         assume "u \<noteq> v"
         then have "arc_balance u p = -1"
           using Suc neq by (auto elim: trail_arc_balanceE)
         then have "card (in_arcs G u \<inter> set p) < card (out_arcs G u \<inter> set p)"
           unfolding arc_set_balance_def by auto
         also have "\<dots> \<le> card (out_arcs G u)"
           by (rule card_mono) auto
         finally have "card (in_arcs G u \<inter> set p) < card (in_arcs G u)"
           using deg[OF \<open>u \<in> _\<close>] unfolding out_degree_def in_degree_def by simp
         then have "in_arcs G u - set p \<noteq> {}"
           by (auto dest: card_psubset[rotated 2])
         then obtain a where "a \<in> arcs G" "head G a = u" "a \<notin> set p"
           by (auto simp: in_arcs_def)
         then have *: "trail (tail G a) (a # p) v"
           using Suc by (auto simp: trail_def awalk_simps)
         then show ?thesis
           using Suc by (intro Suc) auto
       next
         assume "u = v"
         with neq con Suc
         obtain a where a_in: "a \<in> arcs G - set p"
             and a_end: "(tail G a \<in> set (awalk_verts u p) \<or> head G a \<in> set (awalk_verts u p))"
           by (atomize_elim) (rule trail_connected)
         have "trail u p u" using Suc \<open>u = v\<close> by simp
         show ?case
         proof (cases "tail G a \<in> set (awalk_verts u p)")
           case True
           with \<open>trail u p u\<close> obtain q where q: "set p = set q" "trail (tail G a) q (tail G a)"
             by (rule rotate_trailE') blast
           with True a_in have *: "trail (tail G a) (q @ [a]) (head G a)"
             by (fastforce simp: trail_def awalk_simps )
           moreover
           from q Suc have "length q = length p"
             by (simp add: trail_def distinct_card[symmetric])
           ultimately
           show ?thesis using Suc  by (intro Suc) auto
         next
           case False
           with a_end have "head G a \<in> set (awalk_verts u p)" by blast
           with \<open>trail u p u\<close> obtain q where q: "set p = set q" "trail (head G a) q (head G a)"
             by (rule rotate_trailE') blast
           with False a_in have *: "trail (tail G a) (a # q) (head G a)"
             by (fastforce simp: trail_def awalk_simps )
           moreover
           from q Suc have "length q = length p"
             by (simp add: trail_def distinct_card[symmetric])
           ultimately
           show ?thesis using Suc by (intro Suc) auto
         qed
       qed
     qed }
   ultimately obtain u p v where et: "euler_trail u p v" by blast
   moreover
   have "u = v"
   proof -
     have "arc_balanced u p v"
       using \<open>euler_trail u p v\<close> by (auto simp: euler_trail_def dest: arc_balancedI_trail)
     then show ?thesis
       using \<open>euler_trail u p v\<close> deg
       by (auto simp add: euler_trail_def trail_def arc_set_balanced_all split: if_split_asm)
   qed
   ultimately show ?thesis by blast
 qed
 
 lemma (in wf_digraph) closed_euler_imp_eq_degree:
   assumes "euler_trail u p u"
   assumes "v \<in> verts G"
   shows "in_degree G v = out_degree G v"
 proof -
   from assms have "arc_balanced u p u" "set p = arcs G"
     unfolding euler_trail_def by (auto dest: arc_balancedI_trail)
   with assms have "arc_balance v p = 0"
     unfolding arc_set_balanced_def by auto
   moreover
   from \<open>set p = _\<close> have "in_arcs G v \<inter> set p = in_arcs G v" "out_arcs G v \<inter> set p = out_arcs G v"
     by (auto intro: in_arcs_in_arcs out_arcs_in_arcs)
   ultimately
   show ?thesis unfolding arc_set_balance_def in_degree_def out_degree_def by auto
 qed
 
 
 
 theorem (in fin_digraph) closed_euler2:
   assumes "euler_trail u p u"
   shows "connected G"
     and "\<And>u. u \<in> verts G \<Longrightarrow> in_degree G u = out_degree G u" (is "\<And>u. _ \<Longrightarrow> ?eq_deg u")
 proof -
   from assms show "connected G" by (rule euler_imp_connected)
 next
   fix v assume A: "v \<in> verts G"
   with assms show "?eq_deg v" by (rule closed_euler_imp_eq_degree)
 qed
 
 corollary (in fin_digraph) closed_euler:
   "(\<exists>u p. euler_trail u p u) \<longleftrightarrow> connected G \<and> (\<forall>u \<in> verts G. in_degree G u = out_degree G u)"
   by (auto dest: closed_euler1 closed_euler2)
 
 
 
 subsection \<open>Open euler trails\<close>
 
 text \<open>
   Intuitively, a graph has an open euler trail if and only if it is possible to add
   an arc such that the resulting graph has a closed euler trail. However, this is
   not true in our formalization, as the arc type @{typ 'b} might be finite:
 
   Consider for example the graph
   @{term "\<lparr> verts = {0,1}, arcs = {()}, tail = \<lambda>_. 0, head = \<lambda>_. 1 \<rparr>"}. This graph
   obviously has an open euler trail, but we cannot add another arc, as we already
   exhausted the universe.
 
   However, for each @{term "fin_digraph G"} there exist an isomorphic graph
   @{term H} with arc type @{typ "'a \<times> nat \<times> 'a"}. Hence, we first characterize
   the existence of euler trail for the infinite arc type @{typ "'a \<times> nat \<times> 'a"}
   and transfer that result back to arbitrary arc types.
 \<close>
 
 lemma open_euler_infinite_label:
   fixes G :: "('a, 'a \<times> nat \<times> 'a) pre_digraph"
   assumes "fin_digraph G"
   assumes [simp]: "tail G = fst" "head G = snd o snd"
   assumes con: "connected G"
   assumes uv: "u \<in> verts G" "v \<in> verts G"
   assumes deg: "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
   assumes deg_in: "in_degree G u + 1 = out_degree G u"
   assumes deg_out: "out_degree G v + 1 = in_degree G v"
   shows "\<exists>p. pre_digraph.euler_trail G u p v"
 proof -
   define label :: "'a \<times> nat \<times> 'a \<Rightarrow> nat" where [simp]: "label = fst o snd"
 
   interpret fin_digraph G by fact
 
   have "finite (label ` arcs G)" by auto
   moreover have "\<not>finite (UNIV :: nat set)" by blast
   ultimately obtain l where "l \<notin> label ` arcs G" by atomize_elim (rule ex_new_if_finite)
 
   from deg_in deg_out have "u \<noteq> v" by auto
 
   let ?e = "(v,l,u)"
 
   have e_notin:"?e \<notin> arcs G"
     using \<open>l \<notin> _\<close> by (auto simp: image_def)
 
   let ?H = "add_arc ?e"
     \<comment> \<open>We define a graph which has an closed euler trail\<close>
 
   have [simp]: "verts ?H = verts G" using uv by simp
   have [intro]: "\<And>a. compatible (add_arc a) G" by (simp add: compatible_def)
 
   interpret H: fin_digraph "add_arc a"
     rewrites "tail (add_arc a) = tail G" and "head (add_arc a) = head G"
       and "pre_digraph.cas (add_arc a) = cas"
       and "pre_digraph.awalk_verts (add_arc a) = awalk_verts"
      for a
       by unfold_locales (auto dest: wellformed intro: compatible_cas compatible_awalk_verts
           simp: verts_add_arc_conv)
 
   have "\<exists>u p. H.euler_trail ?e u p u"
   proof (rule H.closed_euler1)
     show "connected ?H"
     proof (rule H.connectedI)
       interpret sH: pair_fin_digraph "mk_symmetric ?H" ..
       fix u v assume "u \<in> verts ?H" "v \<in> verts ?H"
       with con have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v" by (auto simp: connected_def)
       moreover
       have "subgraph G ?H" by (auto simp: subgraph_def) unfold_locales
       ultimately show "u \<rightarrow>\<^sup>*\<^bsub>with_proj (mk_symmetric ?H)\<^esub> v"
         by (blast intro: sH.reachable_mono subgraph_mk_symmetric)
     qed (simp add: verts_add_arc_conv)
   next
     fix w assume "w \<in> verts ?H"
     then show "in_degree ?H w = out_degree ?H w"
       using deg deg_in deg_out e_notin
       apply (cases "w = u")
        apply (case_tac [!] "w = v")
          by (auto simp: in_degree_add_arc_iff out_degree_add_arc_iff)
   qed
 
   then obtain w p where Het: "H.euler_trail ?e w p w" by blast
   then have "?e \<in> set p" by (auto simp: pre_digraph.euler_trail_def)
   then obtain q r where p_decomp: "p = q @ [?e] @ r"
     by (auto simp: in_set_conv_decomp)
     \<comment> \<open>We show now that removing the additional arc of @{term ?H}
       from p yields an euler trail in G\<close>
 
   have "euler_trail u (r @ q) v"
   proof (unfold euler_trail_conv_connected[OF con], intro conjI)
     from Het have Ht': "H.trail ?e v (?e # r @ q) v"
       unfolding p_decomp H.euler_trail_def H.trail_def
       by (auto simp: p_decomp H.awalk_Cons_iff)
     then have "H.trail ?e u (r @ q) v" "?e \<notin> set (r @ q)"
       by (auto simp: H.trail_def H.awalk_Cons_iff)
     then show t': "trail u (r @ q) v"
       by (auto simp: trail_def H.trail_def awalk_def H.awalk_def)
 
     show "set (r @ q) = arcs G"
     proof -
       have "arcs G = arcs ?H - {?e}" using e_notin by auto
       also have "arcs ?H = set p" using Het
         by (auto simp: pre_digraph.euler_trail_def pre_digraph.trail_def)
       finally show ?thesis using \<open>?e \<notin> set _\<close> by (auto simp: p_decomp)
     qed
   qed
   then show ?thesis by blast
 qed
 
 context wf_digraph begin
 
 lemma trail_app_isoI:
   assumes t: "trail u p v"
     and hom: "digraph_isomorphism hom"
   shows "pre_digraph.trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
 proof -
   interpret H: wf_digraph "app_iso hom G" using hom ..
   from t hom have i: "inj_on (iso_arcs hom) (set p)"
      unfolding trail_def digraph_isomorphism_def by (auto dest:subset_inj_on[where A="set p"])
   then have "distinct (map (iso_arcs hom) p) = distinct p"
     by (auto simp: distinct_map dest: inj_onD)
   with t hom show ?thesis
     by (auto simp: pre_digraph.trail_def awalk_app_isoI)
 qed
 
 lemma euler_trail_app_isoI:
   assumes t: "euler_trail u p v"
     and hom: "digraph_isomorphism hom"
   shows "pre_digraph.euler_trail (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
 proof -
   from t have "awalk u p v" by (auto simp: euler_trail_def trail_def)
   with assms show ?thesis
     by (simp add: pre_digraph.euler_trail_def trail_app_isoI awalk_verts_app_iso_eq)
 qed
 
 
 end
 
 context fin_digraph begin
 
 (* XXX: We can get rid of "u \<in> verts G" "v \<in> verts G" here and in @{thm open_euler_infinite_label} *)
 theorem open_euler1:
   assumes "connected G"
   assumes "u \<in> verts G" "v \<in> verts G"
   assumes "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
   assumes "in_degree G u + 1 = out_degree G u"
   assumes "out_degree G v + 1 = in_degree G v"
   shows "\<exists>p. euler_trail u p v"
 proof -
   obtain f and n :: nat where "f ` arcs G = {i. i < n}"
       and i: "inj_on f (arcs G)"
     by atomize_elim (rule finite_imp_inj_to_nat_seg, auto)
 
   define iso_f where "iso_f =
     \<lparr> iso_verts = id, iso_arcs = (\<lambda>a. (tail G a, f a, head G a)),
       head = snd o snd, tail = fst \<rparr>"
   have [simp]: "iso_verts iso_f = id" "iso_head iso_f = snd o snd" "iso_tail iso_f = fst"
     unfolding iso_f_def by auto
   have di_iso_f: "digraph_isomorphism iso_f" unfolding digraph_isomorphism_def iso_f_def
     by (auto intro: inj_onI wf_digraph dest: inj_onD[OF i])
 
   let ?iso_g = "inv_iso iso_f"
   have [simp]: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts ?iso_g u = u"
     by (auto simp: inv_iso_def fun_eq_iff the_inv_into_f_eq)
 
   let ?H = "app_iso iso_f G"
   interpret H: fin_digraph ?H using di_iso_f ..
 
   have "\<exists>p. H.euler_trail u p v"
     using di_iso_f assms i
     by (intro open_euler_infinite_label) (auto simp: connectedI_app_iso app_iso_eq)
   then obtain p where Het: "H.euler_trail u p v" by blast
 
   have "pre_digraph.euler_trail (app_iso ?iso_g ?H) (iso_verts ?iso_g u) (map (iso_arcs ?iso_g) p) (iso_verts ?iso_g v)"
     using Het by (intro H.euler_trail_app_isoI digraph_isomorphism_invI di_iso_f)
   then show ?thesis using di_iso_f \<open>u \<in> _\<close> \<open>v \<in> _\<close> by simp rule
 qed
 
 theorem open_euler2:
   assumes et: "euler_trail u p v" and "u \<noteq> v"
   shows "connected G \<and>
     (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
     in_degree G u + 1 = out_degree G u \<and>
     out_degree G v + 1 = in_degree G v"
 proof -
   from et have *: "trail u p v" "u \<in> verts G" "v \<in> verts G"
     by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)
 
   from et have [simp]: "\<And>u. card (in_arcs G u \<inter> set p) = in_degree G u"
       "\<And>u. card (out_arcs G u \<inter> set p) = out_degree G u"
     by (auto simp: in_degree_def out_degree_def euler_trail_def intro: arg_cong[where f=card])
 
   from assms * show ?thesis
     by (auto simp: arc_set_balance_def elim: trail_arc_balanceE
         intro: euler_imp_connected)
 qed
 
 corollary open_euler:
   "(\<exists>u p v. euler_trail u p v \<and> u \<noteq> v) \<longleftrightarrow>
     connected G \<and> (\<exists>u v. u \<in> verts G \<and> v \<in> verts G \<and>
       (\<forall>w \<in> verts G. u \<noteq> w \<longrightarrow> v \<noteq> w \<longrightarrow> in_degree G w = out_degree G w) \<and>
       in_degree G u + 1 = out_degree G u \<and>
       out_degree G v + 1 = in_degree G v)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   then obtain u p v where *: "euler_trail u p v" "u \<noteq> v"
     by auto
   then have "u \<in> verts G" "v \<in> verts G"
     by (auto simp: euler_trail_def trail_def awalk_hd_in_verts)
   then show ?R using open_euler2[OF *] by blast
 next
   assume ?R
   then obtain u v where *:
     "connected G" "u \<in> verts G" "v \<in> verts G"
     "\<And>w. \<lbrakk>w \<in> verts G; u \<noteq> w; v \<noteq> w\<rbrakk> \<Longrightarrow> in_degree G w = out_degree G w"
     "in_degree G u + 1 = out_degree G u"
     "out_degree G v + 1 = in_degree G v"
     by blast
   then have "u \<noteq> v" by auto
   from * show ?L by (metis open_euler1 \<open>u \<noteq> v\<close>)
 qed
 
 end
 
 end
diff --git a/thys/LTL_to_DRA/Auxiliary/List2.thy b/thys/LTL_to_DRA/Auxiliary/List2.thy
--- a/thys/LTL_to_DRA/Auxiliary/List2.thy
+++ b/thys/LTL_to_DRA/Auxiliary/List2.thy
@@ -1,286 +1,281 @@
 (*  
     Author:      Salomon Sickert
     License:     BSD
 *)
 
 section \<open>Auxiliary List Facts\<close>
 
 theory List2                  
   imports Main "HOL-Library.Omega_Words_Fun" "List-Index.List_Index" 
 begin
 
 subsection \<open>remdups\_fwd\<close>
 \<comment> \<open>Remove duplicates of a list in a forward moving direction\<close>
 
 fun remdups_fwd_acc 
 where
   "remdups_fwd_acc Acc [] = []"
 | "remdups_fwd_acc Acc (x#xs) = (if x \<in> Acc then [] else [x]) @ remdups_fwd_acc (insert x Acc) xs"
 
 lemma remdups_fwd_acc_append[simp]:
   "remdups_fwd_acc Acc (xs@ys) = (remdups_fwd_acc Acc xs) @ (remdups_fwd_acc (Acc \<union> set xs) ys)"
   by (induction xs arbitrary: Acc) simp+
 
 lemma remdups_fwd_acc_set[simp]:
   "set (remdups_fwd_acc Acc xs) = set xs - Acc"
   by (induction xs arbitrary: Acc) force+
 
 lemma remdups_fwd_acc_distinct:
   "distinct (remdups_fwd_acc Acc xs)"
   by (induction xs arbitrary: Acc rule: rev_induct) simp+
 
 lemma remdups_fwd_acc_empty:
   "set xs \<subseteq> Acc \<longleftrightarrow> remdups_fwd_acc Acc xs = []"
   by (metis remdups_fwd_acc_set set_empty Diff_eq_empty_iff Diff_eq_empty_iff)
 
 lemma remdups_fwd_acc_drop:
   "set ys \<subseteq> Acc \<union> set xs \<Longrightarrow> remdups_fwd_acc Acc (xs @ ys @ zs) = remdups_fwd_acc Acc (xs @ zs)"
   by (simp add: remdups_fwd_acc_empty sup.absorb1)
 
 lemma remdups_fwd_acc_filter:
   "remdups_fwd_acc Acc (filter P xs) = filter P (remdups_fwd_acc Acc xs)"
   by (induction xs rule: rev_induct) simp+
 
 fun remdups_fwd
 where
   "remdups_fwd xs = remdups_fwd_acc {} xs "
 
 lemma remdups_fwd_eq:
   "remdups_fwd xs = (rev o remdups o rev) xs"
   by (induction xs rule: rev_induct) simp+
 
 lemma remdups_fwd_set[simp]:
   "set (remdups_fwd xs) = set xs"
   by simp
 
 lemma remdups_fwd_distinct:
   "distinct (remdups_fwd xs)"
   using remdups_fwd_acc_distinct by simp
 
 lemma remdups_fwd_filter:
   "remdups_fwd (filter P xs) = filter P (remdups_fwd xs)"
   using remdups_fwd_acc_filter by simp
 
 subsection \<open>Split Lemmas\<close>
 
 lemma map_splitE:
   assumes "map f xs = ys @ zs"
   obtains us vs where "xs = us @ vs" and "map f us = ys" and "map f vs = zs"
   by (insert assms; induction ys arbitrary: xs) 
      (simp_all add: map_eq_Cons_conv, metis append_Cons) 
   
 lemma filter_split':
   "filter P xs = ys @ zs \<Longrightarrow> \<exists>us vs. xs = us @ vs \<and> filter P us = ys \<and> filter P vs = zs"
 proof (induction ys arbitrary: zs xs rule: rev_induct)
   case (snoc y ys)
     obtain us vs where "xs = us @ vs" and "filter P us = ys" and "filter P vs = y # zs"
       using snoc(1)[OF snoc(2)[unfolded append_assoc]] by auto
     moreover
     then obtain vs' vs'' where "vs = vs' @ y # vs''" and "y \<notin> set vs'" and "(\<forall>u\<in>set vs'. \<not> P u)" and "filter P vs'' = zs" and "P y"
       unfolding filter_eq_Cons_iff by blast
     ultimately
     have "xs = (us @ vs' @ [y]) @ vs''" and "filter P (us @ vs' @ [y]) = ys @ [y]" and "filter P (vs'') = zs"
       unfolding filter_append by auto
     thus ?case
       by blast
 qed fastforce
 
 lemma filter_splitE:
   assumes "filter P xs = ys @ zs"
   obtains us vs where "xs = us @ vs" and "filter P us = ys" and "filter P vs = zs"
   using filter_split'[OF assms] by blast
 
 lemma filter_map_splitE:
   assumes "filter P (map f xs) = ys @ zs"
   obtains us vs where "xs = us @ vs" and "filter P (map f us) = ys" and "filter P (map f vs) = zs"
   using assms by (fastforce elim: filter_splitE map_splitE)
 
 lemma filter_map_split_iff:
   "filter P (map f xs) = ys @ zs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> filter P (map f us) = ys \<and> filter P (map f vs) = zs)"
   by (fastforce elim: filter_map_splitE)
 
 lemma list_empty_prefix:
   "xs @ y # zs = y # us \<Longrightarrow> y \<notin> set xs \<Longrightarrow> xs = []"
   by (metis hd_append2 list.sel(1) list.set_sel(1))
 
 lemma remdups_fwd_split:
   "remdups_fwd_acc Acc xs = ys @ zs \<Longrightarrow> \<exists>us vs. xs = us @ vs \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys) vs = zs"
 proof (induction ys arbitrary: zs rule: rev_induct)
   case (snoc y ys)
     then obtain us vs where "xs = us @ vs" 
       and "remdups_fwd_acc Acc us = ys" 
       and "remdups_fwd_acc (Acc \<union> set ys) vs = y # zs"
       by fastforce
     moreover
     hence "y \<in> set vs" and "y \<notin> Acc \<union> set ys"
       using remdups_fwd_acc_set[of "Acc \<union> set ys" vs] by auto
     moreover
     then obtain vs' vs'' where "vs = vs' @ y # vs''" and "y \<notin> set vs'" 
       using split_list_first by metis
     moreover
     hence "remdups_fwd_acc (Acc \<union> set ys) vs' = []"
       using \<open>remdups_fwd_acc (Acc \<union> set ys) vs = y # zs\<close> \<open>y \<notin> Acc \<union> set ys\<close>
       by (force intro: list_empty_prefix)
     ultimately
     have "xs = (us @ vs' @ [y]) @ vs''"
       and "remdups_fwd_acc Acc (us @ vs' @ [y]) = ys @ [y]"
       and "remdups_fwd_acc (Acc \<union> set (ys @ [y])) vs'' = zs"
       by (auto simp add: remdups_fwd_acc_empty sup.absorb1) 
     thus ?case
       by blast  
 qed force
 
 lemma remdups_fwd_split_exact:
   assumes "remdups_fwd_acc Acc xs = ys @ x # zs"
   shows "\<exists>us vs. xs = us @ x # vs \<and> x \<notin> Acc \<and> x \<notin> set ys \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs"
 proof -
   obtain us vs where "xs = us @ vs" and "remdups_fwd_acc Acc us = ys" and "remdups_fwd_acc (Acc \<union> set ys) vs = x # zs"
     using assms by (blast dest: remdups_fwd_split)
   moreover
   hence "x \<in> set vs" and "x \<notin> Acc \<union> set ys"
     using remdups_fwd_acc_set[of "Acc \<union> set ys"] by (fastforce, metis (no_types) Diff_iff list.set_intros(1))
   moreover
   then obtain vs' vs'' where "vs = vs' @ x # vs''" and "x \<notin> set vs'" 
     by (blast dest: split_list_first)
   moreover
   hence "set vs' \<subseteq> Acc \<union> set ys"
     using \<open>remdups_fwd_acc (Acc \<union> set ys) vs = x # zs\<close> \<open>x \<notin> Acc \<union> set ys\<close> 
     unfolding remdups_fwd_acc_empty by (fastforce intro: list_empty_prefix)
   moreover
   hence "remdups_fwd_acc (Acc \<union> set ys) vs' = []"
     using remdups_fwd_acc_empty by blast
   ultimately
   have "xs = (us @ vs') @ x # vs''"
     and "remdups_fwd_acc Acc (us @ vs') = ys"
     and "remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs'' = zs"
     by (fastforce dest: sup.absorb1)+ 
   thus ?thesis
     using \<open>x \<notin> Acc \<union> set ys\<close> by blast
 qed
 
 lemma remdups_fwd_split_exactE:
   assumes "remdups_fwd_acc Acc xs = ys @ x # zs"
   obtains us vs where "xs = us @ x # vs" and "x \<notin> set us" and "remdups_fwd_acc Acc us = ys" and "remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs"
     using remdups_fwd_split_exact[OF assms] by auto
 
 lemma remdups_fwd_split_exact_iff:
   "remdups_fwd_acc Acc xs = ys @ x # zs \<longleftrightarrow> 
     (\<exists>us vs. xs = us @ x # vs \<and> x \<notin> Acc \<and> x \<notin> set us \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs)"
   using remdups_fwd_split_exact by fastforce 
 
 lemma sorted_pre:
   "(\<And>x y xs ys. zs = xs @ [x, y] @ ys \<Longrightarrow> x \<le> y) \<Longrightarrow> sorted zs"
 apply (induction zs)
  apply simp
 by (metis append_Nil append_Cons list.exhaust sorted1 sorted2)
 
 lemma sorted_list:
   assumes "x \<in> set xs" and "y \<in> set xs"
   assumes "sorted (map f xs)" and "f x < f y"
   shows "\<exists>xs' xs'' xs'''. xs = xs' @ x # xs'' @ y # xs'''"
 proof -
   obtain ys zs where "xs = ys @ y # zs" and "y \<notin> set ys"
     using assms by (blast dest: split_list_first)
   moreover
   hence "sorted (map f (y # zs))" 
     using \<open>sorted (map f xs)\<close> by (simp add: sorted_append)
   hence "\<forall>x\<in>set (map f (y # zs)). f y \<le> x"
     by force
   hence "\<forall>x\<in>set (y # zs). f y \<le> f x"
     by auto
   have "x \<in> set ys"
     apply (rule ccontr)
     using \<open>f x < f y\<close> \<open>x \<in> set xs\<close> \<open>\<forall>x\<in>set (y # zs). f y \<le> f x\<close> unfolding \<open>xs = ys @ y # zs\<close> set_append by auto
   then obtain ys' zs' where "ys = ys' @ x # zs'"
     using assms by (blast dest: split_list_first)
   ultimately
   show ?thesis
     by auto
 qed
     
 lemma takeWhile_foo:
   "x \<notin> set ys \<Longrightarrow> ys = takeWhile (\<lambda>y. y \<noteq> x) (ys @ x # zs)"
   by (metis (mono_tags, lifting) append_Nil2 takeWhile.simps(2) takeWhile_append2)
 
 lemma takeWhile_split:
   "x \<in> set xs \<Longrightarrow> y \<in> set (takeWhile (\<lambda>y. y \<noteq> x) xs) \<Longrightarrow> \<exists>xs' xs'' xs'''. xs = xs' @ y # xs'' @ x # xs'''"
   using split_list_first by (metis append_Cons append_assoc takeWhile_foo)
  
 lemma takeWhile_distinct:
   "distinct (xs' @ x # xs'') \<Longrightarrow> y \<in> set (takeWhile (\<lambda>y. y \<noteq> x) (xs' @ x # xs'')) \<longleftrightarrow> y \<in> set xs'"
   by (induction xs') simp+
 
 lemma finite_lists_length_eqE:
   assumes "finite A" 
   shows "finite {xs. set xs = A \<and> length xs = n}"
 proof -
   have "{xs. set xs = A \<and> length xs = n} \<subseteq> {xs. set xs \<subseteq> A \<and> length xs = n}"
     by blast
   thus ?thesis
     using finite_lists_length_eq[OF assms(1), of n] using finite_subset by auto
 qed
 
 lemma finite_set2:
-  assumes "card A = n" and "finite A"
+  assumes "finite A"
   shows "finite {xs. set xs = A \<and> distinct xs}"
-proof -
-  have "{xs. set xs = A \<and> distinct xs} \<subseteq> {xs. set xs = A \<and> length xs = n}"
-    using assms(1) distinct_card by fastforce
-  thus ?thesis
-    by (metis (no_types, lifting) finite_lists_length_eqE[OF \<open>finite A\<close>, of n] finite_subset)
-qed
+by(blast intro: rev_finite_subset[OF finite_subset_distinct[OF assms]])
 
 lemma set_list: 
   assumes "finite (set ` XS)"
   assumes "\<And>xs. xs \<in> XS \<Longrightarrow> distinct xs"
   shows "finite XS"
 proof -
   have "XS \<subseteq> {xs | xs. set xs \<in> set ` XS \<and> distinct xs}"
     using assms by auto
   moreover
   have 1: "{xs |xs. set xs \<in> set ` XS \<and> distinct xs} = \<Union>{{xs | xs. set xs = A \<and> distinct xs} | A. A \<in> set ` XS}"
     by auto
   have "finite {xs |xs. set xs \<in> set ` XS \<and> distinct xs}"
-    using finite_set2[OF _ finite_set] distinct_card  assms(1) unfolding 1 by fastforce
+    using finite_set2[OF finite_set] distinct_card  assms(1) unfolding 1 by fastforce
   ultimately
   show ?thesis
     using finite_subset by blast
 qed
 
 lemma set_foldl_append:
   "set (foldl (@) i xs) = set i \<union> \<Union>{set x | x. x \<in> set xs}"
   by (induction xs arbitrary: i) auto
 
 subsection \<open>Short-circuited Version of @{const foldl}\<close>
 
 fun foldl_break :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b"
 where
   "foldl_break f s a [] = a" 
 | "foldl_break f s a (x # xs) = (if s a then a else foldl_break f s (f a x) xs)"
 
 lemma foldl_break_append:
   "foldl_break f s a (xs @ ys) = (if s (foldl_break f s a xs) then foldl_break f s a xs else (foldl_break f s (foldl_break f s a xs) ys))"
   by (induction xs arbitrary: a) (cases ys, auto)
 
 subsection \<open>Suffixes\<close>
 
 \<comment> \<open>Non empty suffixes of finite words - specialised!\<close>
 
 fun suffixes
 where
   "suffixes [] = []"
 | "suffixes (x#xs) = (suffixes xs) @ [x#xs]"
 
 lemma suffixes_append:
   "suffixes (xs @ ys) = (suffixes ys) @ (map (\<lambda>zs. zs @ ys) (suffixes xs))"
   by (induction xs) simp_all
 
 lemma suffixes_alt_def:
   "suffixes xs = rev (prefix (length xs) (\<lambda>i. drop i xs))"
 proof (induction xs rule: rev_induct)
   case (snoc x xs)
     show ?case
       by (simp add: subsequence_def suffixes_append snoc rev_map)
 qed simp
 
 end
diff --git a/thys/Markov_Models/Markov_Models_Auxiliary.thy b/thys/Markov_Models/Markov_Models_Auxiliary.thy
--- a/thys/Markov_Models/Markov_Models_Auxiliary.thy
+++ b/thys/Markov_Models/Markov_Models_Auxiliary.thy
@@ -1,602 +1,602 @@
 (* Author: Johannes Hölzl <hoelzl@in.tum.de> *)
 
 section \<open>Auxiliary Theory\<close>
 
 text \<open>Parts of it should be moved to the Isabelle repository\<close>
 
 theory Markov_Models_Auxiliary
 imports
   "HOL-Probability.Probability"
   "HOL-Library.Rewrite"
   "HOL-Library.Linear_Temporal_Logic_on_Streams"
   Coinductive.Coinductive_Stream
   Coinductive.Coinductive_Nat
 begin
 
 lemma lfp_upperbound: "(\<And>y. x \<le> f y) \<Longrightarrow> x \<le> lfp f"
   unfolding lfp_def by (intro Inf_greatest) (auto intro: order_trans)
 
 (* ?? *)
 lemma lfp_arg: "(\<lambda>t. lfp (F t)) = lfp (\<lambda>x t. F t (x t))"
   apply (auto simp: lfp_def le_fun_def fun_eq_iff intro!: Inf_eqI Inf_greatest)
   subgoal for x y
     by (rule INF_lower2[of "top(x := y)"]) auto
   done
 
 lemma lfp_pair: "lfp (\<lambda>f (a, b). F (\<lambda>a b. f (a, b)) a b) (a, b) = lfp F a b"
   unfolding lfp_def
   by (auto intro!: INF_eq simp: le_fun_def)
      (auto intro!: exI[of _ "\<lambda>(a, b). x a b" for x])
 
 lemma all_Suc_split: "(\<forall>i. P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i. P (Suc i)))"
   using nat_induct by auto
 
 definition "with P f d = (if \<exists>x. P x then f (SOME x. P x) else d)"
 
 lemma withI[case_names default exists]:
   "((\<And>x. \<not> P x) \<Longrightarrow> Q d) \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q (f x)) \<Longrightarrow> Q (with P f d)"
   unfolding with_def by (auto intro: someI2)
 
 context order
 begin
 
 definition
   "maximal f S = {x\<in>S. \<forall>y\<in>S. f y \<le> f x}"
 
 lemma maximalI: "x \<in> S \<Longrightarrow> (\<And>y. y \<in> S \<Longrightarrow> f y \<le> f x) \<Longrightarrow> x \<in> maximal f S"
   by (simp add: maximal_def)
 
 lemma maximalI_trans: "x \<in> maximal f S \<Longrightarrow> f x \<le> f y \<Longrightarrow> y \<in> S \<Longrightarrow> y \<in> maximal f S"
   unfolding maximal_def by (blast intro: antisym order_trans)
 
 lemma maximalD1: "x \<in> maximal f S \<Longrightarrow> x \<in> S"
   by (simp add: maximal_def)
 
 lemma maximalD2: "x \<in> maximal f S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<le> f x"
   by (simp add: maximal_def)
 
 lemma maximal_inject: "x \<in> maximal f S \<Longrightarrow> y \<in> maximal f S \<Longrightarrow> f x = f y"
   by (rule order.antisym) (simp_all add: maximal_def)
 
 lemma maximal_empty[simp]: "maximal f {} = {}"
   by (simp add: maximal_def)
 
 lemma maximal_singleton[simp]: "maximal f {x} = {x}"
   by (auto simp add: maximal_def)
 
 lemma maximal_in_S: "maximal f S \<subseteq> S"
   by (auto simp: maximal_def)
 
 end
 
 context linorder
 begin
 
 lemma maximal_ne:
   assumes "finite S" "S \<noteq> {}"
   shows "maximal f S \<noteq> {}"
   using assms
 proof (induct rule: finite_ne_induct)
   case (insert s S)
   show ?case
   proof cases
     assume "\<forall>x\<in>S. f x \<le> f s"
     with insert have "s \<in> maximal f (insert s S)"
       by (auto intro!: maximalI)
     then show ?thesis
       by auto
   next
     assume "\<not> (\<forall>x\<in>S. f x \<le> f s)"
     then have "maximal f (insert s S) = maximal f S"
       by (auto simp: maximal_def)
     with insert show ?thesis
       by auto
   qed
 qed simp
 
 end
 
 lemma mono_les:
   fixes s S N and l1 l2 :: "'a \<Rightarrow> real" and K :: "'a \<Rightarrow> 'a pmf"
   defines "\<Delta> x \<equiv> l2 x - l1 x"
   assumes s: "s \<in> S" and S: "(\<Union>s\<in>S. set_pmf (K s)) \<subseteq> S \<union> N"
   assumes int_l1[simp]: "\<And>s. s \<in> S \<Longrightarrow> integrable (K s) l1"
   assumes int_l2[simp]: "\<And>s. s \<in> S \<Longrightarrow> integrable (K s) l2"
   assumes to_N: "\<And>s. s \<in> S \<Longrightarrow> \<exists>t\<in>N. (s, t) \<in> (SIGMA s:UNIV. K s)\<^sup>*"
   assumes l1: "\<And>s. s \<in> S \<Longrightarrow> (\<integral>t. l1 t \<partial>K s) + c s \<le> l1 s"
   assumes l2: "\<And>s. s \<in> S \<Longrightarrow> l2 s \<le> (\<integral>t. l2 t \<partial>K s) + c s"
   assumes eq: "\<And>s. s \<in> N \<Longrightarrow> l2 s \<le> l1 s"
   assumes finitary: "finite (\<Delta> ` (S\<union>N))"
   shows "l2 s \<le> l1 s"
 proof -
   define M where "M = {s\<in>S\<union>N. \<forall>t\<in>S\<union>N. \<Delta> t \<le> \<Delta> s}"
 
   have [simp]: "\<And>s. s\<in>S \<Longrightarrow> integrable (K s) \<Delta>"
     by (simp add: \<Delta>_def[abs_def])
 
   have M_unqiue: "\<And>s t. s \<in> M \<Longrightarrow> t \<in> M \<Longrightarrow> \<Delta> s = \<Delta> t"
     by (auto intro!: antisym simp: M_def)
   have M1: "\<And>s. s \<in> M \<Longrightarrow> s \<in> S \<union> N"
     by (auto simp: M_def)
   have M2: "\<And>s t. s \<in> M \<Longrightarrow> t \<in> S \<union> N \<Longrightarrow> \<Delta> t \<le> \<Delta> s"
     by (auto simp: M_def)
   have M3: "\<And>s t. s \<in> M \<Longrightarrow> t \<in> S \<union> N \<Longrightarrow> t \<notin> M \<Longrightarrow> \<Delta> t < \<Delta> s"
     by (auto simp: M_def less_le)
 
   have N: "\<forall>s\<in>N. \<Delta> s \<le> 0"
     using eq by (simp add: \<Delta>_def)
 
   { fix s assume s: "s \<in> M" "M \<inter> N = {}"
     then have "s \<in> S - N"
       by (auto dest: M1)
     with to_N[of s] obtain t where "(s, t) \<in> (SIGMA s:UNIV. K s)\<^sup>*" and "t \<in> N"
       by (auto simp: M_def)
     from this(1) \<open>s \<in> M\<close> have "\<Delta> s \<le> 0"
     proof (induction rule: converse_rtrancl_induct)
       case (step s s')
       then have s: "s \<in> M" "s \<in> S" "s \<notin> N" and s': "s' \<in> S \<union> N" "s' \<in> K s"
         using S \<open>M \<inter> N = {}\<close> by (auto dest: M1)
       have "s' \<in> M"
       proof (rule ccontr)
         assume "s' \<notin> M"
         with \<open>s \<in> S\<close> s' \<open>s \<in> M\<close>
         have "0 < pmf (K s) s'" "\<Delta> s' < \<Delta> s"
           by (auto intro: M2 M3 pmf_positive)
 
         have "\<Delta> s \<le> ((\<integral>t. l2 t \<partial>K s) + c s) - ((\<integral>t. l1 t \<partial>K s) + c s)"
           unfolding \<Delta>_def using \<open>s \<in> S\<close> \<open>s \<notin> N\<close> by (intro diff_mono l1 l2) auto
         then have "\<Delta> s \<le> (\<integral>s'. \<Delta> s' \<partial>K s)"
           using \<open>s \<in> S\<close> by (simp add: \<Delta>_def)
         also have "\<dots> < (\<integral>s'. \<Delta> s \<partial>K s)"
           using \<open>s' \<in> K s\<close> \<open>\<Delta> s' < \<Delta> s\<close> \<open>s\<in>S\<close> S \<open>s\<in>M\<close>
           by (intro measure_pmf.integral_less_AE[where A="{s'}"])
              (auto simp: emeasure_measure_pmf_finite AE_measure_pmf_iff set_pmf_iff[symmetric]
                    intro!: M2)
         finally show False
           using measure_pmf.prob_space[of "K s"] by simp
       qed
       with step.IH \<open>t\<in>N\<close> N have "\<Delta> s' \<le> 0" "s' \<in> M"
         by auto
       with \<open>s\<in>S\<close> show "\<Delta> s \<le> 0"
         by (force simp: M_def)
     qed (insert N \<open>t\<in>N\<close>, auto) }
 
   show ?thesis
   proof cases
     assume "M \<inter> N = {}"
     have "Max (\<Delta>`(S\<union>N)) \<in> \<Delta>`(S\<union>N)"
       using \<open>s \<in> S\<close> by (intro Max_in finitary) auto
     then obtain t where "t \<in> S \<union> N" "\<Delta> t = Max (\<Delta>`(S\<union>N))"
       unfolding image_iff by metis
     then have "t \<in> M"
       by (auto simp: M_def finitary intro!: Max_ge)
     have "\<Delta> s \<le> \<Delta> t"
       using \<open>t\<in>M\<close> \<open>s\<in>S\<close> by (auto dest: M2)
     also have "\<Delta> t \<le> 0"
       using \<open>t\<in>M\<close> \<open>M \<inter> N = {}\<close> by fact
     finally show ?thesis
       by (simp add: \<Delta>_def)
   next
     assume "M \<inter> N \<noteq> {}"
     then obtain t where "t \<in> M" "t \<in> N" by auto
     with N \<open>s\<in>S\<close> have "\<Delta> s \<le> 0"
       by (intro order_trans[of "\<Delta> s" "\<Delta> t" 0]) (auto simp: M_def)
     then show ?thesis
       by (simp add: \<Delta>_def)
   qed
 qed
 
 lemma unique_les:
   fixes s S N and l1 l2 :: "'a \<Rightarrow> real" and K :: "'a \<Rightarrow> 'a pmf"
   defines "\<Delta> x \<equiv> l2 x - l1 x"
   assumes s: "s \<in> S" and S: "(\<Union>s\<in>S. set_pmf (K s)) \<subseteq> S \<union> N"
   assumes "\<And>s. s \<in> S \<Longrightarrow> integrable (K s) l1"
   assumes "\<And>s. s \<in> S \<Longrightarrow> integrable (K s) l2"
   assumes "\<And>s. s \<in> S \<Longrightarrow> \<exists>t\<in>N. (s, t) \<in> (SIGMA s:UNIV. K s)\<^sup>*"
   assumes "\<And>s. s \<in> S \<Longrightarrow> l1 s = (\<integral>t. l1 t \<partial>K s) + c s"
   assumes "\<And>s. s \<in> S \<Longrightarrow> l2 s = (\<integral>t. l2 t \<partial>K s) + c s"
   assumes "\<And>s. s \<in> N \<Longrightarrow> l2 s = l1 s"
   assumes 1: "finite (\<Delta> ` (S\<union>N))"
   shows "l2 s = l1 s"
 proof -
   have "finite ((\<lambda>x. l2 x - l1 x) ` (S\<union>N))"
     using 1 by (auto simp: \<Delta>_def[abs_def])
   moreover then have "finite (uminus ` (\<lambda>x. l2 x - l1 x) ` (S\<union>N))"
     by auto
   ultimately show ?thesis
     using assms
     by (intro antisym mono_les[of s S K N l2 l1 c] mono_les[of s S K N l1 l2 c])
        (auto simp: image_comp comp_def)
 qed
 
 lemma inf_continuous_suntil_disj[order_continuous_intros]:
   assumes Q: "inf_continuous Q"
   assumes disj: "\<And>x \<omega>. \<not> (P \<omega> \<and> Q x \<omega>)"
   shows "inf_continuous (\<lambda>x. P suntil Q x)"
   unfolding inf_continuous_def
 proof (safe intro!: ext)
   fix M \<omega> i assume "(P suntil Q (\<Sqinter>i. M i)) \<omega>" "decseq M" then show "(P suntil Q (M i)) \<omega>"
     unfolding inf_continuousD[OF Q \<open>decseq M\<close>] by induction (auto intro: suntil.intros)
 next
   fix M \<omega> assume *: "(\<Sqinter>i. P suntil Q (M i)) \<omega>" "decseq M"
   then have "(P suntil Q (M 0)) \<omega>"
     by auto
   from this * show "(P suntil Q (\<Sqinter>i. M i)) \<omega>"
     unfolding inf_continuousD[OF Q \<open>decseq M\<close>]
   proof induction
     case (base \<omega>) with disj[of \<omega> "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
   next
     case (step \<omega>) with disj[of \<omega> "M _"] show ?case by (auto intro: suntil.intros elim: suntil.cases)
   qed
 qed
 
 lemma inf_continuous_nxt[order_continuous_intros]: "inf_continuous P \<Longrightarrow> inf_continuous (\<lambda>x. nxt (P x) \<omega>)"
   by (auto simp: inf_continuous_def image_comp)
 
 lemma sup_continuous_nxt[order_continuous_intros]: "sup_continuous P \<Longrightarrow> sup_continuous (\<lambda>x. nxt (P x) \<omega>)"
   by (auto simp: sup_continuous_def image_comp)
 
 lemma mcont_ennreal_of_enat: "mcont Sup (\<le>) Sup (\<le>) ennreal_of_enat"
   by (auto intro!: mcontI monotoneI contI ennreal_of_enat_Sup)
 
 lemma mcont2mcont_ennreal_of_enat[cont_intro]:
   "mcont lub ord Sup (\<le>) f \<Longrightarrow> mcont lub ord Sup (\<le>) (\<lambda>x. ennreal_of_enat (f x))"
   by (auto intro: ccpo.mcont2mcont[OF complete_lattice_ccpo'] mcont_ennreal_of_enat)
 
 declare stream.exhaust[cases type: stream]
 
 lemma scount_eq_emeasure: "scount P \<omega> = emeasure (count_space UNIV) {i. P (sdrop i \<omega>)}"
 proof cases
   assume "alw (ev P) \<omega>"
   moreover then have "infinite {i. P (sdrop i \<omega>)}"
     using infinite_iff_alw_ev[of P \<omega>] by simp
   ultimately show ?thesis
     by (simp add: scount_infinite_iff[symmetric])
 next
   assume "\<not> alw (ev P) \<omega>"
   moreover then have "finite {i. P (sdrop i \<omega>)}"
     using infinite_iff_alw_ev[of P \<omega>] by simp
   ultimately show ?thesis
     by (simp add: not_alw_iff not_ev_iff scount_eq_card)
 qed
 
 lemma measurable_scount[measurable]:
   assumes [measurable]: "Measurable.pred (stream_space M) P"
   shows "scount P \<in> measurable (stream_space M) (count_space UNIV)"
   unfolding scount_eq[abs_def] by measurable
 
 lemma measurable_sfirst2:
   assumes [measurable]: "Measurable.pred (N \<Otimes>\<^sub>M stream_space M) (\<lambda>(x, \<omega>). P x \<omega>)"
   shows "(\<lambda>(x, \<omega>). sfirst (P x) \<omega>) \<in> measurable (N \<Otimes>\<^sub>M  stream_space M) (count_space UNIV)"
   apply (coinduction rule: measurable_enat_coinduct)
   apply simp
   apply (rule exI[of _ "\<lambda>x. 0"])
   apply (rule exI[of _ "\<lambda>(x, \<omega>). (x, stl \<omega>)"])
   apply (rule exI[of _ "\<lambda>(x, \<omega>). P x \<omega>"])
   apply (subst sfirst.simps[abs_def])
   apply (simp add: fun_eq_iff)
   done
 
 lemma measurable_sfirst2'[measurable (raw)]:
   assumes [measurable (raw)]: "f \<in> N \<rightarrow>\<^sub>M stream_space M" "Measurable.pred (N \<Otimes>\<^sub>M stream_space M) (\<lambda>x. P (fst x) (snd x))"
   shows "(\<lambda>x. sfirst (P x) (f x)) \<in> measurable N (count_space UNIV)"
   using measurable_sfirst2[measurable] by measurable
 
 lemma measurable_sfirst[measurable]:
   assumes [measurable]: "Measurable.pred (stream_space M) P"
   shows "sfirst P \<in> measurable (stream_space M) (count_space UNIV)"
   by measurable
 
 lemma measurable_epred[measurable]: "epred \<in> count_space UNIV \<rightarrow>\<^sub>M count_space UNIV"
   by (rule measurable_count_space)
 
 lemma nn_integral_stretch:
   "f \<in> borel \<rightarrow>\<^sub>M borel \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> (\<integral>\<^sup>+x. f (c * x) \<partial>lborel) = (1 / \<bar>c\<bar>::real) * (\<integral>\<^sup>+x. f x \<partial>lborel)"
   using nn_integral_real_affine[of f c 0] by (simp add: mult.assoc[symmetric] ennreal_mult[symmetric])
 
 lemma prod_sum_distrib:
   fixes f g :: "'a \<Rightarrow> 'b \<Rightarrow> 'c::comm_semiring_1"
   assumes "finite I" shows "(\<And>i. i \<in> I \<Longrightarrow> finite (J i)) \<Longrightarrow> (\<Prod>i\<in>I. \<Sum>j\<in>J i. f i j) = (\<Sum>m\<in>Pi\<^sub>E I J. \<Prod>i\<in>I. f i (m i))"
   using \<open>finite I\<close>
 proof induction
   case (insert i I) then show ?case
     by (auto simp: PiE_insert_eq finite_PiE sum.reindex inj_combinator sum.swap[of _ "Pi\<^sub>E I J"]
-                   sum_cartesian_product' sum_distrib_left sum_distrib_right
+                   sum.cartesian_product' sum_distrib_left sum_distrib_right
              intro!: sum.cong prod.cong arg_cong[where f="(*) x" for x])
 qed simp
 
 lemma prod_add_distrib:
   fixes f g :: "'a \<Rightarrow> 'b::comm_semiring_1"
   assumes "finite I" shows "(\<Prod>i\<in>I. f i + g i) = (\<Sum>J\<in>Pow I. (\<Prod>i\<in>J. f i) * (\<Prod>i\<in>I - J. g i))"
 proof -
   have "(\<Prod>i\<in>I. f i + g i) = (\<Prod>i\<in>I. \<Sum>b\<in>{True, False}. if b then f i else g i)"
     by simp
   also have "\<dots> = (\<Sum>m\<in>I \<rightarrow>\<^sub>E {True, False}. \<Prod>i\<in>I. if m i then f i else g i)"
     using \<open>finite I\<close> by (rule prod_sum_distrib) simp
   also have "\<dots> = (\<Sum>J\<in>Pow I. (\<Prod>i\<in>J. f i) * (\<Prod>i\<in>I - J. g i))"
     by (rule sum.reindex_bij_witness[where i="\<lambda>J. \<lambda>i\<in>I. i\<in>J" and j="\<lambda>m. {i\<in>I. m i}"])
        (auto simp: fun_eq_iff prod.If_cases \<open>finite I\<close> intro!: arg_cong2[where f="(*)"] prod.cong)
   finally show ?thesis .
 qed
 
 subclass (in linordered_nonzero_semiring) ordered_semiring_0
   proof qed
 
 lemma (in linordered_nonzero_semiring) prod_nonneg: "(\<forall>a\<in>A. 0 \<le> f a) \<Longrightarrow> 0 \<le> prod f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma (in linordered_nonzero_semiring) prod_mono:
   "\<forall>i\<in>A. 0 \<le> f i \<and> f i \<le> g i \<Longrightarrow> prod f A \<le> prod g A"
   by (induct A rule: infinite_finite_induct) (auto intro!: prod_nonneg mult_mono)
 
 lemma (in linordered_nonzero_semiring) prod_mono2:
   assumes "finite J" "I \<subseteq> J" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> g i \<and> g i \<le> f i" "(\<And>i. i \<in> J - I \<Longrightarrow> 1 \<le> f i)"
   shows "prod g I \<le> prod f J"
 proof -
   have "prod g I = (\<Prod>i\<in>J. if i \<in> I then g i else 1)"
     using \<open>finite J\<close> \<open>I \<subseteq> J\<close> by (simp add: prod.If_cases Int_absorb1)
   also have "\<dots> \<le> prod f J"
     using assms by (intro prod_mono) auto
   finally show ?thesis .
 qed
 
 lemma (in linordered_nonzero_semiring) prod_mono3:
   assumes "finite J" "I \<subseteq> J" "\<And>i. i \<in> J \<Longrightarrow> 0 \<le> g i" "\<And>i. i \<in> I \<Longrightarrow> g i \<le> f i" "(\<And>i. i \<in> J - I \<Longrightarrow> g i \<le> 1)"
   shows "prod g J \<le> prod f I"
 proof -
   have "prod g J \<le> (\<Prod>i\<in>J. if i \<in> I then f i else 1)"
     using assms by (intro prod_mono) auto
   also have "\<dots> = prod f I"
     using \<open>finite J\<close> \<open>I \<subseteq> J\<close> by (simp add: prod.If_cases Int_absorb1)
   finally show ?thesis .
 qed
 
 lemma (in linordered_nonzero_semiring) one_le_prod: "(\<And>i. i \<in> I \<Longrightarrow> 1 \<le> f i) \<Longrightarrow> 1 \<le> prod f I"
 proof (induction I rule: infinite_finite_induct)
   case (insert i I) then show ?case
     using mult_mono[of 1 "f i" 1 "prod f I"]
     by (auto intro: order_trans[OF zero_le_one])
 qed auto
 
 lemma sum_plus_one_le_prod_plus_one:
   fixes p :: "'a \<Rightarrow> 'b::linordered_nonzero_semiring"
   assumes "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> p i"
   shows "(\<Sum>i\<in>I. p i) + 1 \<le> (\<Prod>i\<in>I. p i + 1)"
 proof cases
   assume [simp]: "finite I"
   with assms have [simp]: "J \<subseteq> I \<Longrightarrow> 0 \<le> prod p J" for J
     by (intro prod_nonneg) auto
   have "1 + (\<Sum>i\<in>I. p i) = (\<Sum>J\<in>insert {} ((\<lambda>x. {x})`I). (\<Prod>i\<in>J. p i) * (\<Prod>i\<in>I - J. 1))"
     by (subst sum.insert) (auto simp: sum.reindex)
   also have "\<dots> \<le> (\<Sum>J\<in>Pow I. (\<Prod>i\<in>J. p i) * (\<Prod>i\<in>I - J. 1))"
     using assms by (intro sum_mono2) auto
   finally show ?thesis
     by (subst prod_add_distrib) (auto simp: add.commute)
 qed simp
 
 lemma summable_iff_convergent_prod:
   fixes p :: "nat \<Rightarrow> real" assumes p: "\<And>i. 0 \<le> p i"
   shows "summable p \<longleftrightarrow> convergent (\<lambda>n. \<Prod>i<n. p i + 1)"
   unfolding summable_iff_convergent
 proof
   assume "convergent (\<lambda>n. \<Prod>i<n. p i + 1)"
   then obtain x where x: "(\<lambda>n. \<Prod>i<n. p i + 1) \<longlonglongrightarrow> x"
     by (auto simp: convergent_def)
   then have "1 \<le> x"
     by (rule tendsto_lowerbound) (auto intro!: always_eventually one_le_prod p)
 
   have "convergent (\<lambda>n. 1 + (\<Sum>i<n. p i))"
   proof (intro Bseq_mono_convergent BseqI allI)
     show "0 < x" using \<open>1 \<le> x\<close> by auto
   next
     fix n
     have "norm ((\<Sum>i<n. p i) + 1) \<le> (\<Prod>i<n. p i + 1)"
       using p by (simp add: sum_nonneg sum_plus_one_le_prod_plus_one p)
     also have "\<dots> \<le> x"
       using assms
       by (intro tendsto_lowerbound[OF x])
           (auto simp: eventually_sequentially intro!: exI[of _ n] prod_mono2)
     finally show "norm (1 + sum p {..<n}) \<le> x"
       by (simp add: add.commute)
   qed (insert p, auto intro!: sum_mono2)
   then show "convergent (\<lambda>n. \<Sum>i<n. p i)"
     unfolding convergent_add_const_iff .
 next
   assume "convergent (\<lambda>n. \<Sum>i<n. p i)"
   then obtain x where x: "(\<lambda>n. exp (\<Sum>i<n. p i)) \<longlonglongrightarrow> exp x"
     by (force simp: convergent_def intro!: tendsto_exp)
   show "convergent (\<lambda>n. \<Prod>i<n. p i + 1)"
   proof (intro Bseq_mono_convergent BseqI allI)
     show "0 < exp x" by simp
   next
     fix n
     have "norm (\<Prod>i<n. p i + 1) \<le> exp (\<Sum>i<n. p i)"
       using p exp_ge_add_one_self[of "p _"] by (auto simp add: prod_nonneg exp_sum add.commute intro!: prod_mono)
     also have "\<dots> \<le> exp x"
       using p
       by (intro tendsto_lowerbound[OF x]) (auto simp: eventually_sequentially intro!: sum_mono2 )
     finally show "norm (\<Prod>i<n. p i + 1) \<le> exp x" .
   qed (insert p, auto intro!: prod_mono2)
 qed
 
 primrec eexp :: "ereal \<Rightarrow> ennreal"
   where
     "eexp MInfty = 0"
   | "eexp (ereal r) = ennreal (exp r)"
   | "eexp PInfty = top"
 
 lemma
   shows eexp_minus_infty[simp]: "eexp (-\<infinity>) = 0"
     and eexp_infty[simp]: "eexp \<infinity> = top"
   using eexp.simps by simp_all
 
 lemma eexp_0[simp]: "eexp 0 = 1"
   by (simp add: zero_ereal_def)
 
 lemma eexp_inj[simp]: "eexp x = eexp y \<longleftrightarrow> x = y"
   by (cases x; cases y; simp)
 
 lemma eexp_mono[simp]: "eexp x \<le> eexp y \<longleftrightarrow> x \<le> y"
   by (cases x; cases y; simp add: top_unique)
 
 lemma eexp_strict_mono[simp]: "eexp x < eexp y \<longleftrightarrow> x < y"
   by (simp add: less_le)
 
 lemma exp_eq_0_iff[simp]: "eexp x = 0 \<longleftrightarrow> x = -\<infinity>"
   using eexp_inj[of x "-\<infinity>"] unfolding eexp_minus_infty .
 
 lemma eexp_surj: "range eexp = UNIV"
 proof -
   have part: "UNIV = {0} \<union> {0 <..< top} \<union> {top::ennreal}"
     by (auto simp: less_top)
   show ?thesis
     unfolding part
     by (force simp: image_iff less_top less_top_ennreal intro!: eexp.simps[symmetric] eexp.simps dest: exp_total)
 qed
 
 lemma continuous_on_eexp': "continuous_on UNIV eexp"
   by (rule continuous_onI_mono) (auto simp: eexp_surj)
 
 lemma continuous_on_eexp[continuous_intros]: "continuous_on A f \<Longrightarrow> continuous_on A (\<lambda>x. eexp (f x))"
   by (rule continuous_on_compose2[OF continuous_on_eexp']) auto
 
 lemma tendsto_eexp[tendsto_intros]: "(f \<longlongrightarrow> x) F \<Longrightarrow> ((\<lambda>x. eexp (f x)) \<longlongrightarrow> eexp x) F"
   by (rule continuous_on_tendsto_compose[OF continuous_on_eexp']) auto
 
 lemma measurable_eexp[measurable]: "eexp \<in> borel \<rightarrow>\<^sub>M borel"
   using continuous_on_eexp' by (rule borel_measurable_continuous_onI)
 
 lemma eexp_add: "\<not> ((x = \<infinity> \<and> y = -\<infinity>) \<or> (x = -\<infinity> \<and> y = \<infinity>)) \<Longrightarrow> eexp (x + y) = eexp x * eexp y"
   by (cases x; cases y; simp add: exp_add ennreal_mult ennreal_top_mult ennreal_mult_top)
 
 lemma sum_Pinfty:
   fixes f :: "'a \<Rightarrow> ereal"
   shows "sum f I = \<infinity> \<longleftrightarrow> (finite I \<and> (\<exists>i\<in>I. f i = \<infinity>))"
   by (induction I rule: infinite_finite_induct) auto
 
 lemma sum_Minfty:
   fixes f :: "'a \<Rightarrow> ereal"
   shows "sum f I = -\<infinity> \<longleftrightarrow> (finite I \<and> \<not> (\<exists>i\<in>I. f i = \<infinity>) \<and> (\<exists>i\<in>I. f i = -\<infinity>))"
   by (induction I rule: infinite_finite_induct)
      (auto simp: sum_Pinfty)
 
 lemma eexp_sum: "\<not> (\<exists>i\<in>I. \<exists>j\<in>I. f i = -\<infinity> \<and> f j = \<infinity>) \<Longrightarrow> eexp (\<Sum>i\<in>I. f i) = (\<Prod>i\<in>I. eexp (f i))"
 proof (induction I rule: infinite_finite_induct)
   case (insert i I)
   have "eexp (sum f (insert i I)) = eexp (f i) * eexp (sum f I)"
     using insert.prems insert.hyps by (auto simp: sum_Pinfty sum_Minfty intro!: eexp_add)
   then show ?case
     using insert by auto
 qed simp_all
 
 lemma eexp_suminf:
   assumes wf_f: "\<not> {-\<infinity>, \<infinity>} \<subseteq> range f" and f: "summable f"
   shows "(\<lambda>n. \<Prod>i<n. eexp (f i)) \<longlonglongrightarrow> eexp (\<Sum>i. f i)"
 proof -
   have "(\<lambda>n. eexp (\<Sum>i<n. f i)) \<longlonglongrightarrow> eexp (\<Sum>i. f i)"
     by (intro tendsto_eexp summable_LIMSEQ f)
   also have "(\<lambda>n. eexp (\<Sum>i<n. f i)) = (\<lambda>n. \<Prod>i<n. eexp (f i))"
     using wf_f by (auto simp: fun_eq_iff image_iff eq_commute intro!: eexp_sum)
   finally show ?thesis .
 qed
 
 lemma continuous_onI_antimono:
   fixes f :: "'a::linorder_topology \<Rightarrow> 'b::{dense_order,linorder_topology}"
   assumes "open (f`A)"
     and mono: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f y \<le> f x"
   shows "continuous_on A f"
 proof (rule continuous_on_generate_topology[OF open_generated_order], safe)
   have monoD: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f y < f x \<Longrightarrow> x < y"
     by (auto simp: not_le[symmetric] mono)
   have "\<exists>x. x \<in> A \<and> f x < b \<and> x < a" if a: "a \<in> A" and fa: "f a < b" for a b
   proof -
     obtain y where "f a < y" "{f a ..< y} \<subseteq> f`A"
       using open_right[OF \<open>open (f`A)\<close>, of "f a" b] a fa
       by auto
     obtain z where z: "f a < z" "z < min b y"
       using dense[of "f a" "min b y"] \<open>f a < y\<close> \<open>f a < b\<close> by auto
     then obtain c where "z = f c" "c \<in> A"
       using \<open>{f a ..< y} \<subseteq> f`A\<close>[THEN subsetD, of z] by (auto simp: less_imp_le)
     with a z show ?thesis
       by (auto intro!: exI[of _ c] simp: monoD)
   qed
   then show "\<exists>C. open C \<and> C \<inter> A = f -` {..<b} \<inter> A" for b
     by (intro exI[of _ "(\<Union>x\<in>{x\<in>A. f x < b}. {x <..})"])
        (auto intro: le_less_trans[OF mono] less_imp_le)
 
   have "\<exists>x. x \<in> A \<and> b < f x \<and> x > a" if a: "a \<in> A" and fa: "b < f a" for a b
   proof -
     note a fa
     moreover
     obtain y where "y < f a" "{y <.. f a} \<subseteq> f`A"
       using open_left[OF \<open>open (f`A)\<close>, of "f a" b]  a fa
       by auto
     then obtain z where z: "max b y < z" "z < f a"
       using dense[of "max b y" "f a"] \<open>y < f a\<close> \<open>b < f a\<close> by auto
     then obtain c where "z = f c" "c \<in> A"
       using \<open>{y <.. f a} \<subseteq> f`A\<close>[THEN subsetD, of z] by (auto simp: less_imp_le)
     with a z show ?thesis
       by (auto intro!: exI[of _ c] simp: monoD)
   qed
   then show "\<exists>C. open C \<and> C \<inter> A = f -` {b <..} \<inter> A" for b
     by (intro exI[of _ "(\<Union>x\<in>{x\<in>A. b < f x}. {..< x})"])
        (auto intro: less_le_trans[OF _ mono] less_imp_le)
 qed
 
 lemma minus_add_eq_ereal: "\<not> ((a = \<infinity> \<and> b = -\<infinity>) \<or> (a = -\<infinity> \<and> b = \<infinity>)) \<Longrightarrow> - (a + b::ereal) = -a - b"
   by (cases a; cases b; simp)
 
 lemma setsum_negf_ereal: "\<not> {-\<infinity>, \<infinity>} \<subseteq> f`I \<Longrightarrow> (\<Sum>i\<in>I. - f i) = - (\<Sum>i\<in>I. f i::ereal)"
   by (induction I rule: infinite_finite_induct)
      (auto simp: minus_add_eq_ereal sum_Minfty sum_Pinfty,
       (subst minus_add_eq_ereal; auto simp: sum_Pinfty sum_Minfty image_iff minus_ereal_def)+)
 
 lemma convergent_minus_iff_ereal: "convergent (\<lambda>x. - f x::ereal) \<longleftrightarrow> convergent f"
   unfolding convergent_def  by (metis ereal_uminus_uminus ereal_Lim_uminus)
 
 lemma summable_minus_ereal: "\<not> {-\<infinity>, \<infinity>} \<subseteq> range f \<Longrightarrow> summable (\<lambda>n. f n) \<Longrightarrow> summable (\<lambda>n. - f n::ereal)"
   unfolding summable_iff_convergent
   by (subst setsum_negf_ereal) (auto simp: convergent_minus_iff_ereal)
 
 lemma (in product_prob_space) product_nn_integral_component:
   assumes "f \<in> borel_measurable (M i)""i \<in> I"
   shows "integral\<^sup>N (Pi\<^sub>M I M) (\<lambda>x. f (x i)) = integral\<^sup>N (M i) f"
 proof -
   from assms show ?thesis
     apply (subst PiM_component[symmetric, OF \<open>i \<in> I\<close>])
     apply (subst nn_integral_distr[OF measurable_component_singleton])
     apply simp_all
     done
 qed
 
 lemma ennreal_inverse_le[simp]: "inverse x \<le> inverse y \<longleftrightarrow> y \<le> (x::ennreal)"
   by (cases "0 < x"; cases x; cases "0 < y"; cases y; auto simp: top_unique inverse_ennreal)
 
 lemma inverse_inverse_ennreal[simp]: "inverse (inverse x::ennreal) = x"
   by (cases "0 < x"; cases x; auto simp: inverse_ennreal)
 
 lemma range_inverse_ennreal: "range inverse = (UNIV::ennreal set)"
 proof -
   have "\<exists>x. y = inverse x" for y :: ennreal
     by (intro exI[of _ "inverse y"]) simp
   then show ?thesis
     unfolding surj_def by auto
 qed
 
 lemma continuous_on_inverse_ennreal': "continuous_on (UNIV :: ennreal set) inverse"
   by (rule continuous_onI_antimono) (auto simp: range_inverse_ennreal)
 
 lemma sums_minus_ereal: "\<not> {- \<infinity>, \<infinity>} \<subseteq> f ` UNIV \<Longrightarrow> (\<lambda>n. - f n::ereal) sums x \<Longrightarrow> f sums - x"
   unfolding sums_def
   apply (subst ereal_Lim_uminus)
   apply (subst (asm) setsum_negf_ereal)
   apply auto
   done
 
 lemma suminf_minus_ereal: "\<not> {- \<infinity>, \<infinity>} \<subseteq> f ` UNIV \<Longrightarrow> summable f \<Longrightarrow> (\<Sum>n. - f n :: ereal) = - suminf f"
   apply (rule sums_unique[symmetric])
   apply (rule sums_minus_ereal)
   apply (auto simp: ereal_uminus_eq_reorder)
   done
 
 end
diff --git a/thys/Native_Word/Code_Target_Word_Base.thy b/thys/Native_Word/Code_Target_Word_Base.thy
--- a/thys/Native_Word/Code_Target_Word_Base.thy
+++ b/thys/Native_Word/Code_Target_Word_Base.thy
@@ -1,386 +1,384 @@
 (*  Title:      Code_Target_Word_Base.thy
     Author:     Andreas Lochbihler, ETH Zurich
 *)
 
 chapter \<open>Common base for target language implementations of word types\<close>
 
 theory Code_Target_Word_Base
   imports
     "HOL-Library.Word"
     "Word_Lib.Signed_Division_Word"
     "Word_Lib.More_Word"
 begin
 
 subsection \<open>More on conversions\<close>
 
 lemma int_of_integer_unsigned_eq [simp]:
   \<open>int_of_integer (unsigned w) = uint w\<close>
   by transfer simp
 
 lemma int_of_integer_signed_eq [simp]:
   \<open>int_of_integer (signed w) = sint w\<close>
   by transfer simp
 
 abbreviation word_of_integer :: \<open>integer \<Rightarrow> 'a::len word\<close>
   where \<open>word_of_integer k \<equiv> word_of_int (int_of_integer k)\<close>
 
 
 subsection \<open>Quickcheck conversion functions\<close>
 
 context
   includes state_combinator_syntax
 begin
 
 definition qc_random_cnv ::
   "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
     \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
   where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
        let n = a_of_natural k
        in (n, \<lambda>_. Code_Evaluation.term_of n)))"
 
 end
 
 definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_exhaustive_cnv a_of_natural f d =
    Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"
 
 definition qc_full_exhaustive_cnv ::
   "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
   (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"
 
 declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]
 
 definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
 where
   "qc_narrowing_drawn_from xs =
    foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"
 
 locale quickcheck_narrowing_samples =
   fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
   and zero :: "'a"
   and tr :: "typerep"
 begin
 
 function narrowing_samples :: "integer \<Rightarrow> 'a list"
 where
   "narrowing_samples i =
    (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
 by pat_completeness auto
 termination including integer.lifting
 proof(relation "measure nat_of_integer")
   fix i :: integer
   assume "0 < i"
   thus "(i - 1, i) \<in> measure nat_of_integer"
     by simp(transfer, simp)
 qed simp
 
 definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
 where
   "partial_term_of_sample i =
   (if i < 0 then undefined
    else if i = 0 then zero
    else if i mod 2 = 0 then snd (a_of_integer (i div 2))
    else fst (a_of_integer (i div 2 + 1)))"
 
 lemma partial_term_of_code:
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
     Code_Evaluation.Free (STR ''_'') tr"
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
    Code_Evaluation.term_of (partial_term_of_sample i)"
 by (rule partial_term_of_anything)+
 
 end
 
 lemmas [code] =
   quickcheck_narrowing_samples.narrowing_samples.simps
   quickcheck_narrowing_samples.partial_term_of_sample_def
 
 
 subsection \<open>More on division\<close>
 
 lemma div_half_nat:
   fixes x y :: nat
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   let ?q = "2 * (x div 2 div y)"
   have q: "?q = x div y - x div y mod 2"
     by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
   let ?r = "x - ?q * y"
   have r: "?r = x mod y + x div y mod 2 * y"
     by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)
 
   show ?thesis
   proof(cases "y \<le> x - ?q * y")
     case True
     with assms q have "x div y mod 2 \<noteq> 0" unfolding r
       by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1)) 
     hence "x div y = ?q + 1" unfolding q
       by simp
     moreover hence "x mod y = ?r - y"
       by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
     ultimately show ?thesis using True by(simp add: Let_def)
   next
     case False
     hence "x div y mod 2 = 0" unfolding r
       by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
     hence "x div y = ?q" unfolding q by simp
     moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
     ultimately show ?thesis using False by(simp add: Let_def)
   qed
 qed
 
 lemma div_half_word:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = push_bit 1 (drop_bit 1 x div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   moreover obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat y\<close>]) simp_all
   ultimately have [simp]: \<open>unat (of_nat n :: 'a word) = n\<close> \<open>unat (of_nat m :: 'a word) = m\<close>
     by (transfer, simp add: take_bit_of_nat take_bit_nat_eq_self_iff)+
   let ?q = "push_bit 1 (drop_bit 1 x div y)"
   let ?q' = "2 * (n div 2 div m)"
   have "n div 2 div m < 2 ^ LENGTH('a)"
     using n by (metis of_nat_inverse uno_simps(2) unsigned_less)
   hence q: "?q = of_nat ?q'" using n m
     by (auto simp add: drop_bit_eq_div word_arith_nat_div uno_simps take_bit_nat_eq_self unsigned_of_nat)
   from assms have "m \<noteq> 0" using m by -(rule notI, simp)
 
   from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
     by (metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unsigned_less uno_simps(2))
   moreover
   have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
     by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
   moreover have "2 * (n div 2 div m) * m \<le> n"
     by (simp flip: div_mult2_eq ac_simps)
   ultimately
   have r: "x - ?q * y = of_nat (n - ?q' * m)"
     and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
     using n m unfolding q
      apply (simp_all add: of_nat_diff)
     apply (subst of_nat_diff)
     apply (cases \<open>LENGTH('a) \<ge> 2\<close>)
      apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths unsigned_of_nat)
     done
   then show ?thesis using n m div_half_nat [OF \<open>m \<noteq> 0\<close>, of n] unfolding q
     by (simp add: word_le_nat_alt word_div_def word_mod_def Let_def take_bit_nat_eq_self unsigned_of_nat
       flip: zdiv_int zmod_int
       split del: if_split split: if_split_asm)
 qed
 
 text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>
 
 lemma [code]:
   "x sdiv y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0) \<noteq> (y' < 0);
         result = abs x' div abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
   by (simp add: sdiv_word_def signed_divide_int_def sgn_if Let_def not_less not_le)
 
 lemma [code]:
   "x smod y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0);
         result = abs x' mod abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
 proof -
   have *: \<open>k mod l = k - k div l * l\<close> for k l :: int
     by (simp add: minus_div_mult_eq_mod)
   show ?thesis
     by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if Let_def)
 qed
 
 text \<open>
   This algorithm implements unsigned division in terms of signed division.
   Taken from Hacker's Delight.
 \<close>
 
 lemma divmod_via_sdivmod:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows
   "(x div y, x mod y) =
   (if push_bit (LENGTH('a) - 1) 1 \<le> y then if x < y then (0, x) else (1, x - y)
    else let q = (push_bit 1 (drop_bit 1 x sdiv y));
             r = x - q * y
         in if r \<ge> y then (q + 1, r - y) else (q, r))"
-proof(cases "push_bit (LENGTH('a) - 1) 1 \<le> y")
+proof (cases "push_bit (LENGTH('a) - 1) 1 \<le> y")
   case True
   note y = this
   show ?thesis
-  proof(cases "x < y")
+  proof (cases "x < y")
     case True
-    then have "x mod y = x"
-      by transfer simp
-    then show ?thesis using True y
-      using bits_mod_div_trivial [of x y] by simp
+    with y show ?thesis
+      by (simp add: word_div_less mod_word_less)
   next
     case False
     obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)"
       by (rule that [of \<open>unat y\<close>]) simp_all
     have "unat x < 2 ^ LENGTH('a)" by (rule unsigned_less)
     also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
       by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
     also have "\<dots> \<le> 2 * n" using y n
       by transfer (simp add: take_bit_eq_mod)
     finally have div: "x div of_nat n = 1" using False n
       by (simp add: take_bit_nat_eq_self unsigned_of_nat word_div_eq_1_iff)
     moreover have "x mod y = x - x div y * y"
       by (simp add: minus_div_mult_eq_mod)
     with div n have "x mod y = x - y" by simp
     ultimately show ?thesis using False y n by simp
   qed
 next
   case False
   note y = this
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
     by (cases \<open>LENGTH('a)\<close>)
       (auto dest: less_imp_of_nat_less [where ?'a = int])
   with y n have "sint (drop_bit 1 x) = uint (drop_bit 1 x)"
     by (cases \<open>LENGTH('a)\<close>)
       (auto simp add: sint_uint drop_bit_eq_div take_bit_nat_eq_self uint_div_distrib
         signed_take_bit_int_eq_self_iff unsigned_of_nat)
   moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
     using y by (cases \<open>LENGTH('a)\<close>)
       (simp_all add: not_le word_less_alt uint_power_lower)
   then have "sint y = uint y"
     apply (cases \<open>LENGTH('a)\<close>)
      apply (auto simp add: sint_uint signed_take_bit_int_eq_self_iff)
     using uint_ge_0 [of y]
     by linarith 
   ultimately show ?thesis using y
     apply (subst div_half_word [OF assms])
     apply (simp add: sdiv_word_def signed_divide_int_def flip: uint_div)
     done
 qed
 
 
 subsection \<open>More on misc operations\<close>
 
 context
   includes bit_operations_syntax
 begin
 
 lemma word_of_int_code:
   "uint (word_of_int x :: 'a word) = x AND mask (LENGTH('a :: len))"
   by (simp add: unsigned_of_int take_bit_eq_mask)
 
 lemma word_and_mask_or_conv_and_mask:
   "bit n index \<Longrightarrow> (n AND mask index) OR (push_bit index 1) = n AND mask (index + 1)"
   for n :: \<open>'a::len word\<close>
   by (rule bit_eqI) (auto simp add: bit_simps)
 
 lemma uint_and_mask_or_full:
   fixes n :: "'a :: len word"
   assumes "bit n (LENGTH('a) - 1)"
   and "mask1 = mask (LENGTH('a) - 1)"
   and "mask2 = push_bit (LENGTH('a) - 1) 1"
   shows "uint (n AND mask1) OR mask2 = uint n"
 proof -
   have "mask2 = uint (push_bit (LENGTH('a) - 1) 1 :: 'a word)" using assms
     by transfer (simp add: take_bit_push_bit)
   hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (push_bit (LENGTH('a) - 1) 1 :: 'a word))"
     by(simp add: uint_or)
   also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
     using assms by(simp only: word_and_mask_or_conv_and_mask)
   also have "\<dots> = uint n" by simp
   finally show ?thesis .
 qed
 
 lemma word_of_int_via_signed:
   fixes mask
   assumes mask_def: "mask = Bit_Operations.mask LENGTH('a)"
   and shift_def: "shift = push_bit LENGTH('a) 1"
   and index_def: "index = LENGTH('a) - 1"
   and overflow_def:"overflow = push_bit (LENGTH('a) - 1) 1"
   and least_def: "least = - overflow"
   shows
   "(word_of_int i :: 'a :: len word) =
    (let i' = i AND mask
     in if bit i' index then
          if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
        else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
 proof -
   define i' where "i' = i AND mask"
   have "shift = mask + 1" unfolding assms
     by (simp add: mask_eq_exp_minus_1) 
   hence "i' < shift"
     by (simp add: mask_def i'_def)
   show ?thesis
   proof(cases "bit i' index")
     case True
     then have unf: "i' = overflow OR i'"
       apply (simp add: assms i'_def flip: take_bit_eq_mask)
       apply (rule bit_eqI)
       apply (auto simp add: bit_take_bit_iff bit_or_iff bit_exp_iff)
       done
     have \<open>overflow \<le> overflow OR i'\<close>
       by (simp add: i'_def mask_def or_greater_eq)
     then have "overflow \<le> i'"
       by (subst unf)
     hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
       by(cases "LENGTH('a)")(simp_all add: not_less)
     moreover
     have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
       by(cases "LENGTH('a)")(auto simp add: not_le elim: less_le_trans)
     moreover
     have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
       by (simp add: i'_def shift_def mask_def word_of_int_eq_iff flip: take_bit_eq_mask)
     ultimately show ?thesis using True by(simp add: Let_def i'_def)
   next
     case False
     have "i' = i AND Bit_Operations.mask (LENGTH('a) - 1)"
       apply (rule bit_eqI)
       apply (use False in \<open>auto simp add: bit_simps assms i'_def\<close>)
       apply (auto simp add: less_le)
       done
     also have "\<dots> \<le> Bit_Operations.mask (LENGTH('a) - 1)"
       using AND_upper2 mask_nonnegative_int by blast
     also have "\<dots> < overflow"
       by (simp add: mask_int_def overflow_def)
     also
     have "least \<le> 0" unfolding least_def overflow_def by simp
     have "0 \<le> i'" by (simp add: i'_def mask_def)
     hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
     moreover
     have "word_of_int i' = (word_of_int i :: 'a word)"
       by (simp add: i'_def mask_def of_int_and_eq of_int_mask_eq)
     ultimately show ?thesis using False by(simp add: Let_def i'_def)
   qed
 qed
 
 end
 
 
 subsection \<open>Code generator setup\<close>
 
 text \<open>
   The separate code target \<open>SML_word\<close> collects setups for the
   code generator that PolyML does not provide.
 \<close>
 
 setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>
 
 code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
   (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word
 
 
 text \<open>Misc\<close>
 
 lemmas word_sdiv_def = sdiv_word_def
 lemmas word_smod_def = smod_word_def
 
 end
diff --git a/thys/Native_Word/Word_Type_Copies.thy b/thys/Native_Word/Word_Type_Copies.thy
--- a/thys/Native_Word/Word_Type_Copies.thy
+++ b/thys/Native_Word/Word_Type_Copies.thy
@@ -1,332 +1,332 @@
 (*  Title:      Word_Type_Copies.thy
     Author:     Florian Haftmann, TU Muenchen
 *)
 
 chapter \<open>Systematic approach towards type copies of word type\<close>
 
 theory Word_Type_Copies
   imports
     "HOL-Library.Word"
     "Word_Lib.Most_significant_bit"
     "Word_Lib.Least_significant_bit"
     "Word_Lib.Generic_set_bit"
     "Word_Lib.Bit_Comprehension"
     "Code_Target_Word_Base"
 begin
 
 text \<open>The lifting machinery is not localized, hence the abstract proofs are carried out using morphisms.\<close>
 
 locale word_type_copy =
   fixes of_word :: \<open>'b::len word \<Rightarrow> 'a\<close>
     and word_of :: \<open>'a \<Rightarrow> 'b word\<close>
   assumes type_definition: \<open>type_definition word_of of_word UNIV\<close>
 begin
 
 lemma word_of_word:
   \<open>word_of (of_word w) = w\<close>
   using type_definition by (simp add: type_definition_def)
 
 lemma of_word_of [code abstype]:
   \<open>of_word (word_of p) = p\<close>
     \<comment> \<open>Use an abstract type for code generation to disable pattern matching on \<^term>\<open>of_word\<close>.\<close>
   using type_definition by (simp add: type_definition_def)
 
 lemma word_of_eqI:
   \<open>p = q\<close> if \<open>word_of p = word_of q\<close>
 proof -
   from that have \<open>of_word (word_of p) = of_word (word_of q)\<close>
     by simp
   then show ?thesis
     by (simp add: of_word_of)
 qed
 
 lemma eq_iff_word_of:
   \<open>p = q \<longleftrightarrow> word_of p = word_of q\<close>
   by (auto intro: word_of_eqI)
 
 end
 
 bundle constraintless
 begin
 
 declaration \<open>
   let
     val cs = map (rpair NONE o fst o dest_Const)
       [\<^term>\<open>0\<close>, \<^term>\<open>(+)\<close>, \<^term>\<open>uminus\<close>, \<^term>\<open>(-)\<close>,
        \<^term>\<open>1\<close>, \<^term>\<open>(*)\<close>, \<^term>\<open>(div)\<close>, \<^term>\<open>(mod)\<close>,
        \<^term>\<open>HOL.equal\<close>, \<^term>\<open>(\<le>)\<close>, \<^term>\<open>(<)\<close>,
        \<^term>\<open>(dvd)\<close>, \<^term>\<open>of_bool\<close>, \<^term>\<open>numeral\<close>, \<^term>\<open>of_nat\<close>,
        \<^term>\<open>bit\<close>,
        \<^term>\<open>Bit_Operations.not\<close>, \<^term>\<open>Bit_Operations.and\<close>, \<^term>\<open>Bit_Operations.or\<close>, \<^term>\<open>Bit_Operations.xor\<close>, \<^term>\<open>mask\<close>,
        \<^term>\<open>push_bit\<close>, \<^term>\<open>drop_bit\<close>, \<^term>\<open>take_bit\<close>,
        \<^term>\<open>Bit_Operations.set_bit\<close>, \<^term>\<open>unset_bit\<close>, \<^term>\<open>flip_bit\<close>,
        \<^term>\<open>msb\<close>, \<^term>\<open>lsb\<close>, \<^term>\<open>size\<close>, \<^term>\<open>Generic_set_bit.set_bit\<close>, \<^term>\<open>set_bits\<close>]
   in
     K (Context.mapping I (fold Proof_Context.add_const_constraint cs))
   end
 \<close>
 
 end
 
 locale word_type_copy_ring = word_type_copy
   opening constraintless +
   constrains word_of :: \<open>'a \<Rightarrow> 'b::len word\<close>
   assumes word_of_0 [code]: \<open>word_of 0 = 0\<close>
     and word_of_1 [code]: \<open>word_of 1 = 1\<close>
     and word_of_add [code]: \<open>word_of (p + q) = word_of p + word_of q\<close>
     and word_of_minus [code]: \<open>word_of (- p) = - (word_of p)\<close>
     and word_of_diff [code]: \<open>word_of (p - q) = word_of p - word_of q\<close>
     and word_of_mult [code]: \<open>word_of (p * q) = word_of p * word_of q\<close>
     and word_of_div [code]: \<open>word_of (p div q) = word_of p div word_of q\<close>
     and word_of_mod [code]: \<open>word_of (p mod q) = word_of p mod word_of q\<close>
     and equal_iff_word_of [code]: \<open>HOL.equal p q \<longleftrightarrow> HOL.equal (word_of p) (word_of q)\<close>
     and less_eq_iff_word_of [code]: \<open>p \<le> q \<longleftrightarrow> word_of p \<le> word_of q\<close>
     and less_iff_word_of [code]: \<open>p < q \<longleftrightarrow> word_of p < word_of q\<close>
 begin
 
 lemma of_class_comm_ring_1:
   \<open>OFCLASS('a, comm_ring_1_class)\<close>
   by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
     word_of_add word_of_minus word_of_diff word_of_mult algebra_simps)
 
 lemma of_class_semiring_modulo:
   \<open>OFCLASS('a, semiring_modulo_class)\<close>
   by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
     word_of_add word_of_minus word_of_diff word_of_mult word_of_mod word_of_div algebra_simps
     mod_mult_div_eq)
 
 lemma of_class_equal:
   \<open>OFCLASS('a, equal_class)\<close>
   by standard (simp add: eq_iff_word_of equal_iff_word_of equal)
 
 lemma of_class_linorder:
   \<open>OFCLASS('a, linorder_class)\<close>
   by standard (auto simp add: eq_iff_word_of less_eq_iff_word_of less_iff_word_of)
 
 end
 
 locale word_type_copy_bits = word_type_copy_ring
   opening constraintless bit_operations_syntax +
   constrains word_of :: \<open>'a::{comm_ring_1, semiring_modulo, equal, linorder} \<Rightarrow> 'b::len word\<close>
   fixes signed_drop_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
   assumes bit_eq_word_of [code]: \<open>bit p = bit (word_of p)\<close>
     and word_of_not [code]: \<open>word_of (NOT p) = NOT (word_of p)\<close>
     and word_of_and [code]: \<open>word_of (p AND q) = word_of p AND word_of q\<close>
     and word_of_or [code]: \<open>word_of (p OR q) = word_of p OR word_of q\<close>
     and word_of_xor [code]: \<open>word_of (p XOR q) = word_of p XOR word_of q\<close>
     and word_of_mask [code]: \<open>word_of (mask n) = mask n\<close>
     and word_of_push_bit [code]: \<open>word_of (push_bit n p) = push_bit n (word_of p)\<close>
     and word_of_drop_bit [code]: \<open>word_of (drop_bit n p) = drop_bit n (word_of p)\<close>
     and word_of_signed_drop_bit [code]: \<open>word_of (signed_drop_bit n p) = Word.signed_drop_bit n (word_of p)\<close>
     and word_of_take_bit [code]: \<open>word_of (take_bit n p) = take_bit n (word_of p)\<close>
     and word_of_set_bit [code]: \<open>word_of (Bit_Operations.set_bit n p) = Bit_Operations.set_bit n (word_of p)\<close>
     and word_of_unset_bit [code]: \<open>word_of (unset_bit n p) = unset_bit n (word_of p)\<close>
     and word_of_flip_bit [code]: \<open>word_of (flip_bit n p) = flip_bit n (word_of p)\<close>
 begin
 
 lemma word_of_bool:
   \<open>word_of (of_bool n) = of_bool n\<close>
   by (simp add: word_of_0 word_of_1)
 
 lemma word_of_nat:
   \<open>word_of (of_nat n) = of_nat n\<close>
   by (induction n) (simp_all add: word_of_0 word_of_1 word_of_add)
 
 lemma word_of_numeral [simp]:
   \<open>word_of (numeral n) = numeral n\<close>
 proof -
   have \<open>word_of (of_nat (numeral n)) = of_nat (numeral n)\<close>
     by (simp only: word_of_nat)
   then show ?thesis by simp
 qed
 
 lemma word_of_power:
   \<open>word_of (p ^ n) = word_of p ^ n\<close>
   by (induction n) (simp_all add: word_of_1 word_of_mult)
 
 lemma even_iff_word_of:
   \<open>2 dvd p \<longleftrightarrow> 2 dvd word_of p\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then obtain q where \<open>p = 2 * q\<close> ..
   then show ?Q by (simp add: word_of_mult)
 next
   assume ?Q
   then obtain w where \<open>word_of p = 2 * w\<close> ..
   then have \<open>of_word (word_of p) = of_word (2 * w)\<close>
     by simp
   then have \<open>p = 2 * of_word w\<close>
     by (simp add: eq_iff_word_of word_of_word word_of_mult)
   then show ?P
     by simp
 qed
 
 lemma of_class_ring_bit_operations:
   \<open>OFCLASS('a, ring_bit_operations_class)\<close>
 proof -
   have induct: \<open>P p\<close> if stable: \<open>(\<And>p. p div 2 = p \<Longrightarrow> P p)\<close>
       and rec: \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * p) div 2 = p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
     for p :: 'a and P
   proof -
     from stable have stable': \<open>(\<And>p. word_of p div 2 = word_of p \<Longrightarrow> P p)\<close>
       by (simp add: eq_iff_word_of word_of_div)
     from rec have rec': \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * word_of p) div 2 = word_of p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
       by (simp add: eq_iff_word_of word_of_add word_of_bool word_of_mult word_of_div)
     define w where \<open>w = word_of p\<close>
     then have \<open>p = of_word w\<close>
       by (simp add: of_word_of)
     also have \<open>P (of_word w)\<close>
-    proof (induction w rule: bits_induct)
+    proof (induction w rule: bit_induct)
       case (stable w)
       show ?case
         by (rule stable') (simp add: word_of_word stable)
     next
       case (rec w b)
       have \<open>P (of_bool b + 2 * of_word w)\<close>
         by (rule rec') (simp_all add: word_of_word rec)
       also have \<open>of_bool b + 2 * of_word w = of_word (of_bool b + 2 * w)\<close>
         by (simp add: eq_iff_word_of word_of_word word_of_add word_of_1 word_of_mult word_of_0)
       finally show ?case .
     qed
     finally show \<open>P p\<close> .
   qed
   have \<open>class.semiring_parity_axioms (+) (0::'a) (*) 1 (mod)\<close>
     by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1 even_iff_word_of word_of_mod even_iff_mod_2_eq_zero)
   with of_class_semiring_modulo have \<open>OFCLASS('a, semiring_parity_class)\<close>
     by (rule semiring_parity_class.intro) 
   moreover have \<open>class.semiring_bits_axioms (+) (-) (0::'a) (*) 1 (div) (mod) bit\<close>
     apply (standard, fact induct)
     apply (simp_all only: eq_iff_word_of word_of_0 word_of_1 word_of_bool word_of_numeral
       word_of_add word_of_diff word_of_mult word_of_div word_of_mod word_of_power even_iff_word_of
       bit_eq_word_of push_bit_take_bit drop_bit_take_bit
       even_drop_bit_iff_not_bit
       flip: push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod mask_eq_exp_minus_1)
                apply (auto simp add: ac_simps bit_simps drop_bit_exp_eq)
     done
   ultimately have \<open>OFCLASS('a, semiring_bits_class)\<close>
     by (rule semiring_bits_class.intro)
   moreover have \<open>class.semiring_bit_operations_axioms (+) (-) (0::'a) (*) (1::'a) (div) (mod) (AND) (OR) (XOR) mask Bit_Operations.set_bit unset_bit flip_bit push_bit drop_bit take_bit\<close>
     apply standard
     apply (simp_all add: eq_iff_word_of word_of_add word_of_push_bit word_of_power
       bit_eq_word_of word_of_and word_of_or word_of_xor word_of_mask word_of_diff
       word_of_0 word_of_1 bit_simps
-      word_of_set_bit set_bit_eq_or word_of_unset_bit unset_bit_Suc word_of_flip_bit flip_bit_eq_xor
+      word_of_set_bit set_bit_eq_or word_of_unset_bit unset_bit_eq_or_xor word_of_flip_bit flip_bit_eq_xor
       word_of_mult
       word_of_drop_bit word_of_div word_of_take_bit word_of_mod
       and_rec [of \<open>word_of a\<close> \<open>word_of b\<close> for a b]
       or_rec [of \<open>word_of a\<close> \<open>word_of b\<close> for a b]
       xor_rec [of \<open>word_of a\<close> \<open>word_of b\<close> for a b] even_iff_word_of
       flip: mask_eq_exp_minus_1 push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)
     done
   ultimately have \<open>OFCLASS('a, semiring_bit_operations_class)\<close>
     by (rule semiring_bit_operations_class.intro)
   moreover have \<open>OFCLASS('a, ring_parity_class)\<close>
     using \<open>OFCLASS('a, semiring_parity_class)\<close> by (rule ring_parity_class.intro) standard
   moreover have \<open>class.ring_bit_operations_axioms (-) (1::'a) uminus NOT\<close>
     by standard
       (simp add: eq_iff_word_of word_of_not word_of_diff word_of_minus word_of_1 not_eq_complement)
   ultimately show \<open>OFCLASS('a, ring_bit_operations_class)\<close>
     by (rule ring_bit_operations_class.intro)
 qed
 
 lemma [code]:
   \<open>take_bit n a = a AND mask n\<close> for a :: 'a
   by (simp add: eq_iff_word_of word_of_take_bit word_of_and word_of_mask take_bit_eq_mask)
 
 lemma [code]:
   \<open>mask (Suc n) = push_bit n (1 :: 'a) OR mask n\<close>
   \<open>mask 0 = (0 :: 'a)\<close>
   by (simp_all add: eq_iff_word_of word_of_mask word_of_or word_of_push_bit word_of_0 word_of_1 mask_Suc_exp)
 
 lemma [code]:
   \<open>Bit_Operations.set_bit n w = w OR push_bit n 1\<close> for w :: 'a
   by (simp add: eq_iff_word_of word_of_set_bit word_of_or word_of_push_bit word_of_1 set_bit_eq_or)
 
 lemma [code]:
   \<open>unset_bit n w = w AND NOT (push_bit n 1)\<close> for w :: 'a
   by (simp add: eq_iff_word_of word_of_unset_bit word_of_and word_of_not word_of_push_bit word_of_1 unset_bit_eq_and_not)
 
 lemma [code]:
   \<open>flip_bit n w = w XOR push_bit n 1\<close> for w :: 'a
   by (simp add: eq_iff_word_of word_of_flip_bit word_of_xor word_of_push_bit word_of_1 flip_bit_eq_xor)
 
 end
 
 locale word_type_copy_more = word_type_copy_bits +
   constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
   fixes of_nat :: \<open>nat \<Rightarrow> 'a\<close> and nat_of :: \<open>'a \<Rightarrow> nat\<close>
     and of_int :: \<open>int \<Rightarrow> 'a\<close> and int_of :: \<open>'a \<Rightarrow> int\<close>
     and of_integer :: \<open>integer \<Rightarrow> 'a\<close> and integer_of :: \<open>'a \<Rightarrow> integer\<close>
   assumes word_of_nat_eq: \<open>word_of (of_nat n) = word_of_nat n\<close>
     and nat_of_eq_word_of: \<open>nat_of p = unat (word_of p)\<close>
     and word_of_int_eq: \<open>word_of (of_int k) = word_of_int k\<close>
     and int_of_eq_word_of: \<open>int_of p = uint (word_of p)\<close>
     and word_of_integer_eq: \<open>word_of (of_integer l) = word_of_integer l\<close>
     and integer_of_eq_word_of: \<open>integer_of p = unsigned (word_of p)\<close>
 begin
 
 lemma of_word_numeral [code_post]:
   \<open>of_word (numeral n) = numeral n\<close>
   by (simp add: eq_iff_word_of word_of_word)
 
 lemma of_word_0 [code_post]:
   \<open>of_word 0 = 0\<close>
   by (simp add: eq_iff_word_of word_of_0 word_of_word)
 
 lemma of_word_1 [code_post]:
   \<open>of_word 1 = 1\<close>
   by (simp add: eq_iff_word_of word_of_1 word_of_word)
 
 text \<open>Use pretty numerals from integer for pretty printing\<close>
 
 lemma numeral_eq_integer [code_unfold]:
   \<open>numeral n = of_integer (numeral n)\<close>
   by (simp add: eq_iff_word_of word_of_integer_eq)
 
 lemma neg_numeral_eq_integer [code_unfold]:
   \<open>- numeral n = of_integer (- numeral n)\<close>
   by (simp add: eq_iff_word_of word_of_integer_eq word_of_minus)
 
 end
 
 locale word_type_copy_misc = word_type_copy_more
   opening constraintless bit_operations_syntax +
   constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
   fixes size :: nat and set_bits_aux :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
     assumes size_eq_length: \<open>size = LENGTH('b::len)\<close>
     and msb_iff_word_of [code]: \<open>msb p \<longleftrightarrow> msb (word_of p)\<close>
     and lsb_iff_word_of [code]: \<open>lsb p \<longleftrightarrow> lsb (word_of p)\<close>
     and size_eq_word_of: \<open>Nat.size (p :: 'a) = Nat.size (word_of p)\<close>
     and word_of_generic_set_bit [code]: \<open>word_of (Generic_set_bit.set_bit p n b) = Generic_set_bit.set_bit (word_of p) n b\<close>
     and word_of_set_bits: \<open>word_of (set_bits P) = set_bits P\<close>
     and word_of_set_bits_aux: \<open>word_of (set_bits_aux P n p) = Bit_Comprehension.set_bits_aux P n (word_of p)\<close>
 begin
 
 lemma size_eq [code]:
   \<open>Nat.size p = size\<close> for p :: 'a
   by (simp add: size_eq_length size_eq_word_of word_size)
 
 lemma set_bits_aux_code [code]:
   \<open>set_bits_aux f n w =
   (if n = 0 then w 
    else let n' = n - 1 in set_bits_aux f n' (push_bit 1 w OR (if f n' then 1 else 0)))\<close>
   by (simp add: eq_iff_word_of word_of_set_bits_aux Let_def word_of_mult word_of_or word_of_0 word_of_1 set_bits_aux_rec [of f n])
 
 lemma set_bits_code [code]: \<open>set_bits P = set_bits_aux P size 0\<close>
   by (simp add: fun_eq_iff eq_iff_word_of word_of_set_bits word_of_set_bits_aux word_of_0 size_eq_length set_bits_conv_set_bits_aux)
 
 lemma of_class_lsb:
   \<open>OFCLASS('a, lsb_class)\<close>
   by standard (simp add: fun_eq_iff lsb_iff_word_of even_iff_word_of lsb_odd)
 
 lemma of_class_set_bit:
   \<open>OFCLASS('a, set_bit_class)\<close>
   by standard (simp add: eq_iff_word_of word_of_generic_set_bit bit_eq_word_of word_of_power word_of_0 bit_simps linorder_not_le)
 
 lemma of_class_bit_comprehension:
   \<open>OFCLASS('a, bit_comprehension_class)\<close>
   by standard (simp add: eq_iff_word_of word_of_set_bits bit_eq_word_of set_bits_bit_eq)
 
 end
 
 end
diff --git a/thys/Optics/Scene_Spaces.thy b/thys/Optics/Scene_Spaces.thy
--- a/thys/Optics/Scene_Spaces.thy
+++ b/thys/Optics/Scene_Spaces.thy
@@ -1,841 +1,832 @@
 section \<open> Scene Spaces \<close>
 
 theory Scene_Spaces            
   imports Scenes
 begin
 
 subsection \<open> Preliminaries \<close>
 
 abbreviation foldr_scene :: "'a scene list \<Rightarrow> 'a scene" ("\<Squnion>\<^sub>S") where
 "foldr_scene as \<equiv> foldr (\<squnion>\<^sub>S) as \<bottom>\<^sub>S"
 
 lemma pairwise_indep_then_compat [simp]: "pairwise (\<bowtie>\<^sub>S) A \<Longrightarrow> pairwise (##\<^sub>S) A"
   by (simp add: pairwise_alt)
 
 lemma pairwise_compat_foldr: 
   "\<lbrakk> pairwise (##\<^sub>S) (set as); \<forall> b \<in> set as. a ##\<^sub>S b \<rbrakk> \<Longrightarrow> a ##\<^sub>S \<Squnion>\<^sub>S as"
   apply (induct as)
    apply (simp)
   apply (auto simp add: pairwise_insert scene_union_pres_compat)
   done
 
 lemma foldr_scene_indep:
   "\<lbrakk> pairwise (##\<^sub>S) (set as); \<forall> b \<in> set as. a \<bowtie>\<^sub>S b \<rbrakk> \<Longrightarrow> a \<bowtie>\<^sub>S \<Squnion>\<^sub>S as"
   apply (induct as)
    apply (simp)
   apply (auto intro: scene_indep_pres_compat simp add: pairwise_insert )
   done
 
 lemma foldr_compat_dist:
   "pairwise (##\<^sub>S) (set as) \<Longrightarrow> foldr (\<squnion>\<^sub>S) (map (\<lambda>a. a ;\<^sub>S x) as) \<bottom>\<^sub>S = \<Squnion>\<^sub>S as ;\<^sub>S x"
   apply (induct as)
    apply (simp)
   apply (auto simp add: pairwise_insert)
   apply (metis pairwise_compat_foldr scene_compat_refl scene_union_comp_distl)
   done  
 
 lemma foldr_compat_quotient_dist:
   "\<lbrakk> pairwise (##\<^sub>S) (set as); \<forall> a\<in>set as. a \<le> \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> foldr (\<squnion>\<^sub>S) (map (\<lambda>a. a /\<^sub>S x) as) \<bottom>\<^sub>S = \<Squnion>\<^sub>S as /\<^sub>S x"
   apply (induct as)
    apply (auto simp add: pairwise_insert)
   apply (subst scene_union_quotient)
      apply simp_all
   using pairwise_compat_foldr scene_compat_refl apply blast
   apply (meson foldr_scene_indep scene_indep_sym scene_le_iff_indep_inv)
   done
 
 lemma foldr_scene_union_add_tail:
   "\<lbrakk> pairwise (##\<^sub>S) (set xs); \<forall> x\<in>set xs. x ##\<^sub>S b \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S xs \<squnion>\<^sub>S b = foldr (\<squnion>\<^sub>S) xs b"
   apply (induct xs)
    apply (simp)
   apply (simp)
   apply (subst scene_union_assoc[THEN sym])
      apply (auto simp add: pairwise_insert)
   using pairwise_compat_foldr scene_compat_refl apply blast
   apply (meson pairwise_compat_foldr scene_compat_sym)
   done
 
 lemma pairwise_Diff: "pairwise R A \<Longrightarrow> pairwise R (A - B)"
   using pairwise_mono by fastforce
 
 lemma scene_compats_members: "\<lbrakk> pairwise (##\<^sub>S) A; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x ##\<^sub>S y"
   by (metis pairwise_def scene_compat_refl)
 
 corollary foldr_scene_union_removeAll:
   assumes "pairwise (##\<^sub>S) (set xs)" "x \<in> set xs"
   shows "\<Squnion>\<^sub>S (removeAll x xs) \<squnion>\<^sub>S x = \<Squnion>\<^sub>S xs"
 using assms proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   have x_compat: "\<And> z. z \<in> set xs \<Longrightarrow> x ##\<^sub>S z"
     using Cons.prems(1) Cons.prems(2) scene_compats_members by auto
 
   from Cons have x_compats: "x ##\<^sub>S \<Squnion>\<^sub>S (removeAll x xs)"
     by (metis (no_types, lifting) insert_Diff list.simps(15) pairwise_compat_foldr pairwise_insert removeAll_id set_removeAll x_compat)
 
   from Cons have a_compats: "a ##\<^sub>S \<Squnion>\<^sub>S (removeAll x xs)"
     by (metis (no_types, lifting) insert_Diff insert_iff list.simps(15) pairwise_compat_foldr pairwise_insert scene_compat_refl set_removeAll x_compats)
 
   from Cons show ?case 
   proof (cases "x \<in> set xs")
     case True
     with Cons show ?thesis
       by (auto simp add: pairwise_insert scene_union_commute)
          (metis a_compats scene_compats_members scene_union_assoc scene_union_idem,
           metis (full_types) a_compats scene_union_assoc scene_union_commute x_compats)
   next
     case False
     with Cons show ?thesis
       by (simp add: scene_union_commute)
   qed
 qed
 
 lemma foldr_scene_union_eq_sets:
   assumes "pairwise (##\<^sub>S) (set xs)" "set xs = set ys"
   shows "\<Squnion>\<^sub>S xs = \<Squnion>\<^sub>S ys"
 using assms proof (induct xs arbitrary: ys)
   case Nil
   then show ?case
     by simp
 next
   case (Cons a xs)
   hence ys: "set ys = insert a (set (removeAll a ys))"
     by (auto)
   then show ?case
     by (metis (no_types, lifting) Cons.hyps Cons.prems(1) Cons.prems(2) Diff_insert_absorb foldr_scene_union_removeAll insertCI insert_absorb list.simps(15) pairwise_insert set_removeAll)
 qed
 
 lemma foldr_scene_removeAll:
   assumes "pairwise (##\<^sub>S) (set xs)"
   shows "x \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x xs) = x \<squnion>\<^sub>S \<Squnion>\<^sub>S xs"
   by (metis (mono_tags, opaque_lifting) assms foldr_Cons foldr_scene_union_eq_sets insertCI insert_Diff list.simps(15) o_apply removeAll.simps(2) removeAll_id set_removeAll)
 
 lemma pairwise_Collect: "pairwise R A \<Longrightarrow> pairwise R {x \<in> A. P x}"
   by (simp add: pairwise_def)
 
 lemma removeAll_overshadow_filter: 
   "removeAll x (filter (\<lambda>xa. xa \<notin> A - {x}) xs) = removeAll x (filter (\<lambda> xa. xa \<notin> A) xs)"
   apply (simp add: removeAll_filter_not_eq)
   apply (rule filter_cong)
    apply (simp)
   apply auto
   done
 
 corollary foldr_scene_union_filter:
   assumes "pairwise (##\<^sub>S) (set xs)" "set ys \<subseteq> set xs"
   shows "\<Squnion>\<^sub>S xs = \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set ys) xs) \<squnion>\<^sub>S \<Squnion>\<^sub>S ys"
 using assms proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by (simp)
 next
   case (Cons x xs)
   show ?case
   proof (cases "x \<in> set ys")
     case True
     with Cons have 1: "set ys - {x} \<subseteq> set xs"
       by (auto)
     have 2: "x ##\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (metis Cons.prems(1) Cons.prems(2) True foldr_scene_removeAll foldr_scene_union_removeAll pairwise_subset scene_compat_bot(2) scene_compat_sym scene_union_incompat scene_union_unit(1))
     have 3: "\<And> P. x ##\<^sub>S \<Squnion>\<^sub>S (filter P xs)"
       by (meson Cons.prems(1) Cons.prems(2) True filter_is_subset in_mono pairwise_compat_foldr pairwise_subset scene_compats_members set_subset_Cons)    
     have 4: "\<And> P. \<Squnion>\<^sub>S (filter P xs) ##\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (rule pairwise_compat_foldr)
          (metis Cons.prems(1) Cons.prems(2) pairwise_Diff pairwise_subset set_removeAll,
           metis (no_types, lifting) "1" Cons.prems(1) filter_is_subset pairwise_compat_foldr pairwise_subset scene_compat_sym scene_compats_members set_removeAll set_subset_Cons subsetD)
     have "\<Squnion>\<^sub>S (x # xs) = x \<squnion>\<^sub>S \<Squnion>\<^sub>S xs"
       by simp
     also have "... = x \<squnion>\<^sub>S (\<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys - {x}) xs) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys))"
       using 1 Cons(1)[where ys="removeAll x ys"] Cons(2) by (simp add: pairwise_insert)    
     also have "... = (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys - {x}) xs)) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (simp add: scene_union_assoc 1 2 3 4)
     also have "... = (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x (filter (\<lambda>xa. xa \<notin> set ys - {x}) xs))) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (metis (no_types, lifting) Cons.prems(1) filter_is_subset foldr_scene_removeAll pairwise_subset set_subset_Cons)
     also have "... = (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x (filter (\<lambda>xa. xa \<notin> set ys) xs))) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (simp only: removeAll_overshadow_filter)
     also have "... = (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x (filter (\<lambda>xa. xa \<notin> set ys) (x # xs)))) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by simp
     also have "... = (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys) (x # xs))) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (simp add: True)
     also have "... = (\<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys) (x # xs)) \<squnion>\<^sub>S x) \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys)"
       by (simp add: scene_union_commute)
     also have "... = \<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys) (x # xs)) \<squnion>\<^sub>S (x \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll x ys))"
       by (simp add: scene_union_assoc True 2 3 4 scene_compat_sym)
     also have "... = \<Squnion>\<^sub>S (filter (\<lambda>xa. xa \<notin> set ys) (x # xs)) \<squnion>\<^sub>S \<Squnion>\<^sub>S ys"
       by (metis (no_types, lifting) Cons.prems(1) Cons.prems(2) True foldr_scene_union_removeAll pairwise_subset scene_union_commute)
     finally show ?thesis .
   next
     case False
     with Cons(2-3) have 1: "set ys \<subseteq> set xs"
       by auto
     have 2: "x ##\<^sub>S \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set ys) xs)"
       by (metis (no_types, lifting) Cons.prems(1) filter_is_subset filter_set list.simps(15) member_filter pairwise_compat_foldr pairwise_insert pairwise_subset scene_compat_refl)
     have 3: "x ##\<^sub>S \<Squnion>\<^sub>S ys"
       by (meson Cons.prems(1) Cons.prems(2) list.set_intros(1) pairwise_compat_foldr pairwise_subset scene_compats_members subset_code(1))
     from Cons(1)[of ys] Cons(2-3) have 4: "\<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set ys) xs) ##\<^sub>S \<Squnion>\<^sub>S ys"
       by (auto simp add: pairwise_insert)
          (metis (no_types, lifting) "1" foldr_append foldr_scene_union_eq_sets scene_compat_bot(1) scene_union_incompat set_append subset_Un_eq)
 
     with 1 False Cons(1)[of ys] Cons(2-3) show ?thesis
       by (auto simp add: pairwise_insert scene_union_assoc 2 3 4)
   qed
 qed
 
 lemma foldr_scene_append:
   "\<lbrakk> pairwise (##\<^sub>S) (set (xs @ ys)) \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S (xs @ ys) = \<Squnion>\<^sub>S xs \<squnion>\<^sub>S \<Squnion>\<^sub>S ys"
   by (simp add: foldr_scene_union_add_tail pairwise_compat_foldr pairwise_subset scene_compats_members)
 
 lemma foldr_scene_concat:
   "\<lbrakk> pairwise (##\<^sub>S) (set (concat xs)) \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S (concat xs) = \<Squnion>\<^sub>S (map \<Squnion>\<^sub>S xs)"
   by (induct xs, simp_all, metis foldr_append foldr_scene_append pairwise_subset set_append set_concat sup_ge2)
 
 subsection \<open> Predicates \<close>
 
 text \<open> All scenes in the set are independent \<close>
 
 definition scene_indeps :: "'s scene set \<Rightarrow> bool" where
 "scene_indeps = pairwise (\<bowtie>\<^sub>S)"
 
 text \<open> All scenes in the set cover the entire state space \<close>
 
 definition scene_span :: "'s scene list \<Rightarrow> bool" where
 "scene_span S = (foldr (\<squnion>\<^sub>S) S \<bottom>\<^sub>S = \<top>\<^sub>S)"
 
 text \<open> cf. @{term finite_dimensional_vector_space}, which scene spaces are based on. \<close>  
 
 subsection \<open> Scene space class \<close>
 
 class scene_space =
   fixes Vars :: "'a scene list"
   assumes idem_scene_Vars [simp]: "\<And> x. x \<in> set Vars \<Longrightarrow> idem_scene x"
   and indep_Vars: "scene_indeps (set Vars)"
   and span_Vars: "scene_span Vars"
 begin
 
 lemma scene_space_compats [simp]: "pairwise (##\<^sub>S) (set Vars)"
   by (metis local.indep_Vars pairwise_alt scene_indep_compat scene_indeps_def)
 
 lemma Vars_ext_lens_indep: "\<lbrakk> a ;\<^sub>S x \<noteq> b ;\<^sub>S x; a \<in> set Vars; b \<in> set Vars \<rbrakk> \<Longrightarrow> a ;\<^sub>S x \<bowtie>\<^sub>S b ;\<^sub>S x"
   by (metis indep_Vars pairwiseD scene_comp_indep scene_indeps_def)
 
 inductive_set scene_space :: "'a scene set" where
 bot_scene_space [intro]: "\<bottom>\<^sub>S \<in> scene_space" | 
 Vars_scene_space [intro]: "x \<in> set Vars \<Longrightarrow> x \<in> scene_space" |
 union_scene_space [intro]: "\<lbrakk> x \<in> scene_space; y \<in> scene_space \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>S y \<in> scene_space"
 
 lemma idem_scene_space: "a \<in> scene_space \<Longrightarrow> idem_scene a"
   by (induct rule: scene_space.induct) auto
 
 lemma set_Vars_scene_space [simp]: "set Vars \<subseteq> scene_space"
   by blast
 
 lemma pairwise_compat_Vars_subset: "set xs \<subseteq> set Vars \<Longrightarrow> pairwise (##\<^sub>S) (set xs)"
   using pairwise_subset scene_space_compats by blast
 
 lemma scene_space_foldr: "set xs \<subseteq> scene_space \<Longrightarrow> \<Squnion>\<^sub>S xs \<in> scene_space"
   by (induction xs, auto)
 
 lemma top_scene_eq: "\<top>\<^sub>S = \<Squnion>\<^sub>S Vars"
   using local.span_Vars scene_span_def by force
 
 lemma top_scene_space: "\<top>\<^sub>S \<in> scene_space"
 proof -
   have "\<top>\<^sub>S = foldr (\<squnion>\<^sub>S) Vars \<bottom>\<^sub>S"
     using span_Vars by (simp add: scene_span_def)
   also have "... \<in> scene_space"
     by (simp add: scene_space_foldr)
   finally show ?thesis .
 qed
 
 lemma Vars_compat_scene_space: "\<lbrakk> b \<in> scene_space; x \<in> set Vars \<rbrakk> \<Longrightarrow> x ##\<^sub>S b"
 proof (induct b rule: scene_space.induct)
   case bot_scene_space
   then show ?case
     by (metis scene_compat_refl scene_union_incompat scene_union_unit(1)) 
 next
   case (Vars_scene_space a)
   then show ?case
     by (metis local.indep_Vars pairwiseD scene_compat_refl scene_indep_compat scene_indeps_def)
 next
   case (union_scene_space a b)
   then show ?case
     using scene_union_pres_compat by blast
 qed
 
 lemma scene_space_compat: "\<lbrakk> a \<in> scene_space; b \<in> scene_space \<rbrakk> \<Longrightarrow> a ##\<^sub>S b"
 proof (induct rule: scene_space.induct)
   case bot_scene_space
   then show ?case
     by simp
 next
   case (Vars_scene_space x)
   then show ?case
     by (simp add: Vars_compat_scene_space) 
 next
   case (union_scene_space x y)
   then show ?case
     using scene_compat_sym scene_union_pres_compat by blast
 qed
 
 corollary scene_space_union_assoc:
   assumes "x \<in> scene_space" "y \<in> scene_space" "z \<in> scene_space"
   shows "x \<squnion>\<^sub>S (y \<squnion>\<^sub>S z) = (x \<squnion>\<^sub>S y) \<squnion>\<^sub>S z"
   by (simp add: assms scene_space_compat scene_union_assoc)
 
 lemma scene_space_vars_decomp: "a \<in> scene_space \<Longrightarrow> \<exists>xs. set xs \<subseteq> set Vars \<and> foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S = a"
 proof (induct rule: scene_space.induct)
   case bot_scene_space
   then show ?case
     by (simp add: exI[where x="[]"])
 next
   case (Vars_scene_space x)
   show ?case
     apply (rule exI[where x="[x]"])
     using Vars_scene_space by simp
 next
   case (union_scene_space x y)
   then obtain xs ys where xsys: "set xs \<subseteq> set Vars \<and> foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S = x"
                                 "set ys \<subseteq> set Vars \<and> foldr (\<squnion>\<^sub>S) ys \<bottom>\<^sub>S = y"
     by blast+
   show ?case
   proof (rule exI[where x="xs @ ys"])
     show "set (xs @ ys) \<subseteq> set Vars \<and> \<Squnion>\<^sub>S (xs @ ys) = x \<squnion>\<^sub>S y"
       by (auto simp: xsys)
          (metis (full_types) Vars_compat_scene_space foldr_scene_union_add_tail pairwise_subset 
            scene_space_compats subsetD union_scene_space.hyps(3) xsys(1))
   qed
 qed
 
 lemma scene_space_vars_decomp_iff: "a \<in> scene_space \<longleftrightarrow> (\<exists>xs. set xs \<subseteq> set Vars \<and> a = foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S)"
   apply (auto simp add: scene_space_vars_decomp scene_space.Vars_scene_space scene_space_foldr)
    apply (simp add: scene_space.Vars_scene_space scene_space_foldr subset_eq)
   using scene_space_vars_decomp apply auto[1]
   by (meson dual_order.trans scene_space_foldr set_Vars_scene_space)
 
 lemma "fold (\<squnion>\<^sub>S) (map (\<lambda>x. x ;\<^sub>S a) Vars) b = \<lbrakk>a\<rbrakk>\<^sub>\<sim> \<squnion>\<^sub>S b"
   oops
 
 lemma Vars_indep_foldr: 
   assumes "x \<in> set Vars" "set xs \<subseteq> set Vars"
   shows "x \<bowtie>\<^sub>S \<Squnion>\<^sub>S (removeAll x xs)"
 proof (rule foldr_scene_indep)
   show "pairwise (##\<^sub>S) (set (removeAll x xs))"
     by (simp, metis Diff_subset assms(2) pairwise_mono scene_space_compats)
   from assms show "\<forall>b\<in>set (removeAll x xs). x \<bowtie>\<^sub>S b"
     by (simp)
        (metis DiffE insertI1 local.indep_Vars pairwiseD scene_indeps_def subset_iff)
 qed
 
 lemma Vars_indeps_foldr:
   assumes "set xs \<subseteq> set Vars"
   shows "foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S \<bowtie>\<^sub>S foldr (\<squnion>\<^sub>S) (filter (\<lambda>x. x \<notin> set xs) Vars) \<bottom>\<^sub>S"
   apply (rule foldr_scene_indep)
    apply (meson filter_is_subset pairwise_subset scene_space_compats)
   apply (simp)
   apply auto
   apply (rule scene_indep_sym)
   apply (metis (no_types, lifting) assms foldr_scene_indep local.indep_Vars pairwiseD pairwise_mono scene_indeps_def scene_space_compats subset_iff)
   done
 
 lemma uminus_var_other_vars:
   assumes "x \<in> set Vars"
   shows "- x = foldr (\<squnion>\<^sub>S) (removeAll x Vars) \<bottom>\<^sub>S"
 proof (rule scene_union_indep_uniq[where Z="x"])
     show "idem_scene (foldr (\<squnion>\<^sub>S) (removeAll x Vars) \<bottom>\<^sub>S)"
       by (metis Diff_subset idem_scene_space order_trans scene_space_foldr set_Vars_scene_space set_removeAll)
     show "idem_scene x" "idem_scene (-x)"
       by (simp_all add: assms local.idem_scene_Vars)
     show "foldr (\<squnion>\<^sub>S) (removeAll x Vars) \<bottom>\<^sub>S \<bowtie>\<^sub>S x"
       using Vars_indep_foldr assms scene_indep_sym by blast
     show "- x \<bowtie>\<^sub>S x"
       using scene_indep_self_compl scene_indep_sym by blast
     show "- x \<squnion>\<^sub>S x = foldr (\<squnion>\<^sub>S) (removeAll x Vars) \<bottom>\<^sub>S \<squnion>\<^sub>S x"
       by (metis \<open>idem_scene (- x)\<close> assms foldr_scene_union_removeAll local.span_Vars scene_space_compats scene_span_def scene_union_compl uminus_scene_twice)
 qed
 
 lemma uminus_vars_other_vars:
   assumes "set xs \<subseteq> set Vars"
   shows "- \<Squnion>\<^sub>S xs = \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set xs) Vars)"
 proof (rule scene_union_indep_uniq[where Z="foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S"])
   show "idem_scene (- foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S)" "idem_scene (foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S)"
     using assms idem_scene_space idem_scene_uminus scene_space_vars_decomp_iff by blast+
   show "idem_scene (foldr (\<squnion>\<^sub>S) (filter (\<lambda>x. x \<notin> set xs) Vars) \<bottom>\<^sub>S)"
     by (meson filter_is_subset idem_scene_space scene_space_vars_decomp_iff)
   show "- foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S \<bowtie>\<^sub>S foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S"
     by (metis scene_indep_self_compl uminus_scene_twice)
   show "foldr (\<squnion>\<^sub>S) (filter (\<lambda>x. x \<notin> set xs) Vars) \<bottom>\<^sub>S \<bowtie>\<^sub>S foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S"
     using Vars_indeps_foldr assms scene_indep_sym by blast
   show "- \<Squnion>\<^sub>S xs \<squnion>\<^sub>S \<Squnion>\<^sub>S xs = \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set xs) Vars) \<squnion>\<^sub>S \<Squnion>\<^sub>S xs"
     using foldr_scene_union_filter[of Vars xs, THEN sym]
     by (simp add: assms)
        (metis \<open>idem_scene (- \<Squnion>\<^sub>S xs)\<close> local.span_Vars scene_span_def scene_union_compl uminus_scene_twice)
 qed
 
 lemma scene_space_uminus: "\<lbrakk> a \<in> scene_space \<rbrakk> \<Longrightarrow> - a \<in> scene_space"
   by (auto simp add: scene_space_vars_decomp_iff uminus_vars_other_vars)
      (metis filter_is_subset)
 
 lemma scene_space_inter: "\<lbrakk> a \<in> scene_space; b \<in> scene_space \<rbrakk> \<Longrightarrow> a \<sqinter>\<^sub>S b \<in> scene_space"
   by (simp add: inf_scene_def scene_space.union_scene_space scene_space_uminus)
 
 lemma scene_union_foldr_remove_element:
   assumes "set xs \<subseteq> set Vars"
   shows "a \<squnion>\<^sub>S \<Squnion>\<^sub>S xs = a \<squnion>\<^sub>S \<Squnion>\<^sub>S (removeAll a xs)"
   using assms proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case apply auto
      apply (metis order_trans scene_space.Vars_scene_space scene_space_foldr scene_space_union_assoc scene_union_idem set_Vars_scene_space)
     apply (smt (verit, best) Diff_subset dual_order.trans removeAll_id scene_space_foldr scene_space_union_assoc scene_union_commute set_Vars_scene_space set_removeAll subset_iff)
     done
 qed
 
 lemma scene_union_foldr_Cons_removeAll:
   assumes "set xs \<subseteq> set Vars" "a \<in> set xs"
   shows "foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S = foldr (\<squnion>\<^sub>S) (a # removeAll a xs) \<bottom>\<^sub>S"
   by (metis assms(1) assms(2) foldr_scene_union_eq_sets insert_Diff list.simps(15) pairwise_subset scene_space_compats set_removeAll)
 
 lemma scene_union_foldr_Cons_removeAll':
   assumes "set xs \<subseteq> set Vars" "a \<in> set Vars"
   shows "foldr (\<squnion>\<^sub>S) (a # xs) \<bottom>\<^sub>S = foldr (\<squnion>\<^sub>S) (a # removeAll a xs) \<bottom>\<^sub>S"
   by (simp add: assms(1) scene_union_foldr_remove_element)
 
 lemma scene_in_foldr: "\<lbrakk> a \<in> set xs; set xs \<subseteq> set Vars \<rbrakk> \<Longrightarrow> a \<subseteq>\<^sub>S \<Squnion>\<^sub>S xs"
   apply (induct xs)
    apply (simp)
   apply (subst scene_union_foldr_Cons_removeAll')
     apply simp
    apply simp
   apply (auto)
   apply (rule scene_union_ub)
     apply (metis Diff_subset dual_order.trans idem_scene_space scene_space_vars_decomp_iff set_removeAll)
   using Vars_indep_foldr apply blast
   apply (metis Vars_indep_foldr foldr_scene_union_removeAll idem_scene_space local.idem_scene_Vars order.trans pairwise_mono removeAll_id scene_indep_sym scene_space_compats scene_space_foldr scene_union_commute scene_union_ub set_Vars_scene_space subscene_trans)
   done
 
 lemma scene_union_foldr_subset:
   assumes "set xs \<subseteq> set ys" "set ys \<subseteq> set Vars"
   shows "\<Squnion>\<^sub>S xs \<subseteq>\<^sub>S \<Squnion>\<^sub>S ys"
   using assms proof (induct xs arbitrary: ys)
   case Nil
   then show ?case 
     by (simp add: scene_bot_least)
 next
   case (Cons a xs)
   { assume "a \<in> set xs"
     with Cons have "foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S = foldr (\<squnion>\<^sub>S) (a # removeAll a xs) \<bottom>\<^sub>S"
       apply (subst scene_union_foldr_Cons_removeAll)
         apply (auto)
       done
   } note a_in = this
   { assume "a \<notin> set xs"
     then have "a \<squnion>\<^sub>S foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S = foldr (\<squnion>\<^sub>S) (a # xs) \<bottom>\<^sub>S"
       by simp
   } note a_out = this
   show ?case apply (simp)
     apply (cases "a \<in> set xs")
     using a_in Cons apply auto
      apply (metis dual_order.trans scene_union_foldr_remove_element)
     using a_out Cons apply auto
     apply (rule scene_union_mono)
     using scene_in_foldr apply blast
        apply blast
       apply (meson Vars_compat_scene_space dual_order.trans scene_space_foldr set_Vars_scene_space subsetD)
     using local.idem_scene_Vars apply blast
     apply (meson idem_scene_space scene_space_foldr set_Vars_scene_space subset_trans)
     done
 qed
 
 lemma union_scene_space_foldrs:
   assumes "set xs \<subseteq> set Vars" "set ys \<subseteq> set Vars"
   shows "(foldr (\<squnion>\<^sub>S) xs \<bottom>\<^sub>S) \<squnion>\<^sub>S (foldr (\<squnion>\<^sub>S) ys \<bottom>\<^sub>S) = foldr (\<squnion>\<^sub>S) (xs @ ys) \<bottom>\<^sub>S"
   using assms
   apply (induct ys)
    apply (simp_all)
   apply (metis Vars_compat_scene_space foldr_scene_union_add_tail local.indep_Vars pairwise_mono scene_indep_compat scene_indeps_def scene_space.Vars_scene_space scene_space.union_scene_space scene_space_foldr subset_eq)
   done
 
 lemma scene_space_ub:
   assumes "a \<in> scene_space" "b \<in> scene_space"
   shows "a \<subseteq>\<^sub>S a \<squnion>\<^sub>S b"
   using assms
   apply (auto simp add: scene_space_vars_decomp_iff union_scene_space_foldrs)
   by (smt (verit, ccfv_SIG) foldr_append scene_union_foldr_subset set_append sup.bounded_iff sup_commute sup_ge2)
 
 lemma scene_compl_subset_iff:
   assumes "a \<in> scene_space" "b \<in> scene_space"
   shows "- a \<subseteq>\<^sub>S -b \<longleftrightarrow> b \<subseteq>\<^sub>S a"
   by (metis scene_indep_sym scene_le_iff_indep_inv uminus_scene_twice)
 
 lemma inter_scene_space_foldrs:
   assumes "set xs \<subseteq> set Vars" "set ys \<subseteq> set Vars"
   shows "\<Squnion>\<^sub>S xs \<sqinter>\<^sub>S \<Squnion>\<^sub>S ys = \<Squnion>\<^sub>S (filter (\<lambda> x. x \<in> set xs \<inter> set ys) Vars)"
 proof -
   have "\<Squnion>\<^sub>S xs \<sqinter>\<^sub>S \<Squnion>\<^sub>S ys = - (- \<Squnion>\<^sub>S xs \<squnion>\<^sub>S - \<Squnion>\<^sub>S ys)"
     by (simp add: inf_scene_def)
   also have "... = - (\<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set xs) Vars) \<squnion>\<^sub>S \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set ys) Vars))"
     by (simp add: uminus_vars_other_vars assms)
   also have "... = - \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set xs) Vars @ filter (\<lambda>x. x \<notin> set ys) Vars)"
     by (simp add: union_scene_space_foldrs assms)
   also have "... =  \<Squnion>\<^sub>S (filter (\<lambda>x. x \<notin> set (filter (\<lambda>x. x \<notin> set xs) Vars @ filter (\<lambda>x. x \<notin> set ys) Vars)) Vars)"
     by (subst uminus_vars_other_vars, simp_all)
   also have "... = \<Squnion>\<^sub>S (filter (\<lambda> x. x \<in> set xs \<inter> set ys) Vars)"
   proof -
     have "\<And>x. x \<in> set Vars \<Longrightarrow> ((x \<in> set Vars \<longrightarrow> x \<in> set xs) \<and> (x \<in> set Vars \<longrightarrow> x \<in> set ys)) = (x \<in> set xs \<and> x \<in> set ys)"
       by auto
     thus ?thesis
       by (simp cong: arg_cong[where f="\<Squnion>\<^sub>S"] filter_cong add: assms)
   qed
   finally show ?thesis .
 qed
 
 lemma scene_inter_distrib_lemma:
   assumes "set xs \<subseteq> set Vars" "set ys \<subseteq> set Vars" "set zs \<subseteq> set Vars"
   shows "\<Squnion>\<^sub>S xs \<squnion>\<^sub>S (\<Squnion>\<^sub>S ys \<sqinter>\<^sub>S \<Squnion>\<^sub>S zs) = (\<Squnion>\<^sub>S xs \<squnion>\<^sub>S \<Squnion>\<^sub>S ys) \<sqinter>\<^sub>S (\<Squnion>\<^sub>S xs \<squnion>\<^sub>S \<Squnion>\<^sub>S zs)"
   using assms
   apply (simp only: union_scene_space_foldrs inter_scene_space_foldrs)
   apply (subst union_scene_space_foldrs)
     apply (simp add: assms)
    apply (simp add: assms)
   apply (subst inter_scene_space_foldrs)
     apply (simp)
    apply (simp)
   apply (rule foldr_scene_union_eq_sets)
   apply (simp)
    apply (smt (verit, ccfv_threshold) Un_subset_iff mem_Collect_eq pairwise_subset scene_space_compats subset_iff)
   apply (auto)
   done
 
 lemma scene_union_inter_distrib:
   assumes "a \<in> scene_space" "b \<in> scene_space" "c \<in> scene_space"
   shows "a \<squnion>\<^sub>S b \<sqinter>\<^sub>S c = (a \<squnion>\<^sub>S b) \<sqinter>\<^sub>S (a \<squnion>\<^sub>S c)"
   using assms
   by (auto simp add: scene_space_vars_decomp_iff scene_inter_distrib_lemma)
 
 lemma finite_distinct_lists_subset:
   assumes "finite A"
   shows "finite {xs. distinct xs \<and> set xs \<subseteq> A}"
-proof -
-  from assms have 1: "{xs. distinct xs \<and> set xs \<subseteq> A} = {xs. distinct xs \<and> length xs \<le> card A \<and> set xs \<subseteq> A}"
-    by (auto, metis card_mono distinct_card)
-  have 2: "... \<subseteq> {xs. set xs \<subseteq> A \<and> length xs \<le> card A}"
-    by auto
-  have 3: "finite ..."
-    using assms finite_lists_length_le by blast
-  show ?thesis
-    by (metis (mono_tags, lifting) "1" "2" "3" infinite_super)
-qed
+  by (metis (no_types, lifting) Collect_cong finite_subset_distinct[OF assms])
 
 lemma foldr_scene_union_remdups: "set xs \<subseteq> set Vars \<Longrightarrow> \<Squnion>\<^sub>S (remdups xs) = \<Squnion>\<^sub>S xs"
   by (auto intro: foldr_scene_union_eq_sets simp add: pairwise_compat_Vars_subset)
 
 lemma scene_space_as_lists:
   "scene_space = {\<Squnion>\<^sub>S xs | xs. distinct xs \<and> set xs \<subseteq> set Vars}"
 proof (rule Set.set_eqI, rule iffI)
   fix a
   assume "a \<in> scene_space"
   then obtain xs where xs: "set xs \<subseteq> set Vars" "\<Squnion>\<^sub>S xs = a"
     using scene_space_vars_decomp_iff by auto
   thus "a \<in> {\<Squnion>\<^sub>S xs |xs. distinct xs \<and> set xs \<subseteq> set Vars}"
     by auto (metis distinct_remdups foldr_scene_union_remdups set_remdups)
 next
   fix a
   assume "a \<in> {\<Squnion>\<^sub>S xs |xs. distinct xs \<and> set xs \<subseteq> set Vars}"
   thus "a \<in> scene_space"
     using scene_space_vars_decomp_iff by auto
 qed
 
 lemma finite_scene_space: "finite scene_space"
 proof -
   have "scene_space = {\<Squnion>\<^sub>S xs | xs. distinct xs \<and> set xs \<subseteq> set Vars}"
     by (simp add: scene_space_as_lists)
   also have "... = \<Squnion>\<^sub>S ` {xs. distinct xs \<and> set xs \<subseteq> set Vars}"
     by auto
   also have "finite ..."
     by (rule finite_imageI, simp add: finite_distinct_lists_subset)
   finally show ?thesis .
 qed 
 
 lemma scene_space_inter_assoc:
   assumes "x \<in> scene_space" "y \<in> scene_space" "z \<in> scene_space"
   shows "(x \<sqinter>\<^sub>S y) \<sqinter>\<^sub>S z = x \<sqinter>\<^sub>S (y \<sqinter>\<^sub>S z)"
 proof -
   have "(x \<sqinter>\<^sub>S y) \<sqinter>\<^sub>S z = - (- x \<squnion>\<^sub>S - y \<squnion>\<^sub>S - z)"
     by (simp add: scene_demorgan1 uminus_scene_twice)
   also have "... = - (- x \<squnion>\<^sub>S (- y \<squnion>\<^sub>S - z))"
     by (simp add: assms scene_space_uminus scene_space_union_assoc)
   also have "... = x \<sqinter>\<^sub>S (y \<sqinter>\<^sub>S z)"
     by (simp add: scene_demorgan1 uminus_scene_twice)
   finally show ?thesis .
 qed
 
 lemma scene_inter_union_distrib:
   assumes "x \<in> scene_space" "y \<in> scene_space" "z \<in> scene_space"
   shows "x \<sqinter>\<^sub>S (y \<squnion>\<^sub>S z) = (x \<sqinter>\<^sub>S y) \<squnion>\<^sub>S (x \<sqinter>\<^sub>S z)"
 proof-
   have "x \<sqinter>\<^sub>S (y \<squnion>\<^sub>S z) = (x \<sqinter>\<^sub>S (x \<squnion>\<^sub>S z)) \<sqinter>\<^sub>S (y \<squnion>\<^sub>S z)"
     by (metis assms(1) assms(3) idem_scene_space local.scene_union_inter_distrib scene_indep_bot scene_inter_commute scene_inter_indep scene_space.simps scene_union_unit(1))
   also have "... = (y \<squnion>\<^sub>S z) \<sqinter>\<^sub>S (x \<sqinter>\<^sub>S (x \<squnion>\<^sub>S z))"
     by (simp add: scene_union_inter_distrib assms scene_inter_commute scene_union_assoc union_scene_space scene_space_inter scene_union_commute)  
   also have "\<dots> = x \<sqinter>\<^sub>S ((y \<squnion>\<^sub>S z) \<sqinter>\<^sub>S (x \<squnion>\<^sub>S z))"
     by (metis assms scene_inter_commute scene_space.union_scene_space scene_space_inter_assoc)
   also have "\<dots> = x \<sqinter>\<^sub>S (z \<squnion>\<^sub>S (x \<sqinter>\<^sub>S y))"
     by (simp add: assms scene_union_inter_distrib scene_inter_commute scene_union_commute)
     
   also have "\<dots> = ((x \<sqinter>\<^sub>S y) \<squnion>\<^sub>S x) \<sqinter>\<^sub>S ((x \<sqinter>\<^sub>S y) \<squnion>\<^sub>S z)"
     by (metis (no_types, opaque_lifting) assms(1) assms(2) idem_scene_space local.scene_union_inter_distrib scene_indep_bot scene_inter_commute scene_inter_indep scene_space.bot_scene_space scene_union_commute scene_union_idem scene_union_unit(1))
   also have "\<dots> = (x \<sqinter>\<^sub>S y) \<squnion>\<^sub>S (x \<sqinter>\<^sub>S z)"
     by (simp add: assms scene_union_inter_distrib scene_space_inter)
   finally show ?thesis .
 qed
 
 lemma scene_union_inter_minus:
   assumes "a \<in> scene_space" "b \<in> scene_space"
   shows "a \<squnion>\<^sub>S (b \<sqinter>\<^sub>S - a) = a \<squnion>\<^sub>S b"
   by (metis assms(1) assms(2) bot_idem_scene idem_scene_space idem_scene_uminus local.scene_union_inter_distrib scene_demorgan1 scene_space_uminus scene_union_compl scene_union_unit(1) uminus_scene_twice)
 
 lemma scene_union_foldr_minus_element:
   assumes "a \<in> scene_space" "set xs \<subseteq> scene_space"
   shows "a \<squnion>\<^sub>S \<Squnion>\<^sub>S xs = a \<squnion>\<^sub>S \<Squnion>\<^sub>S (map (\<lambda> x. x \<sqinter>\<^sub>S - a) xs)"
 using assms proof (induct xs)
   case Nil
   then show ?case by (simp)
 next
   case (Cons y ys)
   have "a \<squnion>\<^sub>S (y \<squnion>\<^sub>S \<Squnion>\<^sub>S ys) = y \<squnion>\<^sub>S (a \<squnion>\<^sub>S \<Squnion>\<^sub>S ys)"
     by (metis Cons.prems(2) assms(1) insert_subset list.simps(15) scene_space_foldr scene_space_union_assoc scene_union_commute)
   also have "... = y \<squnion>\<^sub>S (a \<squnion>\<^sub>S \<Squnion>\<^sub>S (map (\<lambda>x. x \<sqinter>\<^sub>S - a) ys))"
     using Cons.hyps Cons.prems(2) assms(1) by auto
   also have "... = y \<squnion>\<^sub>S a \<squnion>\<^sub>S \<Squnion>\<^sub>S (map (\<lambda>x. x \<sqinter>\<^sub>S - a) ys)"
     apply (subst scene_union_assoc)
     using Cons.prems(2) assms(1) scene_space_compat apply auto[1]
       apply (rule pairwise_compat_foldr)
        apply (simp)
        apply (rule pairwise_imageI)
     apply (meson Cons.prems(2) assms(1) scene_space_compat scene_space_inter scene_space_uminus set_subset_Cons subsetD)
     apply simp
     apply (meson Cons.prems(2) assms(1) in_mono list.set_intros(1) scene_space_compat scene_space_inter scene_space_uminus set_subset_Cons)
      apply (rule pairwise_compat_foldr)
     apply (simp)
        apply (rule pairwise_imageI)
     apply (meson Cons.prems(2) assms(1) in_mono scene_space_compat scene_space_inter scene_space_uminus set_subset_Cons)
     apply (simp)
      apply (meson Cons.prems(2) assms(1) in_mono scene_space_compat scene_space_inter scene_space_uminus set_subset_Cons)
     apply simp
     done
   also have "... = a \<squnion>\<^sub>S (y \<sqinter>\<^sub>S - a \<squnion>\<^sub>S \<Squnion>\<^sub>S (map (\<lambda>x. x \<sqinter>\<^sub>S - a) ys))"
     apply (subst scene_union_assoc)
     using Cons.prems(2) assms(1) scene_space_compat scene_space_inter scene_space_uminus apply force
       apply (metis (no_types, lifting) Cons.hyps Cons.prems(2) assms(1) insert_subset list.simps(15) scene_compat_sym scene_space_compat scene_space_foldr scene_union_assoc scene_union_idem scene_union_incompat scene_union_unit(1))
     apply (rule scene_space_compat)
     using Cons.prems(2) assms(1) scene_space_inter scene_space_uminus apply auto[1]
      apply (rule scene_space_foldr)
     apply auto
     apply (meson Cons.prems(2) assms(1) in_mono scene_space_inter scene_space_uminus set_subset_Cons)
     apply (metis Cons.prems(2) assms(1) insert_subset list.simps(15) scene_union_inter_minus scene_union_commute)
     done
   finally show ?case using Cons
     by auto
 qed
 
 lemma scene_space_in_foldr: "\<lbrakk> a \<in> set xs; set xs \<subseteq> scene_space \<rbrakk> \<Longrightarrow> a \<subseteq>\<^sub>S \<Squnion>\<^sub>S xs"
 proof (induct xs)
   case Nil
   then show ?case
     by simp
 next
   case (Cons y ys)
   have ysp: "y \<squnion>\<^sub>S \<Squnion>\<^sub>S ys = y \<squnion>\<^sub>S \<Squnion>\<^sub>S (map (\<lambda> x. x \<sqinter>\<^sub>S - y) ys)"
     using Cons.prems(2) scene_union_foldr_minus_element by force
   show ?case
   proof (cases "a \<subseteq>\<^sub>S y")
     case False
     with Cons show ?thesis
       by (simp)
          (metis (no_types, lifting) idem_scene_space scene_space_foldr scene_space_ub scene_union_commute subscene_trans)
   next
     case True
     with Cons show ?thesis
       by (simp)
          (meson idem_scene_space scene_space_foldr scene_space_ub subscene_trans)
   qed
 qed
 
 lemma scene_space_foldr_lb: 
   "\<lbrakk> a \<in> scene_space; set xs \<subseteq> scene_space; \<forall> b\<in>set xs. b \<le> a \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S xs \<subseteq>\<^sub>S a"
 proof (induct xs arbitrary: a)
   case Nil
   then show ?case
     by (simp add: scene_bot_least)
 next
   case (Cons x xs)
   then show ?case
     by (simp add: scene_space_compat scene_space_foldr scene_union_lb)
 qed
 
 lemma var_le_union_choice:
   "\<lbrakk> x \<in> set Vars; a \<in> scene_space; b \<in> scene_space; x \<le> a \<squnion>\<^sub>S b \<rbrakk> \<Longrightarrow> (x \<le> a \<or> x \<le> b)"
   by (auto simp add: scene_space_vars_decomp_iff)
      (metis Vars_indep_foldr bot_idem_scene idem_scene_space removeAll_id scene_bot_least scene_indep_pres_compat scene_le_iff_indep_inv scene_space.union_scene_space scene_space_foldr scene_space_in_foldr scene_union_compl set_Vars_scene_space subscene_trans subset_trans uminus_scene_twice uminus_top_scene)
 
 lemma var_le_union_iff:
   "\<lbrakk> x \<in> set Vars; a \<in> scene_space; b \<in> scene_space \<rbrakk> \<Longrightarrow> x \<le> a \<squnion>\<^sub>S b \<longleftrightarrow> (x \<le> a \<or> x \<le> b)"
   apply (rule iffI, simp add: var_le_union_choice)
   apply (auto)
    apply (meson idem_scene_space scene_space_ub subscene_trans)
   apply (metis idem_scene_space scene_space_ub scene_union_commute subscene_trans)
   done
 
 text \<open> @{term Vars} may contain the empty scene, as we want to allow vacuous lenses in alphabets \<close>
 
 lemma le_vars_then_equal: "\<lbrakk> x \<in> set Vars; y \<in> set Vars; x \<le> y; x \<noteq> \<bottom>\<^sub>S \<rbrakk> \<Longrightarrow> x = y"
   by (metis bot_idem_scene foldr_scene_removeAll local.idem_scene_Vars local.indep_Vars local.span_Vars pairwiseD scene_bot_least scene_indep_pres_compat scene_indeps_def scene_le_iff_indep_inv scene_space_compats scene_span_def scene_union_annhil subscene_antisym uminus_scene_twice uminus_top_scene uminus_var_other_vars)
 
 end
 
 lemma foldr_scene_union_eq_scene_space: 
   "\<lbrakk> set xs \<subseteq> scene_space; set xs = set ys \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S xs = \<Squnion>\<^sub>S ys"
   by (metis foldr_scene_union_eq_sets pairwise_def pairwise_subset scene_space_compat)
 
 subsection \<open> Mapping a lens over a scene list \<close>
 
 definition map_lcomp :: "'b scene list \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> 'a scene list" where
 "map_lcomp ss a = map (\<lambda> x. x ;\<^sub>S a) ss"
 
 lemma map_lcomp_dist: 
   "\<lbrakk> pairwise (##\<^sub>S) (set xs); vwb_lens a \<rbrakk> \<Longrightarrow> \<Squnion>\<^sub>S (map_lcomp xs a) = \<Squnion>\<^sub>S xs ;\<^sub>S a"
   by (simp add: foldr_compat_dist map_lcomp_def)
 
 lemma map_lcomp_Vars_is_lens [simp]: "vwb_lens a \<Longrightarrow> \<Squnion>\<^sub>S (map_lcomp Vars a) = \<lbrakk>a\<rbrakk>\<^sub>\<sim>"
   by (metis map_lcomp_dist scene_comp_top_scene scene_space_compats top_scene_eq)
 
 lemma set_map_lcomp [simp]: "set (map_lcomp xs a) = (\<lambda>x. x ;\<^sub>S a) ` set xs"
   by (simp add: map_lcomp_def)
 
 subsection \<open> Instances \<close>
 
 instantiation unit :: scene_space
 begin
 
 definition Vars_unit :: "unit scene list" where [simp]: "Vars_unit = []"
 
 instance
   by (intro_classes, simp_all add: scene_indeps_def scene_span_def unit_scene_top_eq_bot)
 
 end
 
 instantiation prod :: (scene_space, scene_space) scene_space
 begin
 
 definition Vars_prod :: "('a \<times> 'b) scene list" where "Vars_prod = map_lcomp Vars fst\<^sub>L @ map_lcomp Vars snd\<^sub>L"
 
 instance proof
   have pw: "pairwise (\<bowtie>\<^sub>S) (set (map_lcomp Vars fst\<^sub>L @ map_lcomp Vars snd\<^sub>L))"
     by (auto simp add: pairwise_def Vars_ext_lens_indep scene_comp_pres_indep scene_indep_sym)
   show "\<And>x:: ('a \<times> 'b) scene. x \<in> set Vars \<Longrightarrow> idem_scene x"
     by (auto simp add: Vars_prod_def)
   from pw show "scene_indeps (set (Vars :: ('a \<times> 'b) scene list))"
     by (simp add: Vars_prod_def scene_indeps_def)
   show "scene_span (Vars :: ('a \<times> 'b) scene list)"
     by (simp only: scene_span_def Vars_prod_def foldr_scene_append pw pairwise_indep_then_compat map_lcomp_Vars_is_lens fst_vwb_lens snd_vwb_lens)
        (metis fst_vwb_lens lens_plus_scene lens_scene_top_iff_bij_lens plus_mwb_lens scene_union_commute snd_fst_lens_indep snd_vwb_lens swap_bij_lens vwb_lens_mwb)
 qed  
 
 end
 
 subsection \<open> Scene space and basis lenses \<close>
 
 locale var_lens = vwb_lens +
   assumes lens_in_scene_space: "\<lbrakk>x\<rbrakk>\<^sub>\<sim> \<in> scene_space"
 
 declare var_lens.lens_in_scene_space [simp]
 declare var_lens.axioms(1) [simp]
 
 locale basis_lens = vwb_lens +
   assumes lens_in_basis: "\<lbrakk>x\<rbrakk>\<^sub>\<sim> \<in> set Vars"
 
 sublocale basis_lens \<subseteq> var_lens
   using lens_in_basis var_lens_axioms_def var_lens_def vwb_lens_axioms by blast
 
 declare basis_lens.lens_in_basis [simp]
 
 text \<open> Effectual variable and basis lenses need to have at least two view elements \<close>
 
 abbreviation (input) evar_lens :: "('a::two \<Longrightarrow> 's::scene_space) \<Rightarrow> bool" 
   where "evar_lens \<equiv> var_lens"
 
 abbreviation (input) ebasis_lens :: "('a::two \<Longrightarrow> 's::scene_space) \<Rightarrow> bool" 
   where "ebasis_lens \<equiv> basis_lens"
 
 lemma basis_then_var [simp]: "basis_lens x \<Longrightarrow> var_lens x"
   using basis_lens.lens_in_basis basis_lens_def var_lens_axioms_def var_lens_def by blast
 
 lemma basis_lens_intro: "\<lbrakk> vwb_lens x; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<in> set Vars \<rbrakk> \<Longrightarrow> basis_lens x"
   using basis_lens.intro basis_lens_axioms.intro by blast
 
 subsection \<open> Composite lenses \<close>
 
 locale composite_lens = vwb_lens +
   assumes comp_in_Vars: "(\<lambda> a. a ;\<^sub>S x) ` set Vars \<subseteq> set Vars"
 begin
 
 lemma Vars_closed_comp: "a \<in> set Vars \<Longrightarrow> a ;\<^sub>S x \<in> set Vars"
   using comp_in_Vars by blast
 
 lemma scene_space_closed_comp:
   assumes "a \<in> scene_space"
   shows "a ;\<^sub>S x \<in> scene_space"
 proof -
   obtain xs where xs: "a = \<Squnion>\<^sub>S xs" "set xs \<subseteq> set Vars"
     using assms scene_space_vars_decomp by blast
   have "(\<Squnion>\<^sub>S xs) ;\<^sub>S x = \<Squnion>\<^sub>S (map (\<lambda> a. a ;\<^sub>S x) xs)"
     by (metis foldr_compat_dist pairwise_subset scene_space_compats xs(2))
   also have "... \<in> scene_space"
     by (auto simp add: scene_space_vars_decomp_iff)
        (metis comp_in_Vars image_Un le_iff_sup le_supE list.set_map xs(2))
   finally show ?thesis
     by (simp add: xs)
 qed
 
 sublocale var_lens
 proof
   show "\<lbrakk>x\<rbrakk>\<^sub>\<sim> \<in> scene_space"
     by (metis scene_comp_top_scene scene_space_closed_comp top_scene_space vwb_lens_axioms)
 qed
 
 end
 
 lemma composite_implies_var_lens [simp]:
   "composite_lens x \<Longrightarrow> var_lens x"
   by (metis composite_lens.axioms(1) composite_lens.scene_space_closed_comp scene_comp_top_scene top_scene_space var_lens_axioms.intro var_lens_def)
 
 text \<open> The extension of any lens in the scene space remains in the scene space \<close>
 
 lemma composite_lens_comp [simp]:
   "\<lbrakk> composite_lens a; var_lens x \<rbrakk> \<Longrightarrow> var_lens (x ;\<^sub>L a)"
   by (metis comp_vwb_lens composite_lens.scene_space_closed_comp composite_lens_def lens_scene_comp var_lens_axioms_def var_lens_def)
 
 lemma comp_composite_lens [simp]:
   "\<lbrakk> composite_lens a; composite_lens x \<rbrakk> \<Longrightarrow> composite_lens (x ;\<^sub>L a)"
   by (auto intro!: composite_lens.intro simp add: composite_lens_axioms_def)
      (metis composite_lens.Vars_closed_comp composite_lens.axioms(1) scene_comp_assoc)
 
 text \<open> A basis lens within a composite lens remains a basis lens (i.e. it remains atomic) \<close>
 
 lemma composite_lens_basis_comp [simp]:
   "\<lbrakk> composite_lens a; basis_lens x \<rbrakk> \<Longrightarrow> basis_lens (x ;\<^sub>L a)"
   by (metis basis_lens.lens_in_basis basis_lens_def basis_lens_intro comp_vwb_lens composite_lens.Vars_closed_comp composite_lens_def lens_scene_comp)
 
 lemma id_composite_lens: "composite_lens 1\<^sub>L"
   by (force intro: composite_lens.intro composite_lens_axioms.intro)
 
 lemma fst_composite_lens: "composite_lens fst\<^sub>L"
   by (rule composite_lens.intro, simp add: fst_vwb_lens, rule composite_lens_axioms.intro, simp add: Vars_prod_def)
 
 lemma snd_composite_lens: "composite_lens snd\<^sub>L"
   by (rule composite_lens.intro, simp add: snd_vwb_lens, rule composite_lens_axioms.intro, simp add: Vars_prod_def)
 
 end
\ No newline at end of file
diff --git a/thys/Polynomial_Factorization/Missing_List.thy b/thys/Polynomial_Factorization/Missing_List.thy
--- a/thys/Polynomial_Factorization/Missing_List.thy
+++ b/thys/Polynomial_Factorization/Missing_List.thy
@@ -1,1577 +1,1516 @@
 (*  
     Author:      René Thiemann 
                  Akihisa Yamada
     License:     BSD
 *)
 subsection \<open>Missing List\<close>
 
 text \<open>The provides some standard algorithms and lemmas on lists.\<close>
 theory Missing_List
 imports 
   Matrix.Utility
   "HOL-Library.Monad_Syntax"
 begin
 
 fun concat_lists :: "'a list list \<Rightarrow> 'a list list" where
   "concat_lists [] = [[]]"
 | "concat_lists (as # xs) = concat (map (\<lambda>vec. map (\<lambda>a. a # vec) as) (concat_lists xs))"
 
 lemma concat_lists_listset: "set (concat_lists xs) = listset (map set xs)" 
   by (induct xs, auto simp: set_Cons_def)
 
 lemma sum_list_concat: "sum_list (concat ls) = sum_list (map sum_list ls)"
   by (induct ls, auto)
 
 
 (* TODO: move to src/HOL/List *)
 lemma listset: "listset xs = { ys. length ys = length xs \<and> (\<forall> i < length xs. ys ! i \<in> xs ! i)}"
 proof (induct xs)
   case (Cons x xs)
   let ?n = "length xs" 
   from Cons 
   have "?case = (set_Cons x {ys. length ys = ?n \<and> (\<forall>i < ?n. ys ! i \<in> xs ! i)} =
     {ys. length ys = Suc ?n \<and> ys ! 0 \<in> x \<and> (\<forall>i < ?n. ys ! Suc i \<in> xs ! i)})" 
     (is "_ = (?L = ?R)")
     by (auto simp: all_Suc_conv)
   also have "?L = ?R"
     by (auto simp: set_Cons_def, case_tac xa, auto)
   finally show ?case by simp
 qed auto
 
 lemma set_concat_lists[simp]: "set (concat_lists xs) = {as. length as = length xs \<and> (\<forall>i<length xs. as ! i \<in> set (xs ! i))}"
   unfolding concat_lists_listset listset by simp
 
 declare concat_lists.simps[simp del]
 
 fun find_map_filter :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b option" where
   "find_map_filter f p [] = None"
 | "find_map_filter f p (a # as) = (let b = f a in if p b then Some b else find_map_filter f p as)"
 
 lemma find_map_filter_Some: "find_map_filter f p as = Some b \<Longrightarrow> p b \<and> b \<in> f ` set as"
   by (induct f p as rule: find_map_filter.induct, auto simp: Let_def split: if_splits)
 
 lemma find_map_filter_None: "find_map_filter f p as = None \<Longrightarrow> \<forall> b \<in> f ` set as. \<not> p b"
   by (induct f p as rule: find_map_filter.induct, auto simp: Let_def split: if_splits)
 
 lemma remdups_adj_sorted_distinct[simp]: "sorted xs \<Longrightarrow> distinct (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct) (auto)
 
 lemma subseqs_length_simple:
   assumes "b \<in> set (subseqs xs)" shows "length b \<le> length xs"
   using assms by(induct xs arbitrary:b;auto simp:Let_def Suc_leD)
 
 lemma subseqs_length_simple_False:
   assumes "b \<in> set (subseqs xs)" " length xs < length b" shows False
   using assms subseqs_length_simple by fastforce
 
 lemma empty_subseqs[simp]: "[] \<in> set (subseqs xs)" by (induct xs, auto simp: Let_def)
 
 lemma full_list_subseqs: "{ys. ys \<in> set (subseqs xs) \<and> length ys = length xs} = {xs}" 
 proof (induct xs)
   case (Cons x xs)
   have "?case = ({ys \<in> (#) x ` set (subseqs xs) \<union> set (subseqs xs). 
     length ys = Suc (length xs)} = (#) x ` {xs})" (is "_ = (?l = ?r)")
     by (auto simp: Let_def)
   also have "?l = {ys \<in> (#) x ` set (subseqs xs). length ys = Suc (length xs)}" 
     using length_subseqs[of xs]
     using subseqs_length_simple_False by force
   also have "\<dots> = (#) x ` {ys \<in> set (subseqs xs). length ys = length xs}"
     by auto
   also have "\<dots> = (#) x ` {xs}" unfolding Cons by auto
   finally show ?case by simp
 qed simp
 
 lemma nth_concat_split: assumes "i < length (concat xs)" 
   shows "\<exists> j k. j < length xs \<and> k < length (xs ! j) \<and> concat xs ! i = xs ! j ! k"
   using assms
 proof (induct xs arbitrary: i)
   case (Cons x xs i)
   define I where "I = i - length x" 
   show ?case 
   proof (cases "i < length x")
     case True note l = this
     hence i: "concat (Cons x xs) ! i = x ! i" by (auto simp: nth_append)
     show ?thesis unfolding i
       by (rule exI[of _ 0], rule exI[of _ i], insert Cons l, auto)
   next
     case False note l = this
     from l Cons(2) have i: "i = length x + I" "I < length (concat xs)" unfolding I_def by auto
     hence iI: "concat (Cons x xs) ! i = concat xs ! I" by (auto simp: nth_append)
     from Cons(1)[OF i(2)] obtain j k where
       IH: "j < length xs \<and> k < length (xs ! j) \<and> concat xs ! I = xs ! j ! k" by auto
     show ?thesis unfolding iI
       by (rule exI[of _ "Suc j"], rule exI[of _ k], insert IH, auto)
   qed
 qed simp
 
 lemma nth_concat_diff: assumes "i1 < length (concat xs)" "i2 < length (concat xs)" "i1 \<noteq> i2"
   shows "\<exists> j1 k1 j2 k2. (j1,k1) \<noteq> (j2,k2) \<and> j1 < length xs \<and> j2 < length xs
     \<and> k1 < length (xs ! j1) \<and> k2 < length (xs ! j2) 
     \<and> concat xs ! i1 = xs ! j1 ! k1 \<and> concat xs ! i2 = xs ! j2 ! k2"
   using assms
 proof (induct xs arbitrary: i1 i2)
   case (Cons x xs)
   define I1 where "I1 = i1 - length x" 
   define I2 where "I2 = i2 - length x" 
   show ?case 
   proof (cases "i1 < length x")
     case True note l1 = this
     hence i1: "concat (Cons x xs) ! i1 = x ! i1" by (auto simp: nth_append)
     show ?thesis
     proof (cases "i2 < length x")
       case True note l2 = this
       hence i2: "concat (Cons x xs) ! i2 = x ! i2" by (auto simp: nth_append)
       show ?thesis unfolding i1 i2 
         by (rule exI[of _ 0], rule exI[of _ i1], rule exI[of _ 0], rule exI[of _ i2], 
          insert Cons(4) l1 l2, auto)
     next
       case False note l2 = this
       from l2 Cons(3) have i22: "i2 = length x + I2" "I2 < length (concat xs)" unfolding I2_def by auto
       hence i2: "concat (Cons x xs) ! i2 = concat xs ! I2" by (auto simp: nth_append)
       from nth_concat_split[OF i22(2)] obtain j2 k2 where
         *: "j2 < length xs \<and> k2 < length (xs ! j2) \<and> concat xs ! I2 = xs ! j2 ! k2" by auto
       show ?thesis unfolding i1 i2
         by (rule exI[of _ 0], rule exI[of _ i1], rule exI[of _ "Suc j2"], rule exI[of _ k2],
          insert * l1, auto)
     qed
   next
     case False note l1 = this
     from l1 Cons(2) have i11: "i1 = length x + I1" "I1 < length (concat xs)" unfolding I1_def by auto
     hence i1: "concat (Cons x xs) ! i1 = concat xs ! I1" by (auto simp: nth_append)
     show ?thesis
     proof (cases "i2 < length x")
       case False note l2 = this
       from l2 Cons(3) have i22: "i2 = length x + I2" "I2 < length (concat xs)" unfolding I2_def by auto
       hence i2: "concat (Cons x xs) ! i2 = concat xs ! I2" by (auto simp: nth_append)
       from Cons(4) i11 i22 have diff: "I1 \<noteq> I2" by auto
       from Cons(1)[OF i11(2) i22(2) diff] obtain j1 k1 j2 k2
         where IH: "(j1,k1) \<noteq> (j2,k2) \<and> j1 < length xs \<and> j2 < length xs
         \<and> k1 < length (xs ! j1) \<and> k2 < length (xs ! j2) 
         \<and> concat xs ! I1 = xs ! j1 ! k1 \<and> concat xs ! I2 = xs ! j2 ! k2" by auto
       show ?thesis unfolding i1 i2 
         by (rule exI[of _ "Suc j1"], rule exI[of _ k1], rule exI[of _ "Suc j2"], rule exI[of _ k2],
         insert IH, auto)
     next
       case True note l2 = this
       hence i2: "concat (Cons x xs) ! i2 = x ! i2" by (auto simp: nth_append)
       from nth_concat_split[OF i11(2)] obtain j1 k1 where
         *: "j1 < length xs \<and> k1 < length (xs ! j1) \<and> concat xs ! I1 = xs ! j1 ! k1" by auto
       show ?thesis unfolding i1 i2
         by (rule exI[of _ "Suc j1"], rule exI[of _ k1], rule exI[of _ 0], rule exI[of _ i2],
          insert * l2, auto)
     qed
   qed      
 qed auto
 
 lemma list_all2_map_map: "(\<And> x. x \<in> set xs \<Longrightarrow> R (f x) (g x)) \<Longrightarrow> list_all2 R (map f xs) (map g xs)"
   by (induct xs, auto)
 
 subsection \<open>Partitions\<close>
 text \<open>Check whether a list of sets forms a partition, i.e.,
 whether the sets are pairwise disjoint.\<close>
 definition is_partition :: "('a set) list \<Rightarrow> bool" where
   "is_partition cs \<longleftrightarrow> (\<forall>j<length cs. \<forall>i<j. cs ! i \<inter> cs ! j = {})"
 
 (* and an equivalent but more symmetric version *)
 definition is_partition_alt :: "('a set) list \<Rightarrow> bool" where
   "is_partition_alt cs \<longleftrightarrow> (\<forall> i j. i < length cs \<and> j < length cs \<and> i \<noteq> j \<longrightarrow> cs!i \<inter> cs!j = {})"
 
 lemma is_partition_alt: "is_partition = is_partition_alt"
 proof (intro ext)
   fix cs :: "'a set list"
   {
     assume "is_partition_alt cs"
     hence "is_partition cs" unfolding is_partition_def is_partition_alt_def by auto
   }
   moreover
   {
     assume part: "is_partition cs"
     have "is_partition_alt cs" unfolding is_partition_alt_def
     proof (intro allI impI)
       fix i j
       assume "i < length cs \<and> j < length cs \<and> i \<noteq> j"
       with part show "cs ! i \<inter> cs ! j = {}"
         unfolding is_partition_def
         by (cases "i < j", simp, cases "j < i", force, simp)
     qed
   }
   ultimately
   show "is_partition cs = is_partition_alt cs" by auto
 qed
       
 lemma is_partition_Nil:
   "is_partition [] = True" unfolding is_partition_def by auto
 
 lemma is_partition_Cons:
   "is_partition (x#xs) \<longleftrightarrow> is_partition xs \<and> x \<inter> \<Union>(set xs) = {}" (is "?l = ?r")
 proof
   assume ?l
   have one: "is_partition xs"
   proof (unfold is_partition_def, intro allI impI)
     fix j i assume "j < length xs" and "i < j"
     hence "Suc j < length(x#xs)" and "Suc i < Suc j" by auto
     from \<open>?l\<close>[unfolded is_partition_def,THEN spec,THEN mp,THEN spec,THEN mp,OF this]
     have "(x#xs)!(Suc i) \<inter> (x#xs)!(Suc j) = {}" .
     thus "xs!i \<inter> xs!j = {}" by simp
   qed
   have two: "x \<inter> \<Union>(set xs) = {}"
   proof (rule ccontr)
     assume "x \<inter> \<Union>(set xs) \<noteq> {}"
     then obtain y where "y \<in> x" and "y \<in> \<Union>(set xs)" by auto
     then obtain z where "z \<in> set xs" and "y \<in> z" by auto
     then obtain i where "i < length xs" and "xs!i = z" using in_set_conv_nth[of z xs] by auto
     with \<open>y \<in> z\<close> have "y \<in> (x#xs)!Suc i" by auto
     moreover with \<open>y \<in> x\<close> have "y \<in> (x#xs)!0" by simp
     ultimately have "(x#xs)!0 \<inter> (x#xs)!Suc i \<noteq> {}" by auto
     moreover from \<open>i < length xs\<close> have "Suc i < length(x#xs)" by simp
     ultimately show False using \<open>?l\<close>[unfolded is_partition_def] by best
   qed
   from one two show ?r ..
 next
   assume ?r
   show ?l
   proof (unfold is_partition_def, intro allI impI)
     fix j i
     assume j: "j < length (x # xs)"
     assume i: "i < j"
     from i obtain j' where j': "j = Suc j'" by (cases j, auto)
     with j have j'len: "j' < length xs" and j'elem: "(x # xs) ! j = xs ! j'" by auto
     show "(x # xs) ! i \<inter> (x # xs) ! j = {}"
     proof (cases i)
       case 0
       with j'elem have "(x # xs) ! i \<inter> (x # xs) ! j = x \<inter> xs ! j'" by auto
       also have "\<dots> \<subseteq> x \<inter> \<Union>(set xs)" using j'len by force
       finally show ?thesis using \<open>?r\<close> by auto
     next
       case (Suc i')
       with i j' have i'j': "i' < j'" by auto
       from Suc j' have "(x # xs) ! i \<inter> (x # xs) ! j = xs ! i' \<inter> xs ! j'" by auto
       with \<open>?r\<close> i'j' j'len show ?thesis unfolding is_partition_def by auto
     qed
   qed
 qed
 
 lemma is_partition_sublist:
   assumes "is_partition (us @ xs @ ys @ zs @ vs)" 
   shows "is_partition (xs @ zs)"
 proof (rule ccontr)
   assume "\<not> is_partition (xs @ zs)"
   then obtain i j where j:"j < length (xs @ zs)" and i:"i < j" and *:"(xs @ zs) ! i \<inter> (xs @ zs) ! j \<noteq> {}" 
     unfolding is_partition_def by blast
   then show False
   proof (cases "j < length xs")
     case True
     let ?m = "j + length us"
     let ?n = "i + length us" 
     from True have "?m < length (us @ xs @ ys @ zs @ vs)" by auto
     moreover from i have "?n < ?m" by auto
     moreover have "(us @ xs @ ys @ zs @ vs) ! ?n \<inter> (us @ xs @ ys @ zs @ vs) ! ?m \<noteq> {}" 
       using i True * nth_append 
       by (metis (no_types, lifting) add_diff_cancel_right' not_add_less2 order.strict_trans)
     ultimately show False using assms unfolding is_partition_def by auto
   next
     case False
     let ?m = "j + length us + length ys"
     from j have m:"?m < length (us @ xs @ ys @ zs @ vs)" by auto
     have mj:"(us @ (xs @ ys @ zs @ vs)) ! ?m = (xs @ zs) ! j" unfolding nth_append using False j by auto
     show False
     proof (cases "i < length xs")
       case True
       let ?n = "i + length us"
       from i have "?n < ?m" by auto
       moreover have "(us @ xs @ ys @ zs @ vs) ! ?n = (xs @ zs) ! i" by (simp add: True nth_append) 
       ultimately show False using * m assms mj unfolding is_partition_def by blast
     next
       case False
       let ?n = "i + length us + length ys"
       from i have i:"?n < ?m" by auto
       moreover have "(us @ xs @ ys @ zs @ vs) ! ?n = (xs @ zs) ! i"
         unfolding nth_append using False i j less_diff_conv2 by auto
       ultimately show False using * m assms mj unfolding is_partition_def by blast
     qed
   qed
 qed
 
 lemma is_partition_inj_map:
   assumes "is_partition xs"
   and "inj_on f (\<Union>x \<in> set xs. x)"
   shows "is_partition (map ((`) f) xs)"
 proof (rule ccontr)
   assume "\<not> is_partition (map ((`) f) xs)"
   then obtain i j where neq:"i \<noteq> j" 
     and i:"i < length (map ((`) f) xs)" and j:"j < length (map ((`) f) xs)"
     and "map ((`) f) xs ! i \<inter> map ((`) f) xs ! j \<noteq> {}" 
     unfolding is_partition_alt is_partition_alt_def by auto
   then obtain x where "x \<in> map ((`) f) xs ! i" and "x \<in> map ((`) f) xs ! j" by auto
   then obtain y z where yi:"y \<in> xs ! i" and yx:"f y = x" and zj:"z \<in> xs ! j" and zx:"f z = x" 
     using i j by auto
   show False
   proof (cases "y = z")
     case True
     with zj yi neq assms(1) i j show ?thesis by (auto simp: is_partition_alt is_partition_alt_def)
   next
     case False
     have "y \<in> (\<Union>x \<in> set xs. x)" using yi i by force
     moreover have "z \<in> (\<Union>x \<in> set xs. x)" using zj j by force
     ultimately show ?thesis using assms(2) inj_on_def[of f "(\<Union>x\<in>set xs. x)"] False zx yx by blast
   qed
 qed
 
 context
 begin
 private fun is_partition_impl :: "'a set list \<Rightarrow> 'a set option" where
   "is_partition_impl [] = Some {}"
 | "is_partition_impl (as # rest) = do {
       all \<leftarrow> is_partition_impl rest;
       if as \<inter> all = {} then Some (all \<union> as) else None
     }" 
 
 lemma is_partition_code[code]: "is_partition as = (is_partition_impl as \<noteq> None)" 
 proof -
   note [simp] = is_partition_Cons is_partition_Nil
   have "\<And> bs. (is_partition as = (is_partition_impl as \<noteq> None)) \<and>
     (is_partition_impl as = Some bs \<longrightarrow> bs = \<Union> (set as))"
   proof (induct as)
     case (Cons as rest bs)
     show ?case
     proof (cases "is_partition rest")
       case False
       thus ?thesis using Cons by auto
     next
       case True
       with Cons obtain c where rest: "is_partition_impl rest = Some c" 
         by (cases "is_partition_impl rest", auto)
       with Cons True show ?thesis by auto
     qed
   qed auto
   thus ?thesis by blast
 qed
 end
 
 lemma case_prod_partition:
   "case_prod f (partition p xs) = f (filter p xs) (filter (Not \<circ> p) xs)"
   by simp
 
 lemmas map_id[simp] = list.map_id
 
 
 subsection \<open>merging functions\<close>
 
 definition fun_merge :: "('a \<Rightarrow> 'b)list \<Rightarrow> 'a set list \<Rightarrow> 'a \<Rightarrow> 'b"
   where "fun_merge fs as a \<equiv> (fs ! (LEAST i. i < length as \<and> a \<in> as ! i)) a"
 
 lemma fun_merge: assumes 
       i: "i < length as"
   and a: "a \<in> as ! i"
   and ident: "\<And> i j a. i < length as \<Longrightarrow> j < length as \<Longrightarrow> a \<in> as ! i \<Longrightarrow> a \<in> as ! j \<Longrightarrow> (fs ! i) a = (fs ! j) a"
   shows "fun_merge fs as a = (fs ! i) a"
 proof -
   let ?p = "\<lambda> i. i < length as \<and> a \<in> as ! i"
   let ?l = "LEAST i. ?p i"
   have p: "?p ?l"
     by (rule LeastI, insert i a, auto)
   show ?thesis unfolding fun_merge_def
     by (rule ident[OF _ i _ a], insert p, auto)
 qed
 
 lemma fun_merge_part: assumes 
       part: "is_partition as"
   and i: "i < length as"
   and a: "a \<in> as ! i"
   shows "fun_merge fs as a = (fs ! i) a"
 proof(rule fun_merge[OF i a])
   fix i j a
   assume "i < length as" and "j < length as" and "a \<in> as ! i" and "a \<in> as ! j"
   hence "i = j" using part[unfolded is_partition_alt is_partition_alt_def] by (cases "i = j", auto)
   thus "(fs ! i) a = (fs ! j) a" by simp
 qed
 
 
 lemma map_nth_conv: "map f ss = map g ts \<Longrightarrow> \<forall>i < length ss. f(ss!i) = g(ts!i)"
 proof (intro allI impI)
   fix i show "map f ss = map g ts \<Longrightarrow> i < length ss \<Longrightarrow> f(ss!i) = g(ts!i)"
   proof (induct ss arbitrary: i ts)
     case Nil thus ?case by (induct ts) auto
   next
     case (Cons s ss) thus ?case
       by (induct ts, simp, (cases i, auto))
   qed
 qed
 
 lemma distinct_take_drop:
   assumes dist: "distinct vs" and len: "i < length vs" shows "distinct(take i vs @ drop (Suc i) vs)" (is "distinct(?xs@?ys)")
 proof -
   from id_take_nth_drop[OF len] have vs[symmetric]: "vs = ?xs @ vs!i # ?ys" .
   with dist have "distinct ?xs" and "distinct(vs!i#?ys)" and "set ?xs \<inter> set(vs!i#?ys) = {}" using distinct_append[of ?xs "vs!i#?ys"] by auto
   hence "distinct ?ys" and "set ?xs \<inter> set ?ys = {}" by auto
   with \<open>distinct ?xs\<close> show ?thesis using distinct_append[of ?xs ?ys] vs by simp
 qed
 
 lemma map_nth_eq_conv:
   assumes len: "length xs = length ys"
   shows "(map f xs = ys) = (\<forall>i<length ys. f (xs ! i) = ys ! i)" (is "?l = ?r")
 proof -
   have "(map f xs = ys) = (map f xs = map id ys)" by auto
   also have "... = (\<forall> i < length ys. f (xs ! i) = id (ys ! i))" 
     using map_nth_conv[of f xs id ys] nth_map_conv[OF len, of f id] unfolding len
     by blast
   finally  show ?thesis by auto
 qed
 
 lemma map_upt_len_conv: 
   "map (\<lambda> i . f (xs!i)) [0..<length xs] = map f xs"
   by (rule nth_equalityI, auto)
 
 lemma map_upt_add':
   "map f [a..<a+b] = map (\<lambda> i. f (a + i)) [0..<b]"
   by (induct b, auto)
 
 
 definition generate_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list"
   where "generate_lists n xs \<equiv> concat_lists (map (\<lambda> _. xs) [0 ..< n])"
 
 lemma set_generate_lists[simp]: "set (generate_lists n xs) = {as. length as = n \<and> set as \<subseteq> set xs}"
 proof -
   {
     fix as
     have "(length as = n \<and> (\<forall>i<n. as ! i \<in> set xs)) = (length as = n \<and> set as \<subseteq> set xs)"
     proof -
       {
         assume "length as = n"
         hence n: "n = length as" by auto
         have "(\<forall>i<n. as ! i \<in> set xs) = (set as \<subseteq> set xs)" unfolding n
           unfolding all_set_conv_all_nth[of as "\<lambda> x. x \<in> set xs", symmetric] by auto
       }
       thus ?thesis by auto
     qed
   }
   thus ?thesis unfolding generate_lists_def unfolding set_concat_lists by auto
 qed
 
 lemma nth_append_take:
   assumes "i \<le> length xs" shows "(take i xs @ y#ys)!i = y"
 proof -
   from assms have a: "length(take i xs) = i" by simp
   have "(take i xs @ y#ys)!(length(take i xs)) = y" by (rule nth_append_length)
   thus ?thesis unfolding a .
 qed
 
 lemma nth_append_take_is_nth_conv:
   assumes "i < j" and "j \<le> length xs" shows "(take j xs @ ys)!i = xs!i"
 proof -
   from assms have "i < length(take j xs)" by simp
   hence "(take j xs @ ys)!i = take j xs ! i" unfolding nth_append by simp
   thus ?thesis unfolding nth_take[OF assms(1)] .
 qed
 
 lemma nth_append_drop_is_nth_conv:
   assumes "j < i" and "j \<le> length xs" and "i \<le> length xs"
   shows "(take j xs @ y # drop (Suc j) xs)!i = xs!i"
 proof -
   from \<open>j < i\<close> obtain n where ij: "Suc(j + n) = i" using less_imp_Suc_add by auto
   with assms have i: "i = length(take j xs) + Suc n" by auto
   have len: "Suc j + n \<le> length xs" using assms i by auto
   have "(take j xs @ y # drop (Suc j) xs)!i =
     (y # drop (Suc j) xs)!(i - length(take j xs))" unfolding nth_append i by auto
   also have "\<dots> = (y # drop (Suc j) xs)!(Suc n)" unfolding i by simp
   also have "\<dots> = (drop (Suc j) xs)!n" by simp
   finally show ?thesis using ij len by simp
 qed
 
 lemma nth_append_take_drop_is_nth_conv: 
  assumes "i \<le> length xs" and "j \<le> length xs" and "i \<noteq> j" 
  shows "(take j xs @ y # drop (Suc j) xs)!i = xs!i"
 proof -
  from assms have "i < j \<or> i > j" by auto
  thus ?thesis using assms 
    by (auto simp: nth_append_take_is_nth_conv nth_append_drop_is_nth_conv)
 qed
   
 lemma take_drop_imp_nth: "\<lbrakk>take i ss @ x # drop (Suc i) ss = ss\<rbrakk> \<Longrightarrow> x = ss!i"
 proof (induct ss arbitrary: i)
  case (Cons s ss)
  from \<open>take i (s#ss) @ x # drop (Suc i) (s#ss) = (s#ss)\<close> show ?case
  proof (induct i)
   case (Suc i)
   from Cons have IH: "take i ss @ x # drop (Suc i) ss = ss \<Longrightarrow> x = ss!i" by auto
   from Suc have "take i ss @ x # drop (Suc i) ss = ss" by auto
   with IH show ?case by auto
  qed auto
 qed auto
 
 lemma take_drop_update_first: assumes "j < length ds" and "length cs = length ds"
   shows "(take j ds @ drop j cs)[j := ds ! j] = take (Suc j) ds @ drop (Suc j) cs" 
 using assms
 proof (induct j arbitrary: ds cs)
   case 0
   then obtain d dds c ccs where ds: "ds = d # dds" and cs: "cs = c # ccs" by (cases ds, simp, cases cs, auto)
   show ?case unfolding ds cs by auto
 next
   case (Suc j)
   then obtain d dds c ccs where ds: "ds = d # dds" and cs: "cs = c # ccs" by (cases ds, simp, cases cs, auto)
   from Suc(1)[of dds ccs] Suc(2) Suc(3) show ?case unfolding ds cs by auto
 qed
 
 lemma take_drop_update_second: assumes "j < length ds" and "length cs = length ds"
   shows "(take j ds @ drop j cs)[j := cs ! j] = take j ds @ drop j cs"
 using assms
 proof (induct j arbitrary: ds cs)
   case 0
   then obtain d dds c ccs where ds: "ds = d # dds" and cs: "cs = c # ccs" by (cases ds, simp, cases cs, auto)
   show ?case unfolding ds cs by auto
 next
   case (Suc j)
   then obtain d dds c ccs where ds: "ds = d # dds" and cs: "cs = c # ccs" by (cases ds, simp, cases cs, auto)
   from Suc(1)[of dds ccs] Suc(2) Suc(3) show ?case unfolding ds cs by auto
 qed
 
 
 lemma nth_take_prefix:
  "length ys \<le> length xs \<Longrightarrow> \<forall>i < length ys. xs!i = ys!i \<Longrightarrow> take (length ys) xs = ys"
 proof (induct xs ys rule: list_induct2')
   case (4 x xs y ys)
   have "take (length ys) xs = ys"
     by (rule 4(1), insert 4(2-3), auto)
   moreover from 4(3) have "x = y" by auto
   ultimately show ?case by auto
 qed auto
 
 
 lemma take_upt_idx:
   assumes i: "i < length ls"
   shows "take i ls = [ ls ! j . j \<leftarrow> [0..<i]]" 
 proof -
   have e: "0 + i \<le> i" by auto
   show ?thesis 
     using take_upt[OF e] take_map map_nth
     by (metis (opaque_lifting, no_types) add.left_neutral i nat_less_le take_upt)
 qed
 
 
 fun distinct_eq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
   "distinct_eq _ [] = True"
 | "distinct_eq eq (x # xs) = ((\<forall> y \<in> set xs. \<not> (eq y x)) \<and> distinct_eq eq xs)"
 
 lemma distinct_eq_append: "distinct_eq eq (xs @ ys) = (distinct_eq eq xs \<and> distinct_eq eq ys \<and> (\<forall> x \<in> set xs. \<forall> y \<in> set ys. \<not> (eq y x)))"
   by (induct xs, auto)
 
 lemma append_Cons_nth_left:
   assumes "i < length xs"
   shows "(xs @ u # ys) ! i = xs ! i"
   using assms nth_append[of xs _ i] by simp
 
 lemma append_Cons_nth_middle:
   assumes "i = length xs"
   shows "(xs @ y # zs) ! i = y"
 using assms by auto
 
 lemma append_Cons_nth_right:
   assumes "i > length xs"
   shows "(xs @ u # ys) ! i = (xs @ z # ys) ! i"
   by (simp add: assms nth_append)
 
 lemma append_Cons_nth_not_middle:
   assumes "i \<noteq> length xs"
   shows "(xs @ u # ys) ! i = (xs @ z # ys) ! i"
   by (metis assms list_update_length nth_list_update_neq)
 
 lemmas append_Cons_nth = append_Cons_nth_middle append_Cons_nth_not_middle
 
 lemma concat_all_nth:
   assumes "length xs = length ys"
     and "\<And>i. i < length xs \<Longrightarrow> length (xs ! i) = length (ys ! i)"
     and "\<And>i j. i < length xs \<Longrightarrow> j < length (xs ! i) \<Longrightarrow> P (xs ! i ! j) (ys ! i ! j)"
   shows "\<forall>k<length (concat xs). P (concat xs ! k) (concat ys ! k)" 
   using assms
 proof (induct xs ys rule: list_induct2)
   case (Cons x xs y ys)
   from Cons(3)[of 0] have xy: "length x = length y" by simp
   from Cons(4)[of 0] xy have pxy: "\<And> j. j < length x \<Longrightarrow> P (x ! j) (y ! j)" by auto
   {
     fix i
     assume i: "i < length xs"
     with Cons(3)[of "Suc i"] 
     have len: "length (xs ! i) = length (ys ! i)" by simp
     from Cons(4)[of "Suc i"] i have "\<And> j. j < length (xs ! i) \<Longrightarrow> P (xs ! i ! j) (ys ! i ! j)"
       by auto
     note len and this
   } 
   from Cons(2)[OF this] have ind: "\<And> k. k < length (concat xs) \<Longrightarrow> P (concat xs ! k) (concat ys ! k)" 
     by auto
   show ?case unfolding concat.simps
   proof (intro allI impI) 
     fix k
     assume k: "k < length (x @ concat xs)"
     show "P ((x @ concat xs) ! k) ((y @ concat ys) ! k)"
     proof (cases "k < length x")
       case True
       show ?thesis unfolding nth_append using True xy pxy[OF True]
         by simp
     next
       case False
       with k have "k - (length x) < length (concat xs)" by auto
       then obtain n where n: "k - length x = n" and nxs: "n < length (concat xs)" by auto
       show ?thesis unfolding nth_append n n[unfolded xy] using False xy ind[OF nxs]
         by auto
     qed
   qed
 qed auto
 
 lemma eq_length_concat_nth:
   assumes "length xs = length ys"
     and "\<And>i. i < length xs \<Longrightarrow> length (xs ! i) = length (ys ! i)"
   shows "length (concat xs) = length (concat ys)"
 using assms
 proof (induct xs ys rule: list_induct2)
   case (Cons x xs y ys)
   from Cons(3)[of 0] have xy: "length x = length y" by simp
   {
     fix i
     assume "i < length xs"
     with Cons(3)[of "Suc i"] 
     have "length (xs ! i) = length (ys ! i)" by simp
   } 
   from Cons(2)[OF this] have ind: "length (concat xs) = length (concat ys)" by simp
   show ?case using xy ind by auto
 qed auto
 
 primrec
   list_union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "list_union [] ys = ys"
 | "list_union (x # xs) ys = (let zs = list_union xs ys in if x \<in> set zs then zs else x # zs)"
 
 lemma set_list_union[simp]: "set (list_union xs ys) = set xs \<union> set ys"
 proof (induct xs)
   case (Cons x xs) thus ?case by (cases "x \<in> set (list_union xs ys)") (auto)
 qed simp
 
 declare list_union.simps[simp del]
 
 (*Why was list_inter thrown out of List.thy?*)
 fun list_inter :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "list_inter [] bs = []"
 | "list_inter (a#as) bs =
     (if a \<in> set bs then a # list_inter as bs else list_inter as bs)"
 
 lemma set_list_inter[simp]:
   "set (list_inter xs ys) = set xs \<inter> set ys"
   by (induct rule: list_inter.induct) simp_all
 
 declare list_inter.simps[simp del]
 
 primrec list_diff :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "list_diff [] ys = []"
 | "list_diff (x # xs) ys = (let zs = list_diff xs ys in if x \<in> set ys then zs else x # zs)"
 
 lemma set_list_diff[simp]:
   "set (list_diff xs ys) = set xs - set ys"
 proof (induct xs)
   case (Cons x xs) thus ?case by (cases "x \<in> set ys") (auto)
 qed simp
 
 declare list_diff.simps[simp del]
 
 lemma nth_drop_0: "0 < length ss \<Longrightarrow> (ss!0)#drop (Suc 0) ss = ss"
   by (simp add: Cons_nth_drop_Suc)
 
 
 lemma set_foldr_remdups_set_map_conv[simp]:
   "set (foldr (\<lambda>x xs. remdups (f x @ xs)) xs []) = \<Union>(set (map (set \<circ> f) xs))"
   by (induct xs) auto
 
 
 lemma subset_set_code[code_unfold]: "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"
   unfolding list_all_iff by auto
 
 fun union_list_sorted where
   "union_list_sorted (x # xs) (y # ys) = 
    (if x = y then x # union_list_sorted xs ys 
     else if x < y then x # union_list_sorted xs (y # ys)
     else y # union_list_sorted (x # xs) ys)"
 | "union_list_sorted [] ys = ys"
 | "union_list_sorted xs [] = xs"
 
 lemma [simp]: "set (union_list_sorted xs ys) = set xs \<union> set ys"
   by (induct xs ys rule: union_list_sorted.induct, auto)
 
 fun subtract_list_sorted :: "('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "subtract_list_sorted (x # xs) (y # ys) = 
    (if x = y then subtract_list_sorted xs (y # ys) 
     else if x < y then x # subtract_list_sorted xs (y # ys)
     else subtract_list_sorted (x # xs) ys)"
 | "subtract_list_sorted [] ys = []"
 | "subtract_list_sorted xs [] = xs"
 
 lemma set_subtract_list_sorted[simp]: "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow>
   set (subtract_list_sorted xs ys) = set xs - set ys"
 proof (induct xs ys rule: subtract_list_sorted.induct)
   case (1 x xs y ys)
   have xxs: "sorted (x # xs)" by fact 
   have yys: "sorted (y # ys)" by fact
   have xs: "sorted xs" using xxs by (simp)
   show ?case
   proof (cases "x = y")
     case True
     thus ?thesis using 1(1)[OF True xs yys] by auto
   next 
     case False note neq = this
     note IH = 1(2-3)[OF this]
     show ?thesis 
       by (cases "x < y", insert IH xxs yys False, auto)
   qed
 qed auto  
 
 lemma subset_subtract_listed_sorted: "set (subtract_list_sorted xs ys) \<subseteq> set xs"
   by (induct xs ys rule: subtract_list_sorted.induct, auto)
 
 lemma set_subtract_list_distinct[simp]: "distinct xs \<Longrightarrow> distinct (subtract_list_sorted xs ys)"
   by (induct xs ys rule: subtract_list_sorted.induct, insert subset_subtract_listed_sorted, auto)
 
 definition "remdups_sort xs = remdups_adj (sort xs)"
 
 lemma remdups_sort[simp]: "sorted (remdups_sort xs)" "set (remdups_sort xs) = set xs"
   "distinct (remdups_sort xs)"
   by (simp_all add: remdups_sort_def)
 
 text \<open>maximum and minimum\<close>
 lemma max_list_mono: assumes "\<And> x. x \<in> set xs - set ys \<Longrightarrow> \<exists> y. y \<in> set ys \<and> x \<le> y"
   shows "max_list xs \<le> max_list ys"
   using assms
 proof (induct xs)
   case (Cons x xs)
   have "x \<le> max_list ys"
   proof (cases "x \<in> set ys")
     case True
     from max_list[OF this] show ?thesis .
   next
     case False
     with Cons(2)[of x] obtain y where y: "y \<in> set ys"
       and xy: "x \<le> y" by auto
     from xy max_list[OF y] show ?thesis by arith
   qed
   moreover have "max_list xs \<le> max_list ys"
     by (rule Cons(1)[OF Cons(2)], auto)
   ultimately show ?case by auto
 qed auto
 
 fun min_list :: "('a :: linorder) list \<Rightarrow> 'a" where
   "min_list [x] = x"
 | "min_list (x # xs) = min x (min_list xs)"
 
 lemma min_list: "(x :: 'a :: linorder) \<in> set xs \<Longrightarrow> min_list xs \<le> x"
 proof (induct xs)
   case oCons : (Cons y ys) 
   show ?case
   proof (cases ys)
     case Nil
     thus ?thesis using oCons by auto
   next
     case (Cons z zs)
     hence "min_list (y # ys) = min y (min_list ys)" 
       by auto
     then show ?thesis
       using min_le_iff_disj oCons.hyps oCons.prems by auto 
   qed
 qed simp
 
 lemma min_list_Cons:
   assumes xy: "x \<le> y"
     and len: "length xs = length ys"
     and xsys: "min_list xs \<le> min_list ys"
   shows "min_list (x # xs) \<le> min_list (y # ys)"
   by (metis min_list.simps len length_greater_0_conv min.mono nth_drop_0 xsys xy)
 
 lemma min_list_nth:
   assumes "length xs = length ys"
     and "\<And>i. i < length ys \<Longrightarrow> xs ! i \<le> ys ! i"
   shows "min_list xs \<le> min_list ys"
 using assms
 proof (induct xs arbitrary: ys)
   case (Cons x xs zs)
   from Cons(2) obtain y ys where zs: "zs = y # ys" by (cases zs, auto)
   note Cons = Cons[unfolded zs]
   from Cons(2) have len: "length xs = length ys" by simp
   from Cons(3)[of 0] have xy: "x \<le> y" by simp
   {
     fix i
     assume "i < length xs"
     with Cons(3)[of "Suc i"] Cons(2)
     have "xs ! i \<le> ys ! i" by simp
   } 
   from Cons(1)[OF len this] Cons(2) have ind: "min_list xs \<le> min_list ys" by simp
   show ?case unfolding zs
     by (rule min_list_Cons[OF xy len ind])
 qed auto
 
 lemma min_list_ex:
   assumes "xs \<noteq> []" shows "\<exists>x\<in>set xs. min_list xs = x"
   using assms
 proof (induct xs)
   case oCons : (Cons x xs) 
   show ?case
   proof (cases xs)
     case (Cons y ys)
     hence id: "min_list (x # xs) = min x (min_list xs)" and nNil: "xs \<noteq> []" by auto
     show ?thesis
     proof (cases "x \<le> min_list xs")
       case True
       show ?thesis unfolding id 
         by (rule bexI[of _ x], insert True, auto simp: min_def)
     next
       case False
       show ?thesis unfolding id min_def
         using oCons(1)[OF nNil] False by auto
     qed
   qed auto
 qed auto
 
 lemma min_list_subset:
   assumes subset: "set ys \<subseteq> set xs" and mem: "min_list xs \<in> set ys"
   shows "min_list xs = min_list ys"
   by (metis antisym empty_iff empty_set mem min_list min_list_ex subset subsetD)
 
 text\<open>Apply a permutation to a list.\<close>
 
 primrec permut_aux :: "'a list \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "permut_aux [] _ _ = []" |
   "permut_aux (a # as) f bs = (bs ! f 0) # (permut_aux as (\<lambda>n. f (Suc n)) bs)"
 
 definition permut :: "'a list \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> 'a list" where
   "permut as f = permut_aux as f as"
 declare permut_def[simp]
 
 lemma permut_aux_sound:
   assumes "i < length as"
   shows "permut_aux as f bs ! i = bs ! (f i)"
 using assms proof (induct as arbitrary: i f bs)
   case (Cons x xs)
   show ?case 
   proof (cases i)
     case (Suc j)
     with Cons(2) have "j < length xs" by simp
     from Cons(1)[OF this] and Suc show ?thesis by simp
   qed simp
 qed simp
 
 lemma permut_sound:
   assumes "i < length as"
   shows "permut as f ! i = as ! (f i)"
 using assms and permut_aux_sound by simp
 
 lemma permut_aux_length:
   assumes "bij_betw f {..<length as} {..<length bs}"
   shows "length (permut_aux as f bs) = length as"
 by (induct as arbitrary: f bs, simp_all)
 
 lemma permut_length:
   assumes "bij_betw f {..< length as} {..< length as}"
   shows "length (permut as f) = length as"
   using permut_aux_length[OF assms] by simp
  
 declare permut_def[simp del]
 
 lemma foldl_assoc:
   fixes b :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>" 55)
   assumes "\<And>f g h. f \<cdot> (g \<cdot> h) = f \<cdot> g \<cdot> h"
   shows "foldl (\<cdot>) (x \<cdot> y) zs = x \<cdot> foldl (\<cdot>) y zs"
   using assms[symmetric] by (induct zs arbitrary: y) simp_all
 
 lemma foldr_assoc:
   assumes "\<And>f g h. b (b f g) h = b f (b g h)"
   shows "foldr b xs (b y z) = b (foldr b xs y) z"
   using assms by (induct xs) simp_all
 
 lemma foldl_foldr_o_id:
   "foldl (\<circ>) id fs = foldr (\<circ>) fs id"
 proof (induct fs)
   case (Cons f fs)
   have "id \<circ> f = f \<circ> id" by simp
   with Cons [symmetric] show ?case
     by (simp only: foldl_Cons foldr_Cons o_apply [of _ _ id] foldl_assoc o_assoc)
 qed simp
 
 lemma foldr_o_o_id[simp]:
   "foldr ((\<circ>) \<circ> f) xs id a = foldr f xs a"
   by (induct xs) simp_all
 
 lemma Ex_list_of_length_P:
   assumes "\<forall>i<n. \<exists>x. P x i"
   shows "\<exists>xs. length xs = n \<and> (\<forall>i<n. P (xs ! i) i)"
 proof -
   from assms have "\<forall> i. \<exists> x. i < n \<longrightarrow> P x i" by simp
   from choice[OF this] obtain xs where xs: "\<And> i. i < n \<Longrightarrow> P (xs i) i" by auto
   show ?thesis
     by (rule exI[of _ "map xs [0 ..< n]"], insert xs, auto)
 qed
 
 lemma ex_set_conv_ex_nth: "(\<exists>x\<in>set xs. P x) = (\<exists>i<length xs. P (xs ! i))"
   using in_set_conv_nth[of _ xs] by force
 
 lemma map_eq_set_zipD [dest]:
   assumes "map f xs = map f ys"
     and "(x, y) \<in> set (zip xs ys)"
   shows "f x = f y"
 using assms
 proof (induct xs arbitrary: ys)
   case (Cons x xs)
   then show ?case by (cases ys) auto
 qed simp
 
 fun span :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
   "span P (x # xs) =
     (if P x then let (ys, zs) = span P xs in (x # ys, zs)
     else ([], x # xs))" |
   "span _ [] = ([], [])"
 
 lemma span[simp]: "span P xs = (takeWhile P xs, dropWhile P xs)"
   by (induct xs, auto)
 
 declare span.simps[simp del]
 
 lemma parallel_list_update: assumes 
   one_update: "\<And> xs i y. length xs = n \<Longrightarrow> i < n \<Longrightarrow> r (xs ! i) y \<Longrightarrow> p xs \<Longrightarrow> p (xs[i := y])"
   and init: "length xs = n" "p xs"
   and rel: "length ys = n" "\<And> i. i < n \<Longrightarrow> r (xs ! i) (ys ! i)"
   shows "p ys"
 proof -
   note len = rel(1) init(1)
   {
     fix i
     assume "i \<le> n"
     hence "p (take i ys @ drop i xs)"
     proof (induct i)
       case 0 with init show ?case by simp
     next
       case (Suc i)
       hence IH: "p (take i ys @ drop i xs)" by simp
       from Suc have i: "i < n" by simp
       let ?xs = "(take i ys @ drop i xs)"
       have "length ?xs = n" using i len by simp
       from one_update[OF this i _ IH, of "ys ! i"] rel(2)[OF i] i len
       show ?case by (simp add: nth_append take_drop_update_first)
     qed
   }
   from this[of n] show ?thesis using len by auto
 qed
 
 lemma nth_concat_two_lists: 
   "i < length (concat (xs :: 'a list list)) \<Longrightarrow> length (ys :: 'b list list) = length xs 
   \<Longrightarrow> (\<And> i. i < length xs \<Longrightarrow> length (ys ! i) = length (xs ! i))
   \<Longrightarrow> \<exists> j k. j < length xs \<and> k < length (xs ! j) \<and> (concat xs) ! i = xs ! j ! k \<and>
      (concat ys) ! i = ys ! j ! k"
 proof (induct xs arbitrary: i ys)
   case (Cons x xs i yys)
   then obtain y ys where yys: "yys = y # ys" by (cases yys, auto)
   note Cons = Cons[unfolded yys]
   from Cons(4)[of 0] have [simp]: "length y = length x" by simp
   show ?case
   proof (cases "i < length x")
     case True
     show ?thesis unfolding yys
       by (rule exI[of _ 0], rule exI[of _ i], insert True Cons(2-4), auto simp: nth_append)
   next
     case False
     let ?i = "i - length x"
     from False Cons(2-3) have "?i < length (concat xs)" "length ys = length xs" by auto
     note IH = Cons(1)[OF this]
     {
       fix i
       assume "i < length xs"
       with Cons(4)[of "Suc i"] have "length (ys ! i) = length (xs ! i)" by simp
     }
     from IH[OF this]
     obtain j k where IH1: "j < length xs" "k < length (xs ! j)" 
       "concat xs ! ?i = xs ! j ! k"
       "concat ys ! ?i = ys ! j ! k" by auto
     show ?thesis unfolding yys
       by (rule exI[of _ "Suc j"], rule exI[of _ k], insert IH1 False, auto simp: nth_append)
   qed
 qed simp
 
 text \<open>Removing duplicates w.r.t. some function.\<close>
 fun remdups_gen :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "remdups_gen f [] = []"
 | "remdups_gen f (x # xs) = x # remdups_gen f [y <- xs. \<not> f x = f y]"
 
 lemma remdups_gen_subset: "set (remdups_gen f xs) \<subseteq> set xs"
   by (induct f xs rule: remdups_gen.induct, auto)
 
 lemma remdups_gen_elem_imp_elem: "x \<in> set (remdups_gen f xs) \<Longrightarrow> x \<in> set xs"
   using remdups_gen_subset[of f xs] by blast
 
 lemma elem_imp_remdups_gen_elem: "x \<in> set xs \<Longrightarrow> \<exists> y \<in> set (remdups_gen f xs). f x = f y"
 proof (induct f xs rule: remdups_gen.induct)
   case (2 f z zs)
   show ?case
   proof (cases "f x = f z")
     case False
     with 2(2) have "x \<in> set [y\<leftarrow>zs . f z \<noteq> f y]" by auto
     from 2(1)[OF this] show ?thesis by auto
   qed auto
 qed auto
 
 
 lemma take_nth_drop_concat:
   assumes "i < length xss" and "xss ! i = ys"
     and "j < length ys" and "ys ! j = z"
   shows "\<exists>k < length (concat xss).
     take k (concat xss) = concat (take i xss) @ take j ys \<and>
     concat xss ! k = xss ! i ! j \<and>
     drop (Suc k) (concat xss) = drop (Suc j) ys @ concat (drop (Suc i) xss)"
 using assms(1, 2)
 proof (induct xss arbitrary: i rule: List.rev_induct)
   case (snoc xs xss)
   then show ?case using assms by (cases "i < length xss") (auto simp: nth_append)
 qed simp
 
 lemma concat_map_empty [simp]:
   "concat (map (\<lambda>_. []) xs) = []"
   by simp
 
 lemma map_upt_len_same_len_conv:
   assumes "length xs = length ys"
   shows "map (\<lambda>i. f (xs ! i)) [0 ..< length ys] = map f xs"
   unfolding assms [symmetric] by (rule map_upt_len_conv)
 
 lemma concat_map_concat [simp]:
   "concat (map concat xs) = concat (concat xs)"
   by (induct xs) simp_all
 
 lemma concat_concat_map:
   "concat (concat (map f xs)) = concat (map (concat \<circ> f) xs)"
   by (induct xs) simp_all
 
 lemma UN_upt_len_conv [simp]:
   "length xs = n \<Longrightarrow> (\<Union>i \<in> {0 ..< n}. f (xs ! i)) = \<Union>(set (map f xs))"
   by (force simp: in_set_conv_nth)
 
 lemma Ball_at_Least0LessThan_conv [simp]:
   "length xs = n \<Longrightarrow>
     (\<forall>i \<in> {0 ..< n}. P (xs ! i)) \<longleftrightarrow> (\<forall>x \<in> set xs. P x)"
   by (metis atLeast0LessThan in_set_conv_nth lessThan_iff)
 
 lemma sum_list_replicate_length [simp]:
   "sum_list (replicate (length xs) (Suc 0)) = length xs"
   by (induct xs) simp_all
 
 lemma list_all2_in_set2:
   assumes "list_all2 P xs ys" and "y \<in> set ys"
   obtains x where "x \<in> set xs" and "P x y"
   using assms by (induct) auto
 
 lemma map_eq_conv':
   "map f xs = map g ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>i < length xs. f (xs ! i) = g (ys ! i))"
   using map_equality_iff map_equality_iff nth_map_conv by auto
 
 
 lemma list_3_cases[case_names Nil 1 2]:
   assumes "xs = [] \<Longrightarrow> P"
       and "\<And>x. xs = [x] \<Longrightarrow> P"
       and "\<And>x y ys. xs = x#y#ys \<Longrightarrow> P"
   shows P
   using assms by (rule remdups_adj.cases)
 
 lemma list_4_cases[case_names Nil 1 2 3]:
   assumes "xs = [] \<Longrightarrow> P"
       and "\<And>x. xs = [x] \<Longrightarrow> P"
       and "\<And>x y. xs = [x,y] \<Longrightarrow> P"
       and "\<And>x y z zs. xs = x # y # z # zs \<Longrightarrow> P"
   shows P
   using assms by (cases xs; cases "tl xs"; cases "tl (tl xs)", auto)
 
 lemma foldr_append2 [simp]:
   "foldr ((@) \<circ> f) xs (ys @ zs) = foldr ((@) \<circ> f) xs ys @ zs"
   by (induct xs) simp_all
 
 lemma foldr_append2_Nil [simp]:
   "foldr ((@) \<circ> f) xs [] @ zs = foldr ((@) \<circ> f) xs zs"
   unfolding foldr_append2 [symmetric] by simp
 
 lemma UNION_set_zip:
   "(\<Union>x \<in> set (zip [0..<length xs] (map f xs)). g x) = (\<Union>i < length xs. g (i, f (xs ! i)))"
   by (auto simp: set_conv_nth)
 
 lemma zip_fst: "p \<in> set (zip as bs) \<Longrightarrow> fst p \<in> set as"
   by (metis in_set_zipE prod.collapse)
 
 lemma zip_snd: "p \<in> set (zip as bs) \<Longrightarrow> snd p \<in> set bs"
   by (metis in_set_zipE prod.collapse)
 
 lemma zip_size_aux: "size_list (size o snd) (zip ts ls) \<le> (size_list size ls)"
 proof (induct ls arbitrary: ts)
   case (Cons l ls ts)
   thus ?case by (cases ts, auto)
 qed auto
 
 text\<open>We definie the function that remove the nth element of
 a list. It uses take and drop and the soundness is therefore not
 too hard to prove thanks to the already existing lemmas.\<close>
 
 definition remove_nth :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "remove_nth n xs \<equiv> (take n xs) @ (drop (Suc n) xs)"
 
 declare remove_nth_def[simp]
 
 lemma remove_nth_len:
   assumes i: "i < length xs"
   shows "length xs = Suc (length (remove_nth i xs))"
 proof -
   show ?thesis unfolding arg_cong[where f = "length", OF id_take_nth_drop[OF i]]
     unfolding remove_nth_def by simp
 qed
 
 lemma remove_nth_length :
   assumes n_bd: "n < length xs"
   shows "length (remove_nth n xs) = length xs - 1"
   using n_bd by force
 
 lemma remove_nth_id : "length xs \<le> n \<Longrightarrow> remove_nth n xs = xs"
   by simp
 
 lemma remove_nth_sound_l :
   assumes p_ub: "p < n"
   shows "(remove_nth n xs) ! p = xs ! p"
 proof (cases "n < length xs")
  case True  
   from length_take and True have ltk: "length (take n xs) = n" by simp
    {
      assume pltn: "p < n"
      from this and ltk have plttk: "p < length (take n xs)" by simp
      with nth_append[of "take n xs" _ p]
      have "((take n xs) @ (drop (Suc n) xs)) ! p = take n xs ! p" by auto
      with pltn and nth_take have "((take n xs) @ (drop (Suc n) xs)) ! p =  xs ! p" by simp
    }
   from this and ltk and p_ub show ?thesis by simp
  next
  case False
   hence "length xs \<le> n" by arith
   with remove_nth_id show ?thesis by force
 qed
 
 lemma remove_nth_sound_r :
   assumes "n \<le> p" and "p < length xs"
   shows "(remove_nth n xs) ! p = xs ! (Suc p)"
 proof-
  from \<open>n \<le> p\<close> and \<open>p < length xs\<close> have n_ub: "n < length xs" by arith
  from length_take and n_ub have ltk: "length (take n xs) = n" by simp
  from \<open>n \<le> p\<close> and ltk and nth_append[of "take n xs" _ p]
  have Hrew: "((take n xs) @ (drop (Suc n) xs)) ! p = drop (Suc n) xs ! (p - n)" by auto
  from \<open>n \<le> p\<close> have idx: "Suc n + (p - n) = Suc p" by arith
  from \<open>p < length xs\<close> have Sp_ub: "Suc p \<le> length xs" by arith
  from idx and Sp_ub and nth_drop have Hrew': "drop (Suc n) xs ! (p - n) = xs ! (Suc p)" by simp
  from Hrew and Hrew' show ?thesis by simp
 qed
 
 lemma nth_remove_nth_conv:
   assumes "i < length (remove_nth n xs)"
   shows "remove_nth n xs ! i = xs ! (if i < n then i else Suc i)"
 using assms remove_nth_sound_l remove_nth_sound_r[of n i xs] by auto
 
 lemma remove_nth_P_compat :
   assumes aslbs: "length as = length bs"
   and Pab: "\<forall>i. i < length as \<longrightarrow> P (as ! i) (bs ! i)"
   shows "\<forall>i. i < length (remove_nth p as) \<longrightarrow> P (remove_nth p as ! i) (remove_nth p bs ! i)"
 proof (cases "p < length as")
  case True
   hence p_ub: "p < length as" by assumption
   with remove_nth_length have lr_ub: "length (remove_nth p as) = length as - 1" by auto
   {
     fix i assume i_ub: "i < length (remove_nth p as)"
     have "P (remove_nth p as ! i) (remove_nth p bs ! i)"
      proof (cases "i < p")
      case True
       from i_ub and lr_ub have i_ub2: "i < length as" by arith
       from i_ub2 and Pab have P: "P (as ! i) (bs ! i)" by blast
       from P and remove_nth_sound_l[OF True, of as] and remove_nth_sound_l[OF True, of bs]
       show ?thesis by simp
      next
      case False
       hence p_ub2: "p \<le> i" by arith
       from i_ub and lr_ub have Si_ub: "Suc i < length as" by arith
       with Pab have P: "P (as ! Suc i) (bs ! Suc i)" by blast
       from i_ub and lr_ub have i_uba: "i < length as" by arith
       from i_uba and aslbs have i_ubb: "i < length bs" by simp      
       from P and p_ub and aslbs and remove_nth_sound_r[OF p_ub2 i_uba]
        and remove_nth_sound_r[OF p_ub2 i_ubb]
        show ?thesis by auto
      qed
   }
   thus ?thesis by simp
  next    
  case False
   hence p_lba: "length as \<le> p" by arith
   with aslbs have p_lbb: "length bs \<le> p" by simp
   from remove_nth_id[OF p_lba] and remove_nth_id[OF p_lbb] and Pab
   show ?thesis by simp
 qed
 
 declare remove_nth_def[simp del]
 
 definition adjust_idx :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   "adjust_idx i j \<equiv> (if j < i then j else (Suc j))"
 
 definition adjust_idx_rev :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
   "adjust_idx_rev i j \<equiv> (if j < i then j else j - Suc 0)"
 
 lemma adjust_idx_rev1: "adjust_idx_rev i (adjust_idx i j) = j"
   using adjust_idx_def adjust_idx_rev_def by auto
 
 lemma adjust_idx_rev2:
   assumes "j \<noteq> i" shows "adjust_idx i (adjust_idx_rev i j) = j"
   using adjust_idx_def adjust_idx_rev_def assms by auto
 
 lemma adjust_idx_i:
   "adjust_idx i j \<noteq> i"
   using adjust_idx_def lessI less_irrefl_nat by auto
 
 lemma adjust_idx_nth:
   assumes i: "i < length xs"
   shows "remove_nth i xs ! j = xs ! adjust_idx i j" (is "?l = ?r")
 proof -
   let ?j = "adjust_idx i j"
   from i have ltake: "length (take i xs) = i" by simp
   note nth_xs = arg_cong[where f = "\<lambda> xs. xs ! ?j", OF id_take_nth_drop[OF i], unfolded nth_append ltake]
   show ?thesis
   proof (cases "j < i")
     case True
     hence j: "?j = j" unfolding adjust_idx_def by simp
     show ?thesis unfolding nth_xs unfolding j remove_nth_def nth_append ltake
       using True by simp
   next
     case False
     hence j: "?j = Suc j" unfolding adjust_idx_def by simp
     from i have lxs: "min (length xs) i = i" by simp
     show ?thesis unfolding nth_xs unfolding j remove_nth_def nth_append
       using False by (simp add: lxs)
   qed
 qed
 
 lemma adjust_idx_rev_nth:
   assumes i: "i < length xs"
     and ji: "j \<noteq> i"
   shows "remove_nth i xs ! adjust_idx_rev i j = xs ! j" (is "?l = ?r")
   by (simp add: adjust_idx_nth adjust_idx_rev2 i ji)
 
 lemma adjust_idx_length:
   assumes i: "i < length xs"
     and j: "j < length (remove_nth i xs)"
   shows "adjust_idx i j < length xs"
   using adjust_idx_def i j remove_nth_len by fastforce
 
 lemma adjust_idx_rev_length:
   assumes "i < length xs"
     and "j < length xs"
     and "j \<noteq> i"
   shows "adjust_idx_rev i j < length (remove_nth i xs)"
   by (metis adjust_idx_def adjust_idx_rev2 assms not_less_eq remove_nth_len)
 
 
 text\<open>If a binary relation holds on two couples of lists, then it holds on
 the concatenation of the two couples.\<close>
 
 lemma P_as_bs_extend:
   assumes lab: "length as = length bs"
   and lcd: "length cs = length ds"
   and nsab: "\<forall>i. i < length bs \<longrightarrow> P (as ! i) (bs ! i)"
   and nscd: "\<forall>i. i < length ds \<longrightarrow> P (cs ! i) (ds ! i)"
   shows "\<forall>i. i < length (bs @ ds) \<longrightarrow> P ((as @ cs) ! i) ((bs @ ds) ! i)"
   by (simp add: lab nsab nscd nth_append)
 
 text\<open>Extension of filter and partition to binary relations.\<close>
 
 fun filter2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('a list \<times> 'b list)" where
   "filter2 P [] _ = ([], [])" |
   "filter2 P _ [] = ([], [])" |
   "filter2 P (a # as) (b # bs) = (if P a b
         then (a # fst (filter2 P as bs), b # snd (filter2 P as bs))
         else filter2 P as bs)"
 
 lemma filter2_length:
   "length (fst (filter2 P as bs)) \<equiv> length (snd (filter2 P as bs))"
 proof (induct as arbitrary: bs)
  case Nil
   show ?case by simp
  next
  case (Cons a as) note IH = this
   thus ?case proof (cases bs)
     case Nil
      thus ?thesis by simp
     next
     case (Cons b bs)
      thus ?thesis proof (cases "P a b")
        case True
         with Cons and IH show ?thesis by simp
        next
        case False
         with Cons and IH show ?thesis by simp
      qed
   qed
 qed
 
 lemma filter2_sound: "\<forall>i. i < length (fst (filter2 P as bs)) \<longrightarrow> P (fst (filter2 P as bs) ! i) (snd (filter2 P as bs) ! i)"
 proof (induct as arbitrary: bs)
  case Nil
   thus ?case by simp
  next
  case (Cons a as) note IH = this
   thus ?case proof (cases bs)
     case Nil
      thus ?thesis by simp
     next
     case (Cons b bs)
      thus ?thesis proof (cases "P a b")
       case False
        with Cons and IH show ?thesis by simp
       next
       case True
        {
          fix i
          assume i_bd: "i < length (fst (filter2 P (a # as) (b # bs)))"
          have "P (fst (filter2 P (a # as) (b # bs)) ! i) (snd (filter2 P (a # as) (b # bs)) ! i)"         proof (cases i)
           case 0
            with True show ?thesis by simp
           next
           case (Suc j)
            with i_bd and True have "j < length (fst (filter2 P as bs))" by auto
            with Suc and IH and True show ?thesis by simp
          qed
        }
        with Cons show ?thesis by simp
      qed
  qed
 qed
 
 definition partition2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('a list \<times> 'b list) \<times> ('a list \<times> 'b list)" where
   "partition2 P as bs \<equiv> ((filter2 P as bs) , (filter2 (\<lambda>a b. \<not> (P a b)) as bs))"
 
 lemma partition2_sound_P: "\<forall>i. i < length (fst (fst (partition2 P as bs))) \<longrightarrow>
   P (fst (fst (partition2 P as bs)) ! i) (snd (fst (partition2 P as bs)) ! i)"
   by (simp add: filter2_sound partition2_def)
 
 lemma partition2_sound_nP: "\<forall>i. i < length (fst (snd (partition2 P as bs))) \<longrightarrow>
   \<not> P (fst (snd (partition2 P as bs)) ! i) (snd (snd (partition2 P as bs)) ! i)"
   by (metis filter2_sound partition2_def snd_conv) 
 
 
 text\<open>Membership decision function that actually returns the
 value of the index where the value can be found.\<close>
 
 fun mem_idx :: "'a \<Rightarrow> 'a list \<Rightarrow> nat Option.option" where
   "mem_idx _ []       = None" |
   "mem_idx x (a # as) = (if x = a then Some 0 else map_option Suc (mem_idx x as))"
 
 lemma mem_idx_sound_output:
   assumes "mem_idx x as = Some i"
   shows "i < length as \<and> as ! i = x"
 using assms proof (induct as arbitrary: i)
   case Nil thus ?case by simp
   next
   case (Cons a as) note IH = this
    thus ?case proof (cases "x = a")
      case True with IH(2) show ?thesis by simp
      next
      case False note neq_x_a = this
       show ?thesis proof (cases "mem_idx x as")
        case None with IH(2) and neq_x_a show ?thesis by simp
        next
        case (Some j)
         with IH(2) and neq_x_a have "i = Suc j" by simp
         with IH(1) and Some show ?thesis by simp
       qed
    qed
 qed
 
 lemma mem_idx_sound_output2:
   assumes "mem_idx x as = Some i"
   shows "\<forall>j. j < i \<longrightarrow> as ! j \<noteq> x"
 using assms proof (induct as arbitrary: i)
   case Nil thus ?case by simp
   next
   case (Cons a as) note IH = this
    thus ?case proof (cases "x = a")
      case True with IH show ?thesis by simp
      next
      case False note neq_x_a = this
       show ?thesis proof (cases "mem_idx x as")
        case None with IH(2) and neq_x_a show ?thesis by simp
        next
        case (Some j)
         with IH(2) and neq_x_a have eq_i_Sj: "i = Suc j" by simp
         {
           fix k assume k_bd: "k < i"
           have "(a # as) ! k \<noteq> x"
           proof (cases k)
           case 0 with neq_x_a show ?thesis by simp
           next
           case (Suc l)
             with k_bd and eq_i_Sj have l_bd: "l < j" by arith
             with IH(1) and Some have "as ! l \<noteq> x" by simp
             with Suc show ?thesis by simp
           qed
         }
         thus ?thesis by simp
       qed
    qed
 qed
 
 lemma mem_idx_sound:
  "(x \<in> set as) = (\<exists>i. mem_idx x as = Some i)"
 proof (induct as)
  case Nil thus ?case by simp
  next
  case (Cons a as) note IH = this
   show ?case proof (cases "x = a")
    case True thus ?thesis by simp
    next
    case False
     {
       assume "x \<in> set (a # as)"
        with False have "x \<in> set as" by simp
        with IH obtain i where Some_i: "mem_idx x as = Some i" by auto
        with False have "mem_idx x (a # as) = Some (Suc i)" by simp
       hence "\<exists>i. mem_idx x (a # as) = Some i" by simp
     }
     moreover
     {
       assume "\<exists>i. mem_idx x (a # as) = Some i"
        then obtain i where Some_i: "mem_idx x (a # as) = Some i" by fast
        have "x \<in> set as" proof (cases i)
          case 0 with mem_idx_sound_output[OF Some_i] and False show ?thesis by simp
          next
          case (Suc j)
           with Some_i and False have "mem_idx x as = Some j" by simp
           hence "\<exists>i. mem_idx x as = Some i" by simp
           with IH show ?thesis by simp
        qed
        hence "x \<in> set (a # as)" by simp
     }
     ultimately show ?thesis by fast
   qed
 qed
 
 lemma mem_idx_sound2:
   "(x \<notin> set as) = (mem_idx x as = None)"
   unfolding mem_idx_sound by auto
 
 lemma sum_list_replicate_mono: assumes "w1 \<le> (w2 :: nat)"
   shows "sum_list (replicate n w1) \<le> sum_list (replicate n w2)"
 proof (induct n)
   case (Suc n)
   thus ?case using \<open>w1 \<le> w2\<close> by auto
 qed simp
 
 lemma all_gt_0_sum_list_map:
   assumes *: "\<And>x. f x > (0::nat)"
     and x: "x \<in> set xs" and len: "1 < length xs"
   shows "f x < (\<Sum>x\<leftarrow>xs. f x)"
   using x len
 proof (induct xs)
   case (Cons y xs)
   show ?case
   proof (cases "y = x")
     case True
     with *[of "hd xs"] Cons(3) show ?thesis by (cases xs, auto)
   next
     case False
     with Cons(2) have x: "x \<in> set xs" by auto
     then obtain z zs where xs: "xs = z # zs" by (cases xs, auto)
     show ?thesis
     proof (cases "length zs")
       case 0
       with x xs *[of y] show ?thesis by auto
     next
       case (Suc n)
       with xs have "1 < length xs" by auto
       from Cons(1)[OF x this] show ?thesis by simp
     qed
   qed
 qed simp
 
-lemma finite_distinct: "finite { xs . distinct xs \<and> set xs = X}" (is "finite (?S X)")
-proof (cases "finite X")
-  case False
-  with finite_set have id: "?S X = {}" by auto
-  show ?thesis unfolding id by auto
-next
-  case True
-  show ?thesis
-  proof (induct rule: finite_induct[OF True])
-    case (2 x X)
-    let ?L = "{0..< card (insert x X)} \<times> ?S X"
-    from 2(3)
-    have fin: "finite ?L" by auto
-    let ?f = "\<lambda> (i,xs). take i xs @ x # drop i xs"
-    show ?case
-    proof (rule finite_surj[OF fin, of _ ?f], rule)
-      fix xs
-      assume "xs \<in> ?S (insert x X)"
-      hence dis: "distinct xs" and set: "set xs = insert x X" by auto
-      from distinct_card[OF dis] have len: "length xs = card (set xs)" by auto
-      from set[unfolded set_conv_nth] obtain i where x: "x = xs ! i" and i: "i < length xs" by auto
-      from i have min: "min (length xs) i = i" by simp
-      let ?ys = "take i xs @ drop (Suc i) xs"
-      from id_take_nth_drop[OF i] have xsi: "xs = take i xs @ xs ! i # drop (Suc i) xs" .
-      also have "... = ?f (i,?ys)" unfolding split
-        by (simp add: min x)
-      finally have xs: "xs = ?f (i,?ys)" .
-      show "xs \<in> ?f ` ?L"
-      proof (rule image_eqI, rule xs, rule SigmaI)
-        show "i \<in> {0..<card (insert x X)}" using i[unfolded len] set[symmetric] by simp
-      next
-        from dis xsi have disxsi: "distinct (take i xs @ xs ! i # drop (Suc i) xs)" by simp
-        note disxsi = disxsi[unfolded distinct_append x[symmetric]]
-        have xys: "x \<notin> set ?ys" using disxsi by auto
-        from distinct_take_drop[OF dis i]
-        have disys: "distinct ?ys" .
-        have "insert x (set ?ys) = set xs" unfolding arg_cong[OF xsi, of set] x by simp
-        hence "insert x (set ?ys) = insert x X" unfolding set by simp
-        from this[unfolded insert_eq_iff[OF xys 2(2)]]
-        show "?ys \<in> ?S X" using disys by auto
-      qed
-    qed
-  qed simp
-qed
-
-lemma finite_distinct_subset:
-  assumes "finite X"
-  shows "finite { xs . distinct xs \<and> set xs \<subseteq> X}" (is "finite (?S X)")
-proof -
-  let ?X = "{ { xs. distinct xs \<and> set xs = Y} | Y. Y \<subseteq> X}"
-  have id: "?S X = \<Union> ?X" by blast
-  show ?thesis unfolding id
-  proof (rule finite_Union)
-    show "finite ?X" using assms  by auto
-  next
-    fix M
-    assume "M \<in> ?X"
-    with finite_distinct show "finite M" by auto
-  qed
-qed
-
 lemma map_of_filter:
   assumes "P x"
   shows "map_of [(x',y) \<leftarrow> ys. P x'] x = map_of ys x"
 proof (induct ys)
   case (Cons xy ys)
   obtain x' y where xy: "xy = (x',y)" by force
   show ?case
     using assms local.Cons by auto
 qed simp
 
 lemma set_subset_insertI: "set xs \<subseteq> set (List.insert x xs)" 
   by auto
 
 lemma set_removeAll_subset: "set (removeAll x xs) \<subseteq> set xs" 
   by auto
 
 lemma map_of_append_Some:
   "map_of xs y = Some z \<Longrightarrow> map_of (xs @ ys) y = Some z"
   by simp
 
 lemma map_of_append_None:
   "map_of xs y = None \<Longrightarrow> map_of (xs @ ys) y = map_of ys y"
   by (simp add: map_add_def)
 
 
 end
diff --git a/thys/Progress_Tracking/Auxiliary.thy b/thys/Progress_Tracking/Auxiliary.thy
--- a/thys/Progress_Tracking/Auxiliary.thy
+++ b/thys/Progress_Tracking/Auxiliary.thy
@@ -1,411 +1,405 @@
 section \<open>Auxiliary Lemmas\<close>
 
 (*<*)
 theory Auxiliary
   imports
     "HOL-Library.Multiset"
     "Nested_Multisets_Ordinals.Signed_Multiset"
     "HOL-Library.Linear_Temporal_Logic_on_Streams"
 begin
 (*>*)
 
 unbundle multiset.lifting
 
 subsection\<open>General\<close>
 
 lemma sum_list_hd_tl:
   fixes xs :: "(_ :: group_add) list"
   shows "xs \<noteq> [] \<Longrightarrow> sum_list (tl xs) = (- hd xs) + sum_list xs"
   by (cases xs) simp_all
 
-lemma finite_distinct_bounded: "finite A \<Longrightarrow> finite {xs. distinct xs \<and> set xs \<subseteq> A}"
-  apply (rule finite_subset[of _ "\<Union>n \<in> {0 .. card A}. {xs.  length xs = n \<and> distinct xs \<and> set xs \<subseteq> A}"])
-  subgoal by clarsimp (metis card_mono distinct_card)
-  subgoal by auto
-  done
-
 
 subsection\<open>Sums\<close>
 
 lemma Sum_eq_pick_changed_elem:
   assumes "finite M"
     and "m \<in> M" "f m = g m + \<Delta>"
     and "\<And>n. n \<noteq> m \<and> n \<in> M \<Longrightarrow> f n = g n"
   shows "(\<Sum>x\<in>M. f x) = (\<Sum>x\<in>M. g x) + \<Delta>"
   using assms
 proof (induct M arbitrary: m rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case
   proof (cases "x=m")
     case True
     with insert have "sum f F = sum g F"
       by (intro sum.cong[OF refl]) force
     with insert True show ?thesis
       by (auto simp: add.commute add.left_commute)
   next
     case False
     with insert show ?thesis
       by (auto simp: add.assoc)
   qed
 qed
 
 lemma sum_pos_ex_elem_pos: "(0::int) < (\<Sum>m\<in>M. f m) \<Longrightarrow> \<exists>m\<in>M. 0 < f m"
   by (meson not_le sum_nonpos)
 
 lemma sum_if_distrib_add: "finite A \<Longrightarrow> b \<in> A \<Longrightarrow> (\<Sum>a\<in>A. if a=b then X b + Y a else X a) = (\<Sum>a\<in>A. X a) + Y b"
   by (simp add: Sum_eq_pick_changed_elem)
 
 subsection\<open>Partial Orders\<close>
 
 lemma (in order) order_finite_set_exists_foundation:
   fixes   t :: 'a
   assumes "finite M"
     and   "t \<in> M"
   shows   "\<exists>s\<in>M. s \<le> t \<and> (\<forall>u\<in>M. \<not> u < s)"
   using assms
   by (simp add: dual_order.strict_iff_order finite_has_minimal2)
 
 lemma order_finite_set_obtain_foundation:
   fixes   t :: "_ :: order"
   assumes "finite M"
     and   "t \<in> M"
   obtains s where "s \<in> M" "s \<le> t" "\<forall>u\<in>M. \<not> u < s"
   using assms order_finite_set_exists_foundation by blast
 
 subsection\<open>Multisets\<close>
 
 lemma finite_nonzero_count: "finite {t. count M t > 0}"
   using count by auto
 
 lemma finite_count[simp]: "finite {t. count M t > i}"
   by (rule finite_subset[OF _ finite_nonzero_count[of M]]) (auto simp only: set_mset_def)
 
 subsection\<open>Signed Multisets\<close>
 
 lemma zcount_zmset_of_nonneg[simp]: "0 \<le> zcount (zmset_of M) t"
   by simp
 
 lemma finite_zcount_pos[simp]: "finite {t. zcount M t > 0}"
   apply transfer
   subgoal for M
     apply (rule finite_subset[OF _ finite_Un[THEN iffD2, OF conjI[OF finite_nonzero_count finite_nonzero_count]], of _ "fst M" "snd M"])
     apply (auto simp only: set_mset_def fst_conv snd_conv split: prod.splits)
     done
   done
 
 lemma finite_zcount_neg[simp]: "finite {t. zcount M t < 0}"
   apply transfer
   subgoal for M
     apply (rule finite_subset[OF _ finite_Un[THEN iffD2, OF conjI[OF finite_nonzero_count finite_nonzero_count]], of _ "fst M" "snd M"])
     apply (auto simp only: set_mset_def fst_conv snd_conv split: prod.splits)
     done
   done
 
 lemma pos_zcount_in_zmset: "0 < zcount M x \<Longrightarrow> x \<in>#\<^sub>z M"
   by (simp add: zcount_inI)
 
 lemma zmset_elem_nonneg: "x \<in>#\<^sub>z M \<Longrightarrow> (\<And>x. x \<in>#\<^sub>z M \<Longrightarrow> 0 \<le> zcount M x) \<Longrightarrow> 0 < zcount M x"
   by (simp add: order.order_iff_strict zcount_eq_zero_iff)
 
 lemma zero_le_sum_single: "0 \<le> zcount (\<Sum>x\<in>M. {#f x#}\<^sub>z) t"
   by (induct M rule: infinite_finite_induct) auto
 
 lemma mem_zmset_of[simp]: "x \<in>#\<^sub>z zmset_of M \<longleftrightarrow> x \<in># M"
   by (simp add: set_zmset_def)
 
 lemma mset_neg_minus: "mset_neg (abs_zmultiset (Mp,Mn)) = Mn-Mp"
   by (simp add: mset_neg.abs_eq)
 
 lemma mset_pos_minus: "mset_pos (abs_zmultiset (Mp,Mn)) = Mp-Mn"
   by (simp add: mset_pos.abs_eq)
 
 lemma mset_neg_sum_set: "(\<And>m. m \<in> M \<Longrightarrow> mset_neg (f m) = {#}) \<Longrightarrow> mset_neg (\<Sum>m\<in>M. f m) = {#}"
   by (induct M rule: infinite_finite_induct) auto
 
 lemma mset_neg_empty_iff: "mset_neg M = {#} \<longleftrightarrow> (\<forall>t. 0 \<le> zcount M t)"
   apply rule
   subgoal
     by (metis add.commute add.right_neutral mset_pos_as_neg zcount_zmset_of_nonneg zmset_of_empty)
   subgoal
     apply (induct rule: zmultiset.abs_induct)
     subgoal for y
       apply (induct y)
       apply (subst mset_neg_minus)
       apply transfer'
       apply (simp add: Diff_eq_empty_iff_mset mset_subset_eqI)
       done
     done
   done
 
 lemma mset_neg_zcount_nonneg: "mset_neg M = {#} \<Longrightarrow> 0 \<le> zcount M t"
   by (subst (asm) mset_neg_empty_iff) simp
 
 lemma in_zmset_conv_pos_neg_disj: "x \<in>#\<^sub>z M \<longleftrightarrow> x \<in># mset_pos M \<or> x \<in># mset_neg M"
   by (metis count_mset_pos in_diff_zcount mem_zmset_of mset_pos_neg_partition nat_code(2) not_in_iff zcount_ne_zero_iff)
 
 lemma in_zmset_notin_mset_pos[simp]: "x \<in>#\<^sub>z M \<Longrightarrow> x \<notin># mset_pos M \<Longrightarrow> x \<in># mset_neg M"
   by (auto simp: in_zmset_conv_pos_neg_disj)
 
 lemma in_zmset_notin_mset_neg[simp]: "x \<in>#\<^sub>z M \<Longrightarrow> x \<notin># mset_neg M \<Longrightarrow> x \<in># mset_pos M"
   by (auto simp: in_zmset_conv_pos_neg_disj)
 
 lemma in_mset_pos_in_zmset: "x \<in># mset_pos M \<Longrightarrow> x \<in>#\<^sub>z M"
   by (auto intro: iffD2[OF in_zmset_conv_pos_neg_disj])
 
 lemma in_mset_neg_in_zmset: "x \<in># mset_neg M \<Longrightarrow> x \<in>#\<^sub>z M"
   by (auto intro: iffD2[OF in_zmset_conv_pos_neg_disj])
 
 lemma set_zmset_eq_set_mset_union: "set_zmset M = set_mset (mset_pos M) \<union> set_mset (mset_neg M)"
   by (auto dest: in_mset_pos_in_zmset in_mset_neg_in_zmset)
 
 lemma member_mset_pos_iff_zcount: "x \<in># mset_pos M \<longleftrightarrow> 0 < zcount M x"
   using not_in_iff pos_zcount_in_zmset by force
 
 lemma member_mset_neg_iff_zcount: "x \<in># mset_neg M \<longleftrightarrow> zcount M x < 0"
   by (metis member_mset_pos_iff_zcount mset_pos_uminus neg_le_0_iff_le not_le zcount_uminus)
 
 lemma mset_pos_mset_neg_disjoint[simp]: "set_mset (mset_pos \<Delta>) \<inter> set_mset (mset_neg \<Delta>) = {}"
   by (auto simp: member_mset_pos_iff_zcount member_mset_neg_iff_zcount)
 
 lemma zcount_sum: "zcount (\<Sum>M\<in>MM. f M) t = (\<Sum>M\<in>MM. zcount (f M) t)"
   by (induct MM rule: infinite_finite_induct) auto
 
 lemma zcount_filter_invariant: "zcount {# t'\<in>#\<^sub>zM. t'=t #} t = zcount M t"
   by auto
 
 lemma in_filter_zmset_in_zmset[simp]: "x \<in>#\<^sub>z filter_zmset P M \<Longrightarrow> x \<in>#\<^sub>z M"
   by (metis count_filter_zmset zcount_ne_zero_iff)
 
 lemma pos_filter_zmset_pos_zmset[simp]: "0 < zcount (filter_zmset P M) x \<Longrightarrow> 0 < zcount M x"
   by (metis (full_types) count_filter_zmset less_irrefl)
 
 lemma neg_filter_zmset_neg_zmset[simp]: "0 > zcount (filter_zmset P M) x \<Longrightarrow> 0 > zcount M x"
   by (metis (full_types) count_filter_zmset less_irrefl)
 
 
 lift_definition update_zmultiset :: "'t zmultiset \<Rightarrow> 't \<Rightarrow> int \<Rightarrow> 't zmultiset" is
   "\<lambda>(A,B) T D.(if D>0 then (A + replicate_mset (nat D) T, B)
                     else (A,B + replicate_mset (nat (-D)) T))"
   by (auto simp: equiv_zmset_def if_split)
 
 lemma zcount_update_zmultiset: "zcount (update_zmultiset M t n) t' = zcount M t' + (if t = t' then n else 0)"
   by transfer auto
 
 lemma (in order) order_zmset_exists_foundation:
   fixes   t :: 'a
   assumes "0 < zcount M t"
   shows   "\<exists>s. s \<le> t \<and> 0 < zcount M s \<and> (\<forall>u. 0 < zcount M u \<longrightarrow> \<not> u < s)"
   using assms
 proof -
   let ?M = "{t. 0 < zcount M t}"
   from assms have "t \<in> ?M"
     by simp
   then have "\<exists>s\<in>?M. s \<le> t \<and> (\<forall>u\<in>?M. \<not> u < s)"
     by - (drule order_finite_set_exists_foundation[rotated 1], auto)
   then show ?thesis by auto
 qed
 
 lemma (in order) order_zmset_exists_foundation':
   fixes   t :: 'a
   assumes "0 < zcount M t"
   shows   "\<exists>s. s \<le> t \<and> 0 < zcount M s \<and> (\<forall>u<s. zcount M u \<le> 0)"
   using assms order_zmset_exists_foundation
   by (meson le_less_linear)
 
 lemma (in order) order_zmset_exists_foundation_neg:
   fixes   t :: 'a
   assumes "zcount M t < 0"
   shows   "\<exists>s. s \<le> t \<and> zcount M s < 0 \<and> (\<forall>u. zcount M u < 0 \<longrightarrow> \<not> u < s)"
   using assms
 proof -
   let ?M = "{t. zcount M t < 0}"
   from assms have "t \<in> ?M"
     by simp
   then have "\<exists>s\<in>?M. s \<le> t \<and> (\<forall>u\<in>?M. \<not> u < s)"
     by - (drule order_finite_set_exists_foundation[rotated 1], auto)
   then show ?thesis by auto
 qed
 
 lemma (in order) order_zmset_exists_foundation_neg':
   fixes   t :: 'a
   assumes "zcount M t < 0"
   shows   "\<exists>s. s \<le> t \<and> zcount M s < 0 \<and> (\<forall>u<s. 0 \<le> zcount M u)"
   using assms order_zmset_exists_foundation_neg
   by (meson le_less_linear)
 
 lemma (in order) elem_order_zmset_exists_foundation:
   fixes x :: 'a
   assumes "x \<in>#\<^sub>z M"
   shows   "\<exists>s\<in>#\<^sub>zM. s \<le> x \<and> (\<forall>u\<in>#\<^sub>zM. \<not> u < s)"
   by (rule order_finite_set_exists_foundation[OF finite_set_zmset, OF assms(1)])
 
 subsubsection\<open>Image of a Signed Multiset\<close>
 
 lift_definition image_zmset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zmultiset \<Rightarrow> 'b zmultiset" is
   "\<lambda>f (M, N). (image_mset f M, image_mset f N)"
   by (auto simp: equiv_zmset_def simp flip: image_mset_union)
 
 syntax (ASCII)
   "_comprehension_zmset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b zmultiset \<Rightarrow> 'a zmultiset"  ("({#_/. _ :#z _#})")
 syntax
   "_comprehension_zmset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b zmultiset \<Rightarrow> 'a zmultiset"  ("({#_/. _ \<in>#\<^sub>z _#})")
 translations
   "{#e. x \<in>#\<^sub>z M#}" \<rightleftharpoons> "CONST image_zmset (\<lambda>x. e) M"
 
 lemma image_zmset_empty[simp]: "image_zmset f {#}\<^sub>z = {#}\<^sub>z"
   by transfer (auto simp: equiv_zmset_def)
 
 lemma image_zmset_single[simp]: "image_zmset f {#x#}\<^sub>z = {#f x#}\<^sub>z"
   by transfer (simp add: equiv_zmset_def)
 
 lemma image_zmset_union[simp]: "image_zmset f (M + N) = image_zmset f M + image_zmset f N"
   by transfer (auto simp: equiv_zmset_def)
 
 lemma image_zmset_Diff[simp]: "image_zmset f (A - B) = image_zmset f A - image_zmset f B"
 proof -
   have "image_zmset f (A - B + B) = image_zmset f (A - B) + image_zmset f B"
     using image_zmset_union by blast
   then show ?thesis by simp
 qed
 
 lemma mset_neg_image_zmset: "mset_neg M = {#} \<Longrightarrow> mset_neg (image_zmset f M) = {#}"
   unfolding multiset_eq_iff count_empty
   by transfer (auto simp add: image_mset_subseteq_mono mset_subset_eqI mset_subset_eq_count)
 
 lemma nonneg_zcount_image_zmset[simp]: "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 \<le> zcount (image_zmset f M) t"
   by (meson mset_neg_empty_iff mset_neg_image_zmset)
 
 lemma image_zmset_add_zmset[simp]: "image_zmset f (add_zmset t M) = add_zmset (f t) (image_zmset f M)"
   by transfer (auto simp: equiv_zmset_def)
 
 lemma pos_zcount_image_zmset[simp]: "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 < zcount M t \<Longrightarrow> 0 < zcount (image_zmset f M) (f t)"
   apply transfer
   subgoal for M t f
     apply (induct M)
     subgoal for Mp Mn
       apply simp
       apply (metis count_diff count_image_mset_ge_count image_mset_Diff less_le_trans subseteq_mset_def zero_less_diff)
       done
     done
   done
 
 lemma set_zmset_transfer[transfer_rule]:
   "(rel_fun (pcr_zmultiset (=)) (rel_set (=)))
    (\<lambda>(Mp, Mn). set_mset Mp \<union> set_mset Mn - {x. count Mp x = count Mn x}) set_zmset"
   by (auto simp: rel_fun_def pcr_zmultiset_def cr_zmultiset_def
       rel_set_eq multiset.rel_eq set_zmset_def zcount.abs_eq count_eq_zero_iff[symmetric]
       simp del: zcount_ne_zero_iff)
 
 lemma zcount_image_zmset:
   "zcount (image_zmset f M) x = (\<Sum>y \<in> f -` {x} \<inter> set_zmset M. zcount M y)"
   apply (transfer fixing: f x)
   subgoal for M
     apply (cases M; clarify)
     subgoal for Mp Mn
       unfolding count_image_mset int_sum
     proof -
       have "(\<Sum>x\<in>f -` {x} \<inter> set_mset Mp. int (count Mp x)) =
         (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mp x))" (is "?S1 = _")
         by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"])
           (auto simp: count_eq_zero_iff)
       moreover
       have "(\<Sum>x\<in>f -` {x} \<inter> set_mset Mn. int (count Mn x)) =
         (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mn x))"(is "?S2 = _")
         by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"])
           (auto simp: count_eq_zero_iff)
       moreover
       have "(\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn - {x. count Mp x = count Mn x}). int (count Mp x) - int (count Mn x))
         = (\<Sum>x\<in>f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn). int (count Mp x) - int (count Mn x))"
         (is "?S = _")
         by (subst sum.same_carrier[where C="f -` {x} \<inter> (set_mset Mp \<union> set_mset Mn)"]) auto
       ultimately show "?S1 - ?S2 = ?S"
         by (auto simp: sum_subtractf)
     qed
     done
   done
 
 lemma zmset_empty_image_zmset_empty: "(\<And>t. zcount M t = 0) \<Longrightarrow> zcount (image_zmset f M) t = 0"
   by (auto simp: zcount_image_zmset)
 
 lemma in_image_zmset_in_zmset: "t \<in>#\<^sub>z image_zmset f M \<Longrightarrow> \<exists>t. t \<in>#\<^sub>z M"
   by (rule ccontr) simp
 
 lemma zcount_image_zmset_zero: "(\<And>m. m \<in>#\<^sub>z M \<Longrightarrow> f m \<noteq> x) \<Longrightarrow> x \<notin>#\<^sub>z image_zmset f M"
   unfolding set_zmset_def
   by (simp add: zcount_image_zmset) (metis Int_emptyI sum.empty vimage_singleton_eq)
 
 lemma image_zmset_pre: "t \<in>#\<^sub>z image_zmset f M \<Longrightarrow> \<exists>m. m \<in>#\<^sub>z M \<and> f m = t"
 proof (rule ccontr)
   assume t: "t \<in>#\<^sub>z image_zmset f M"
   assume "\<nexists>m. m \<in>#\<^sub>z M \<and> f m = t"
   then have "m \<in>#\<^sub>z M \<Longrightarrow> \<not> f m = t" for m
     by blast
   then have "zcount (image_zmset f M) t = 0"
     by (meson t zcount_image_zmset_zero)
   with t show False
     by (meson zcount_ne_zero_iff)
 qed
 
 lemma pos_image_zmset_obtain_pre:
   "(\<And>t. 0 \<le> zcount M t) \<Longrightarrow> 0 < zcount (image_zmset f M) t \<Longrightarrow> \<exists>m. 0 < zcount M m \<and> f m = t"
 proof -
   assume nonneg: "0 \<le> zcount M t" for t
   assume "0 < zcount (image_zmset f M) t"
   then have "t \<in>#\<^sub>z image_zmset f M"
     by (simp add: pos_zcount_in_zmset)
   then obtain x where x: "x \<in>#\<^sub>z M" "f x = t"
     by (auto dest: image_zmset_pre)
   with nonneg have "0 < zcount M x"
     by (meson zmset_elem_nonneg)
   with x show ?thesis
     by auto
 qed
 
 subsection\<open>Streams\<close>
 
 definition relates :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> bool" where
   "relates \<phi> s = \<phi> (shd s) (shd (stl s))"
 
 lemma relatesD[dest]: "relates P s \<Longrightarrow> P (shd s) (shd (stl s))"
   unfolding relates_def by simp
 
 lemma alw_relatesD[dest]: "alw (relates P) s \<Longrightarrow> P (shd s) (shd (stl s))"
   by auto
 
 lemma relatesI[intro]: "P (shd s) (shd (stl s)) \<Longrightarrow> relates P s"
   by (auto simp: relates_def)
 
 lemma alw_holds_smap_conv_comp: "alw (holds P) (smap f s) = alw (\<lambda>s. (P o f) (shd s)) s"
   apply (rule iffI)
    apply (coinduction arbitrary: s)
    apply auto []
   apply (coinduction arbitrary: s)
   apply auto
   done
 
 lemma alw_relates: "alw (relates P) s \<longleftrightarrow> P (shd s) (shd (stl s)) \<and> alw (relates P) (stl s)"
   apply (rule iffI)
    apply (auto simp: relates_def dest: alwD) []
   apply (coinduction arbitrary: s)
   apply (auto simp: relates_def)
   done
 
 subsection\<open>Notation\<close>
 
 no_notation AND  (infix "aand" 60)
 no_notation OR   (infix "or" 60)
 no_notation IMPL (infix "imp" 60)
 
 notation AND  (infixr "aand" 70)
 notation OR   (infixr "or" 65)
 notation IMPL (infixr "imp" 60)
 
 lifting_update multiset.lifting
 lifting_forget multiset.lifting
 
 (*<*)
 end
 (*>*)
\ No newline at end of file
diff --git a/thys/Progress_Tracking/Graph.thy b/thys/Progress_Tracking/Graph.thy
--- a/thys/Progress_Tracking/Graph.thy
+++ b/thys/Progress_Tracking/Graph.thy
@@ -1,384 +1,384 @@
 section\<open>Multigraphs with Partially Ordered Weights\<close>
 
 (*<*)
 theory Graph
   imports "HOL-Library.Sublist" Antichain
 begin
 (*>*)
 
 abbreviation (input) FROM where
   "FROM \<equiv> \<lambda>(s, l, t). s"
 
 abbreviation (input) LBL where
   "LBL \<equiv> \<lambda>(s, l, t). l"
 
 abbreviation (input) TO where
   "TO \<equiv> \<lambda>(s, l, t). t"
 
 notation subseq (infix "\<preceq>" 50)
 
 locale graph =
   fixes weights :: "'vtx :: finite \<Rightarrow> 'vtx \<Rightarrow> 'lbl :: {order, monoid_add} antichain"
   assumes zero_le[simp]: "0 \<le> (s::'lbl)"
     and plus_mono: "(s1::'lbl) \<le> s2 \<Longrightarrow> s3 \<le> s4 \<Longrightarrow> s1 + s3 \<le> s2 + s4"
     and summary_self: "weights loc loc = {}\<^sub>A"
 begin
 
 lemma le_plus: "(s::'lbl) \<le> s + s'" "(s'::'lbl) \<le> s + s'"
   by (intro plus_mono[of s s 0 s', simplified] plus_mono[of 0 s s' s', simplified])+
 
 subsection\<open>Paths\<close>
 
 inductive path :: "'vtx \<Rightarrow> 'vtx \<Rightarrow> ('vtx \<times> 'lbl \<times> 'vtx) list \<Rightarrow> bool" where
   path0: "l1 = l2 \<Longrightarrow> path l1 l2 []"
 | path: "path l1 l2 xs \<Longrightarrow> lbl \<in>\<^sub>A weights l2 l3 \<Longrightarrow> path l1 l3 (xs @ [(l2, lbl, l3)])"
 
 inductive_cases path0E: "path l1 l2 []"
 inductive_cases path_AppendE: "path l1 l3 (xs @ [(l2,s,l2')])"
 
 lemma path_trans: "path l1 l2 xs \<Longrightarrow> path l2 l3 ys \<Longrightarrow> path l1 l3 (xs @ ys)"
   by (rotate_tac, induct l2 l3 ys rule: path.induct)
     (auto intro: path.path simp flip: append_assoc)
 
 lemma path_take_from: "path l1 l2 xs \<Longrightarrow> m < length xs \<Longrightarrow> FROM (xs ! m) = l2' \<Longrightarrow> path l1 l2' (take m xs)"
 proof (induct l1 l2 xs rule: path.induct)
   case (path l1 l2 xs lbl l3)
   then show ?case
     apply (unfold take_append)
     apply simp
     apply (cases "l2=l2'")
      apply (metis linorder_not_less nth_append take_all)
     apply (metis case_prod_conv less_Suc_eq nth_append nth_append_length)
     done
 qed simp
 
 lemma path_take_to: "path l1 l2 xs \<Longrightarrow> m < length xs \<Longrightarrow> TO (xs ! m) = l2' \<Longrightarrow> path l1 l2' (take (m+1) xs)"
 proof (induct l1 l2 xs rule: path.induct)
   case (path l1 l2 xs lbl l3)
   then show ?case
     apply (cases "m < length xs")
      apply (simp add: nth_append)
     apply clarsimp
     apply (metis case_prod_conv less_antisym nth_append_length path.path)
     done
 qed simp
 
 lemma path_determines_loc: "path l1 l2 xs \<Longrightarrow> path l1 l3 xs \<Longrightarrow> l2 = l3"
   by (induct l1 l2 xs rule: path.induct) (auto elim: path.cases)
 
 lemma path_first_loc: "path loc loc' xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> FROM (xs ! 0) = loc"
 proof (induct rule: path.induct)
   case (path l1 l2 xs lbl l3)
   then show ?case
     by (auto elim: path0E simp: nth_append)
 qed simp
 
 lemma path_to_eq_from: "path loc1 loc2 xs \<Longrightarrow> i + 1 < length xs \<Longrightarrow> FROM (xs ! (i+1)) = TO (xs ! i)"
 proof (induct rule: path.induct)
   case (path l1 l2 xs lbl l3)
   then show ?case
     apply (cases "i + 1 < length xs")
      apply (simp add: nth_append)
     apply (simp add: nth_append)
     apply (metis add.commute drop_eq_Nil hd_drop_conv_nth id_take_nth_drop linorder_not_less path_determines_loc path_take_to plus_1_eq_Suc take_hd_drop)
     done
 qed simp
 
 lemma path_singleton[intro, simp]: "s \<in>\<^sub>A weights l1 l2 \<Longrightarrow> path l1 l2 [(l1,s,l2)]"
   by (subst path.simps) (auto simp: path.intros)
 
 lemma path_appendE: "path l1 l3 (xs @ ys) \<Longrightarrow> \<exists>l2. path l2 l3 ys \<and> path l1 l2 xs"
 proof (induct l1 l3 "xs@ys" arbitrary: xs ys rule: path.induct)
   case (path0 l1 l2)
   then show ?case by (auto intro: path.intros)
 next
   case (path l1 l2 xs lbl l3 xs' ys')
   from path(1,3-) show ?case
     apply -
     apply (subst (asm) append_eq_append_conv2[of xs "[(l2,lbl,l3)]" xs' ys'])
     apply (elim exE conjE disjE)
     subgoal for us
       using path(2)[of xs' us]
       by (auto intro: path.intros)
     subgoal for us
       by (cases "us=[]") (auto intro: path.intros simp: Cons_eq_append_conv)
     done
 qed
 
 lemma path_replace_prefix:
   "path l1 l3 (xs @ zs) \<Longrightarrow> path l1 l2 ys \<Longrightarrow> path l1 l2 xs \<Longrightarrow> path l1 l3 (ys @ zs)"
   by (drule path_appendE) (auto elim!: path_trans dest: path_determines_loc)
 
 lemma drop_subseq: "n \<le> length xs \<Longrightarrow> drop n xs \<preceq> xs"
   by (auto simp: suffix_def intro!: exI[of _ "take n xs"])
 
 lemma take_subseq[simp, intro]: "take n xs \<preceq> xs"
   by (induct xs) auto
 
 lemma map_take_subseq[simp, intro]: "map f (take n xs) \<preceq> map f xs"
   by (rule subseq_map, induct xs) auto
 
 lemma path_distinct:
   "path l1 l2 xs \<Longrightarrow> \<exists>xs'. distinct xs' \<and> path l1 l2 xs' \<and> map LBL xs' \<preceq> map LBL xs"
 proof (induct rule: path.induct)
   case (path0 l1 l2)
   then show ?case
     by (intro exI[of _ "[]"]) (auto intro: path.intros)
 next
   case (path l1 l2 xs lbl l3)
   then obtain xs' where ih: "path l1 l2 xs'" "distinct xs'" "map LBL xs' \<preceq> map LBL xs"
     by blast
   then show ?case
   proof (cases "(l2, lbl, l3) \<in> set xs'")
     case True
     then obtain m where m: "m < length xs'" "xs' ! m = (l2, lbl, l3)"
       unfolding in_set_conv_nth by blast
     from m ih have "path l1 l2 (take m xs')"
       by (auto intro: path_take_from)
     with m ih path show ?thesis
       apply (intro exI[of _ "take m xs' @ [(l2, lbl, l3)]"])
       apply (rule conjI)
        apply (metis distinct_take take_Suc_conv_app_nth)
       apply (rule conjI)
        apply (rule path.intros)
         apply simp
        apply simp
       apply simp
       apply (metis ih(3) subseq_order.trans take_map take_subseq)
       done
   next
     case False
     with ih path(3) show ?thesis
       by (auto intro!: exI[of _ "xs' @ [(l2, lbl, l3)]"] intro: path.intros)
   qed
 qed
 
 lemma path_edge: "(l1', lbl, l2') \<in> set xs \<Longrightarrow> path l1 l2 xs \<Longrightarrow> lbl \<in>\<^sub>A weights l1' l2'"
   by (rotate_tac, induct rule: path.induct) auto
 
 subsection\<open>Path Weights\<close>
 
 abbreviation sum_weights :: "'lbl list \<Rightarrow> 'lbl" where
   "sum_weights xs \<equiv> foldr (+) xs 0"
 abbreviation "sum_path_weights xs \<equiv> sum_weights (map LBL xs)"
 
 definition "path_weightp l1 l2 s \<equiv> (\<exists>xs. path l1 l2 xs \<and> s = sum_path_weights xs)"
 
 lemma sum_not_less_zero[simp, dest]: "(s::'lbl) < 0 \<Longrightarrow> False"
   by (simp add: less_le_not_le)
 
 lemma sum_le_zero[simp]: "(s::'lbl) \<le> 0 \<longleftrightarrow> s = 0"
   by (simp add: eq_iff)
 
 lemma sum_le_zeroD[dest]: "(x::'lbl) \<le> 0 \<Longrightarrow> x = 0"
   by simp
 
 lemma foldr_plus_mono: "(n::'lbl) \<le> m \<Longrightarrow> foldr (+) xs n \<le> foldr (+) xs m"
   by (induct xs) (auto simp: plus_mono)
 
 lemma sum_weights_append:
   "sum_weights (ys @ xs) = sum_weights ys + sum_weights xs"
   by (induct ys) (auto simp: add.assoc)
 
 lemma sum_summary_prepend_le: "sum_path_weights ys \<le> sum_path_weights xs \<Longrightarrow> sum_path_weights (zs @ ys) \<le> sum_path_weights (zs @ xs)"
   by (induct zs arbitrary: xs ys) (auto intro: plus_mono)
 
 lemma sum_summary_append_le: "sum_path_weights ys \<le> sum_path_weights xs \<Longrightarrow> sum_path_weights (ys @ zs) \<le> sum_path_weights (xs @ zs)"
 proof (induct zs arbitrary: xs ys)
   case (Cons a zs)
   then show ?case
     by (metis plus_mono map_append order_refl sum_weights_append)
 qed simp
 
 lemma foldr_plus_zero_le: "foldr (+) xs (0::'lbl) \<le> foldr (+) xs a"
   by (induct xs) (simp_all add: plus_mono)
 
 lemma subseq_sum_weights_le:
   assumes "xs \<preceq> ys"
   shows "sum_weights xs \<le> sum_weights ys"
   using assms
 proof (induct rule: list_emb.induct)
   case (list_emb_Nil ys)
   then show ?case by auto
 next
   case (list_emb_Cons xs ys y)
   then show ?case by (auto elim!: order_trans simp: le_plus)
 next
   case (list_emb_Cons2 x y xs ys)
   then show ?case by (auto elim!: order_trans simp: plus_mono)
 qed
 
 lemma subseq_sum_path_weights_le:
   "map LBL xs \<preceq> map LBL ys \<Longrightarrow> sum_path_weights xs \<le> sum_path_weights ys"
   by (rule subseq_sum_weights_le)
 
 lemma sum_path_weights_take_le[simp, intro]: "sum_path_weights (take i xs) \<le> sum_path_weights xs"
   by (auto intro!: subseq_sum_path_weights_le)
 
 lemma sum_weights_append_singleton:
   "sum_weights (xs @ [x]) = sum_weights xs + x"
   by (induct xs) (simp_all add: add.assoc)
 
 lemma sum_path_weights_append_singleton:
   "sum_path_weights (xs @ [(l,x,l')]) = sum_path_weights xs + x"
   by (induct xs) (simp_all add: add.assoc)
 
 lemma path_weightp_ex_path:
   "path_weightp l1 l2 s \<Longrightarrow> \<exists>xs.
   (let s' = sum_path_weights xs in s' \<le> s \<and> path_weightp l1 l2 s' \<and> distinct xs \<and>
   (\<forall>(l1,s,l2) \<in> set xs. s \<in>\<^sub>A weights l1 l2))"
   unfolding path_weightp_def
   apply (erule exE conjE)+
   apply (drule path_distinct)
   apply (erule exE conjE)+
   subgoal for xs xs'
     apply (rule exI[of _ xs'])
     apply (auto simp: Let_def dest!: path_edge intro: subseq_sum_path_weights_le)
     done
   done
 
 lemma finite_set_summaries:
   "finite ((\<lambda>((l1,l2),s). (l1,s,l2)) ` (Sigma UNIV (\<lambda>(l1,l2). set_antichain (weights l1 l2))))"
   by force
 
 lemma finite_summaries: "finite {xs. distinct xs \<and> (\<forall>(l1, s, l2) \<in> set xs. s \<in>\<^sub>A weights l1 l2)}"
-  apply (rule finite_subset[OF _ finite_distinct_bounded[of "((\<lambda>((l1,l2),s). (l1,s,l2)) ` (Sigma UNIV (\<lambda>(l1,l2). set_antichain (weights l1 l2))))"]])
+  apply (rule finite_subset[OF _ finite_subset_distinct[of "((\<lambda>((l1,l2),s). (l1,s,l2)) ` (Sigma UNIV (\<lambda>(l1,l2). set_antichain (weights l1 l2))))"]])
    apply (force simp: finite_set_summaries)+
   done
 
 lemma finite_minimal_antichain_path_weightp:
   "finite (minimal_antichain {x. path_weightp l1 l2 x})"
   apply (rule finite_surj[OF finite_summaries, where f = sum_path_weights])
   apply (clarsimp simp: minimal_antichain_def image_iff dest!: path_weightp_ex_path)
   apply (fastforce simp: Let_def)
   done
 
 (* antichain of summaries along cycles-less paths (cycle-less = no edge repeated) *)
 lift_definition path_weight :: "'vtx \<Rightarrow> 'vtx \<Rightarrow> 'lbl antichain"
   is "\<lambda>l1 l2. minimal_antichain {x. path_weightp l1 l2 x}"
   using finite_minimal_antichain_path_weightp
   by auto
 
 definition "reachable l1 l2 \<equiv> path_weight l1 l2 \<noteq> {}\<^sub>A"
 
 lemma in_path_weight: "s \<in>\<^sub>A path_weight loc1 loc2 \<longleftrightarrow> s \<in> minimal_antichain {s. path_weightp loc1 loc2 s}"
   by transfer simp
 
 lemma path_weight_refl[simp]: "0 \<in>\<^sub>A path_weight loc loc"
 proof -
   have *: "path loc loc []"
     by (simp add: path0)
   then have "0 = sum_path_weights []" by auto
   with * have "path_weightp loc loc 0"
     using path_weightp_def by blast
   then show ?thesis
     by (auto simp: in_path_weight in_minimal_antichain)
 qed
 
 lemma zero_in_minimal_antichain[simp]: "(0::'lbl) \<in> S \<Longrightarrow> 0 \<in> minimal_antichain S"
   by (auto simp: in_minimal_antichain intro: sum_not_less_zero)
 
 definition "path_weightp_distinct l1 l2 s \<equiv> (\<exists>xs. distinct xs \<and> path l1 l2 xs \<and> s = sum_path_weights xs)"
 
 lemma minimal_antichain_path_weightp_distinct:
   "minimal_antichain {xs. path_weightp l1 l2 xs} = minimal_antichain {xs. path_weightp_distinct l1 l2 xs}"
   unfolding path_weightp_def path_weightp_distinct_def minimal_antichain_def
   apply safe
      apply clarsimp
      apply (metis path_distinct order.strict_iff_order subseq_sum_path_weights_le)
     apply (blast+) [2]
   apply clarsimp
   apply (metis (no_types, lifting) le_less_trans path_distinct subseq_sum_weights_le)
   done
 
 lemma finite_path_weightp_distinct[simp, intro]: "finite {xs. path_weightp_distinct l1 l2 xs}"
   unfolding path_weightp_distinct_def
   apply (rule finite_subset[where B = "sum_path_weights ` {xs. distinct xs \<and> path l1 l2 xs}"])
    apply clarsimp
   apply (rule finite_imageI)
   apply (rule finite_subset[OF _ finite_summaries])
   apply (clarsimp simp: path_edge)
   done
 
 lemma path_weightp_distinct_nonempty:
   "{xs. path_weightp l1 l2 xs} \<noteq> {} \<longleftrightarrow> {xs. path_weightp_distinct l1 l2 xs} \<noteq> {}"
   by (auto dest: path_distinct simp: path_weightp_def path_weightp_distinct_def)
 
 lemma path_weightp_distinct_member:
   "s \<in> {s. path_weightp l1 l2 s} \<Longrightarrow> \<exists>u. u \<in> {s. path_weightp_distinct l1 l2 s} \<and> u \<le> s"
   apply (clarsimp simp: path_weightp_def path_weightp_distinct_def)
   apply (drule path_distinct)
   apply (auto dest: subseq_sum_path_weights_le)
   done
 
 lemma minimal_antichain_path_weightp_member:
   "s \<in> {xs. path_weightp l1 l2 xs} \<Longrightarrow> \<exists>u. u \<in> minimal_antichain {xs. path_weightp l1 l2 xs} \<and> u \<le> s"
 proof -
   assume "s \<in> {xs. path_weightp l1 l2 xs}"
   then obtain u where u: "u \<in> {s. path_weightp_distinct l1 l2 s} \<and> u \<le> s"
     using path_weightp_distinct_member by blast
   have finite: "finite {xs. path_weightp_distinct l1 l2 xs}" ..
   from u finite obtain v where "v \<in> minimal_antichain {xs. path_weightp_distinct l1 l2 xs} \<and> v \<le> u"
     by atomize_elim (auto intro: minimal_antichain_member)
   with u show ?thesis
     by (auto simp: minimal_antichain_path_weightp_distinct)
 qed
 
 lemma path_path_weight: "path l1 l2 xs \<Longrightarrow> \<exists>s. s \<in>\<^sub>A path_weight l1 l2 \<and> s \<le> sum_path_weights xs"
 proof -
   assume "path l1 l2 xs"
   then have "sum_path_weights xs \<in> {x. path_weightp l1 l2 x}"
     by (auto simp: path_weightp_def)
   then obtain u where "u \<in> minimal_antichain {x. path_weightp l1 l2 x} \<and> u \<le> sum_path_weights xs"
     apply atomize_elim
     apply (drule minimal_antichain_path_weightp_member)
     apply auto
     done
   then show ?thesis
     by transfer auto
 qed
 
 lemma path_weight_conv_path:
   "s \<in>\<^sub>A path_weight l1 l2 \<Longrightarrow> \<exists>xs. path l1 l2 xs \<and> s = sum_path_weights xs \<and> (\<forall>ys. path l1 l2 ys \<longrightarrow> \<not> sum_path_weights ys < sum_path_weights xs)"
   by transfer (auto simp: in_minimal_antichain path_weightp_def)
 
 abbreviation "optimal_path loc1 loc2 xs \<equiv> path loc1 loc2 xs \<and>
    (\<forall>ys. path loc1 loc2 ys \<longrightarrow> \<not> sum_path_weights ys < sum_path_weights xs)"
 
 lemma path_weight_path: "s \<in>\<^sub>A path_weight loc1 loc2 \<Longrightarrow>
   (\<And>xs. optimal_path loc1 loc2 xs \<Longrightarrow> distinct xs \<Longrightarrow> sum_path_weights xs = s \<Longrightarrow> P) \<Longrightarrow> P"
   apply atomize_elim
   apply transfer
   apply (clarsimp simp: in_minimal_antichain path_weightp_def)
   apply (drule path_distinct)
   apply (erule exE)
   subgoal for loc1 loc2 xs xs'
     apply (rule exI[of _ xs'])
     apply safe
     using order.strict_iff_order subseq_sum_path_weights_le apply metis
     using less_le subseq_sum_path_weights_le apply fastforce
     done
   done
 
 lemma path_weight_elem_trans:
   "s \<in>\<^sub>A path_weight l1 l2 \<Longrightarrow> s' \<in>\<^sub>A path_weight l2 l3 \<Longrightarrow> \<exists>u. u \<in>\<^sub>A path_weight l1 l3 \<and> u \<le> s + s'"
 proof -
   assume ps1: "s  \<in>\<^sub>A path_weight l1 l2"
   assume ps2: "s' \<in>\<^sub>A path_weight l2 l3"
   from ps1 obtain xs where path1: "path l1 l2 xs" "s = sum_path_weights xs"
     by (auto intro: path_weight_path)
   from ps2 obtain ys where path2: "path l2 l3 ys" "s' = sum_path_weights ys"
     by (auto intro: path_weight_path)
   from path1(1) path2(1) have "path l1 l3 (xs @ ys)"
     by (rule path_trans)
   with path1(2) path2(2) have "s + s' \<in> {s. path_weightp l1 l3 s}"
     by (auto simp: path_weightp_def sum_weights_append[symmetric])
   then show "\<exists>u. u \<in>\<^sub>A path_weight l1 l3 \<and> u \<le> s + s'"
     by transfer (simp add: minimal_antichain_path_weightp_member)
 qed
 
 end
 
 (*<*)
 end
 (*>*)
\ No newline at end of file
diff --git a/thys/Query_Optimization/IKKBZ_Optimality.thy b/thys/Query_Optimization/IKKBZ_Optimality.thy
--- a/thys/Query_Optimization/IKKBZ_Optimality.thy
+++ b/thys/Query_Optimization/IKKBZ_Optimality.thy
@@ -1,6266 +1,6254 @@
 (* Author: Bernhard Stöckl *)
 
 theory IKKBZ_Optimality
   imports Complex_Main "CostFunctions" "QueryGraph" "IKKBZ" "HOL-Library.Sublist"
 begin
 
 section \<open>Optimality of IKKBZ\<close>
 
 context directed_tree
 begin
 fun forward_arcs :: "'a list \<Rightarrow> bool" where
   "forward_arcs [] = True"
 | "forward_arcs [x] = True"
 | "forward_arcs (x#xs) = ((\<exists>y \<in> set xs. y \<rightarrow>\<^bsub>T\<^esub> x) \<and> forward_arcs xs)"
 
 fun no_back_arcs :: "'a list \<Rightarrow> bool" where
   "no_back_arcs [] = True"
 | "no_back_arcs (x#xs) = ((\<nexists>y. y \<in> set xs \<and> y \<rightarrow>\<^bsub>T\<^esub> x) \<and> no_back_arcs xs)"
 
 definition forward :: "'a list \<Rightarrow> bool" where
   "forward xs = (\<forall>i \<in> {1..(length xs - 1)}. \<exists>j < i. xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i)"
 
 definition no_back :: "'a list \<Rightarrow> bool" where
   "no_back xs = (\<nexists>i j. i < j \<and> j < length xs \<and> xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i)"
 
 definition seq_conform :: "'a list \<Rightarrow> bool" where
   "seq_conform xs \<equiv> forward_arcs (rev xs) \<and> no_back_arcs xs"
 
 definition before :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "before s1 s2 \<equiv> seq_conform s1 \<and> seq_conform s2 \<and> set s1 \<inter> set s2 = {}
     \<and> (\<exists>x \<in> set s1. \<exists>y \<in> set s2. x \<rightarrow>\<^bsub>T\<^esub> y)"
 
 definition before2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "before2 s1 s2 \<equiv> seq_conform s1 \<and> seq_conform s2 \<and> set s1 \<inter> set s2 = {}
     \<and> (\<exists>x \<in> set s1. \<exists>y \<in> set s2. x \<rightarrow>\<^bsub>T\<^esub> y)
     \<and> (\<forall>x \<in> set s1. \<forall>v \<in> verts T - set s1 - set s2. \<not> x \<rightarrow>\<^bsub>T\<^esub> v)"
 
 lemma before_alt1:
   "(\<exists>i < length s1. \<exists>j < length s2. s1!i \<rightarrow>\<^bsub>T\<^esub> s2!j) \<longleftrightarrow> (\<exists>x \<in> set s1. \<exists>y \<in> set s2. x \<rightarrow>\<^bsub>T\<^esub> y)"
   using in_set_conv_nth by metis
 
 lemma before_alt2:
   "(\<forall>i < length s1. \<forall>v \<in> verts T - set s1 - set s2. \<not> s1!i \<rightarrow>\<^bsub>T\<^esub> v)
     \<longleftrightarrow> (\<forall>x \<in> set s1. \<forall>v \<in> verts T  - set s1 - set s2. \<not> x \<rightarrow>\<^bsub>T\<^esub> v)"
   using in_set_conv_nth by metis
 
 lemma no_back_alt_aux: "(\<forall>i j. i \<ge> j \<or> j \<ge> length xs \<or> \<not>(xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i)) \<Longrightarrow> no_back xs"
   using less_le_not_le no_back_def by auto
 
 lemma no_back_alt: "(\<forall>i j. i \<ge> j \<or> j \<ge> length xs \<or> \<not>(xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i)) \<longleftrightarrow> no_back xs"
   using no_back_alt_aux by (auto simp: no_back_def)
 
 lemma no_back_arcs_alt_aux1: "\<lbrakk>no_back_arcs xs; i < j; j < length xs\<rbrakk> \<Longrightarrow> \<not>(xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i)"
 proof(induction xs arbitrary: i j)
   case (Cons x xs)
   then show ?case
   proof(cases "i = 0")
     case True
     then show ?thesis using Cons.prems by simp
   next
     case False
     then show ?thesis using Cons by auto
   qed
 qed(simp)
 
 lemma no_back_insert_aux:
   "(\<forall>i j. i \<ge> j \<or> j \<ge> length (x#xs) \<or> \<not>((x#xs)!j \<rightarrow>\<^bsub>T\<^esub> (x#xs)!i))
     \<Longrightarrow> (\<forall>i j. i \<ge> j \<or> j \<ge> length xs \<or> \<not>(xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i))"
   by force
 
 lemma no_back_insert: "no_back (x#xs) \<Longrightarrow> no_back xs"
   using no_back_alt no_back_insert_aux by blast
 
 lemma no_arc_fst_if_no_back:
   assumes "no_back (x#xs)" and "y \<in> set xs"
   shows "\<not> y \<rightarrow>\<^bsub>T\<^esub> x"
 proof -
   have 0: "(x#xs)!0 = x" by simp
   obtain j where "xs!j = y" "j < length xs" using assms(2) by (auto simp: in_set_conv_nth)
   then have "(x#xs)!(Suc j) = y \<and> Suc j < length (x#xs)" by simp
   then show ?thesis using assms(1) 0 by (metis no_back_def zero_less_Suc)
 qed
 
 lemma no_back_arcs_alt_aux2: "no_back xs \<Longrightarrow> no_back_arcs xs"
   by(induction xs) (auto simp: no_back_insert no_arc_fst_if_no_back)
 
 lemma no_back_arcs_alt: "no_back xs \<longleftrightarrow> no_back_arcs xs"
   using no_back_arcs_alt_aux1 no_back_arcs_alt_aux2 no_back_alt by fastforce
 
 lemma forward_arcs_alt_aux1:
   "\<lbrakk>forward_arcs xs; i \<in> {1..(length (rev xs) - 1)}\<rbrakk> \<Longrightarrow> \<exists>j < i. (rev xs)!j \<rightarrow>\<^bsub>T\<^esub> (rev xs)!i"
 proof(induction xs rule: forward_arcs.induct)
   case (3 x x' xs)
   then show ?case
   proof(cases "i = length (rev (x#x'#xs)) - 1")
     case True
     then have i: "(rev (x#x'#xs))!i = x" by (simp add: nth_append)
     then obtain y where y_def: "y\<in>set (x'#xs)" "y \<rightarrow>\<^bsub>T\<^esub> x" using "3.prems" by auto
     then obtain j where j_def: "rev (x'#xs)!j = y" "j < length (rev (x'#xs))"
       using in_set_conv_nth[of y] by fastforce
     then have "rev (x#x'#xs)!j = y" by (auto simp: nth_append)
     then show ?thesis using y_def(2) i j_def(2) True by auto
   next
     case False
     then obtain j where j_def: "j < i" "rev (x' # xs)!j \<rightarrow>\<^bsub>T\<^esub> rev (x' # xs)!i" using 3 by auto
     then have "rev (x#x'#xs)!j = rev (x'#xs)!j" using "3.prems"(2) by (auto simp: nth_append)
     moreover have "rev (x#x'#xs)!i = rev (x'#xs)!i"
       using "3.prems"(2) False by (auto simp: nth_append)
     ultimately show ?thesis using j_def by auto
   qed
 qed(auto)
 
 lemma forward_split_aux:
   assumes "forward (xs@ys)" and "i\<in>{1..length xs - 1}"
   shows "\<exists>j<i. xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i"
 proof -
   obtain j where "j < i \<and> (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i" using assms forward_def by force
   moreover have "i < length xs" using assms(2) by auto
   ultimately show ?thesis by (auto simp: nth_append)
 qed
 
 lemma forward_split: "forward (xs@ys) \<Longrightarrow> forward xs"
   using forward_split_aux forward_def by blast
 
 lemma forward_cons:
   "forward (rev (x#xs)) \<Longrightarrow> forward (rev xs)"
   using forward_split by simp
 
 lemma arc_to_lst_if_forward:
   assumes "forward (rev (x#xs))" and "xs = y#ys"
   shows "\<exists>y \<in> set xs. y \<rightarrow>\<^bsub>T\<^esub> x"
 proof -
   have "(x#xs)!0 = x" by simp
   have "(rev xs@[x])!(length xs) = (xs@[x])!(length xs)" by (metis length_rev nth_append_length)
   then have i: "rev (x#xs)!(length xs) = x" by simp
   have "length xs \<in> {1..(length (rev (x#xs)) - 1)}" using assms(2) by simp
   then obtain j where j_def: "j < length xs \<and> (rev (x#xs))!j \<rightarrow>\<^bsub>T\<^esub> (rev (x#xs))!length xs"
     using assms(1) forward_def[of "rev (x#xs)"] by blast
   then have "rev xs!j \<in> set xs" using length_rev nth_mem set_rev by metis
   then have "rev (x#xs)!j \<in> set xs" by (auto simp: j_def nth_append)
   then show ?thesis using i j_def by auto
 qed
 
 lemma forward_arcs_alt_aux2: "forward (rev xs) \<Longrightarrow> forward_arcs xs"
 proof(induction xs rule: forward_arcs.induct)
   case (3 x y xs)
   then have "forward_arcs (y # xs)" using forward_cons by blast
   then show ?case using arc_to_lst_if_forward "3.prems" by simp
 qed(auto)
 
 lemma forward_arcs_alt: "forward xs \<longleftrightarrow> forward_arcs (rev xs)"
   using forward_arcs_alt_aux1 forward_arcs_alt_aux2 forward_def by fastforce
 
 corollary forward_arcs_alt': "forward (rev xs) \<longleftrightarrow> forward_arcs xs"
   using forward_arcs_alt by simp
 
 corollary forward_arcs_split: "forward_arcs (ys@xs) \<Longrightarrow> forward_arcs xs"
   using forward_split[of "rev xs" "rev ys"] forward_arcs_alt by simp
 
 lemma seq_conform_alt: "seq_conform xs \<longleftrightarrow> forward xs \<and> no_back xs"
   using forward_arcs_alt no_back_arcs_alt seq_conform_def by simp
 
 lemma forward_app_aux:
   assumes "forward s1" "forward s2" "\<exists>x\<in>set s1. x \<rightarrow>\<^bsub>T\<^esub> hd s2" "i\<in>{1..length (s1@s2) - 1}"
   shows "\<exists>j<i. (s1@s2)!j \<rightarrow>\<^bsub>T\<^esub> (s1@s2)!i"
 proof -
   consider "i\<in>{1..length s1 - 1}" | "i = length s1" | "i\<in>{length s1 + 1..length s1 + length s2 - 1}"
     using assms(4) by fastforce
   then show ?thesis
   proof(cases)
     case 1
     then obtain j where j_def: "j < i" "s1!j \<rightarrow>\<^bsub>T\<^esub> s1!i" using assms(1) forward_def by blast
     moreover have "(s1@s2)!i = s1!i" using 1 by (auto simp: nth_append)
     moreover have "(s1@s2)!j = s1!j" using 1 j_def(1) by (auto simp: nth_append)
     ultimately show ?thesis by auto
   next
     case 2
     then have "s2 \<noteq> []" using assms(4) by force
     then have "(s1@s2)!i = hd s2" using 2 assms(4) by (simp add: hd_conv_nth nth_append)
     then obtain x where x_def: "x\<in>set s1" "x \<rightarrow>\<^bsub>T\<^esub> (s1@s2)!i" using assms(3) by force
     then obtain j where "s1!j = x" "j < length s1" by (auto simp: in_set_conv_nth)
     then show ?thesis using x_def(2) 2 by (auto simp: nth_append)
   next
     case 3
     then have "i-length s1 \<in> {1..length s2 - 1}" by fastforce
     then obtain j where j_def: "j < (i-length s1)" "s2!j \<rightarrow>\<^bsub>T\<^esub> s2!(i-length s1)"
       using assms(2) forward_def by blast
     moreover have "(s1@s2)!i = s2!(i-length s1)" using 3 by (auto simp: nth_append)
     moreover have "(s1@s2)!(j+length s1) = s2!j" using 3 j_def(1) by (auto simp: nth_append)
     ultimately have "(j+length s1) < i \<and> (s1@s2)!(j+length s1) \<rightarrow>\<^bsub>T\<^esub> (s1@s2)!i" by force
     then show ?thesis by blast
   qed
 qed
 
 lemma forward_app: "\<lbrakk>forward s1; forward s2; \<exists>x\<in>set s1. x \<rightarrow>\<^bsub>T\<^esub> hd s2\<rbrakk> \<Longrightarrow> forward (s1@s2)"
   by (simp add: forward_def forward_app_aux)
 
 lemma before_conform1I: "before s1 s2 \<Longrightarrow> seq_conform s1"
   unfolding before_def by blast
 
 lemma before_forward1I: "before s1 s2 \<Longrightarrow> forward s1"
   unfolding before_def seq_conform_alt by blast
 
 lemma before_no_back1I: "before s1 s2 \<Longrightarrow> no_back s1"
   unfolding before_def seq_conform_alt by blast
 
 lemma before_ArcI: "before s1 s2 \<Longrightarrow> \<exists>x \<in> set s1. \<exists>y \<in> set s2. x \<rightarrow>\<^bsub>T\<^esub> y"
   unfolding before_def by blast
 
 lemma before_conform2I: "before s1 s2 \<Longrightarrow> seq_conform s2"
   unfolding before_def by blast
 
 lemma before_forward2I: "before s1 s2 \<Longrightarrow> forward s2"
   unfolding before_def seq_conform_alt by blast
 
 lemma before_no_back2I: "before s1 s2 \<Longrightarrow> no_back s2"
   unfolding before_def seq_conform_alt by blast
 
 lemma hd_reach_all_forward_arcs:
   "\<lbrakk>hd (rev xs) \<in> verts T; forward_arcs xs; x \<in> set xs\<rbrakk> \<Longrightarrow> hd (rev xs) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x"
 proof(induction xs arbitrary: x rule: forward_arcs.induct)
   case (3 z y ys)
   then have 0: "(\<exists>y \<in> set (y#ys). y \<rightarrow>\<^bsub>T\<^esub> z)" "forward_arcs (y#ys)" by auto
   have hd_eq: "hd (rev (z # y # ys)) = hd (rev (y # ys))"
     using hd_rev[of "y#ys"] by (auto simp: last_ConsR)
   then show ?case
   proof(cases "x = z")
     case True
     then obtain x' where x'_def: "x' \<in> set (y#ys)" "x' \<rightarrow>\<^bsub>T\<^esub> x" using "3.prems"(2) by auto
     then have "hd (rev (z # y # ys)) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x'" using 3 hd_eq by simp
     then show ?thesis using x'_def(2) reachable_adj_trans by blast
   next
     case False
     then show ?thesis using 3 hd_eq by simp
   qed
 qed(auto)
 
 lemma hd_reach_all_forward:
   "\<lbrakk>hd xs \<in> verts T; forward xs; x \<in> set xs\<rbrakk> \<Longrightarrow> hd xs \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x"
   using hd_reach_all_forward_arcs[of "rev xs"] by (simp add: forward_arcs_alt)
 
 lemma hd_in_verts_if_forward: "forward (x#y#xs) \<Longrightarrow> hd (x#y#xs) \<in> verts T"
   unfolding forward_def by fastforce
 
 lemma two_elems_if_length_gt1: "length xs > 1 \<Longrightarrow> \<exists>x y ys. x#y#ys=xs"
   by (metis create_ldeep_rev.cases list.size(3) One_nat_def length_Cons less_asym zero_less_Suc)
 
 lemma hd_in_verts_if_forward': "\<lbrakk>length xs > 1; forward xs\<rbrakk> \<Longrightarrow> hd xs \<in> verts T"
   using two_elems_if_length_gt1 hd_in_verts_if_forward by blast
 
 lemma hd_reach_all_forward':
   "\<lbrakk>length xs > 1; forward xs; x \<in> set xs\<rbrakk> \<Longrightarrow> hd xs \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x"
   by (simp add: hd_in_verts_if_forward' hd_reach_all_forward)
 
 lemma hd_reach_all_forward'':
   "\<lbrakk>forward (x#y#xs); z \<in> set (x#y#xs)\<rbrakk> \<Longrightarrow> hd (x#y#xs) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> z"
   using hd_in_verts_if_forward hd_reach_all_forward by blast
 
 lemma no_back_if_distinct_forward: "\<lbrakk>forward xs; distinct xs\<rbrakk> \<Longrightarrow> no_back xs"
 unfolding no_back_def proof
   assume "\<exists>i j. i < j \<and> j < length xs \<and> xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i" and assms: "forward xs" "distinct xs"
   then obtain i j where i_def: "i < j" "j < length xs" "xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i" by blast
   show False
   proof(cases "i=0")
     case True
     then have "xs!i = hd xs" using i_def(1,2) hd_conv_nth[of xs] by fastforce
     then have "xs!i \<rightarrow>\<^sup>*\<^bsub>T\<^esub> xs!j" using i_def(1,2) assms(1) hd_reach_all_forward' by simp
     then have "xs!i \<rightarrow>\<^sup>+\<^bsub>T\<^esub> xs!j" using reachable_neq_reachable1 i_def(3) by force
     then show ?thesis using i_def(3) reachable1_not_reverse by blast
   next
     case False
     then have "i \<in> {1 .. length xs - 1}" using i_def(1,2) by simp
     then obtain j' where j'_def: "j' < i" "xs!j' \<rightarrow>\<^bsub>T\<^esub> xs!i"
       using assms(1) unfolding forward_def by blast
     have "xs!j' = xs!j" using i_def(3) j'_def(2) two_in_arcs_contr by fastforce
     moreover have "xs!j' \<noteq> xs!j"
       using j'_def(1) i_def(1,2) assms(2) nth_eq_iff_index_eq by fastforce
     ultimately show ?thesis by blast
   qed
 qed
 
 corollary seq_conform_if_dstnct_fwd: "\<lbrakk>forward xs; distinct xs\<rbrakk> \<Longrightarrow> seq_conform xs"
   using no_back_if_distinct_forward seq_conform_def forward_arcs_alt no_back_arcs_alt by blast
 
 lemma forward_arcs_single: "forward_arcs [x]"
   by simp
 
 lemma forward_single: "forward [x]"
   unfolding forward_def by simp
 
 lemma no_back_arcs_single: "no_back_arcs [x]"
   by simp
 
 lemma no_back_single: "no_back [x]"
   unfolding no_back_def by simp
 
 lemma seq_conform_single: "seq_conform [x]"
   unfolding seq_conform_def by simp
 
 lemma forward_arc_to_head':
   assumes "forward ys" and "x \<notin> set ys" and "y \<in> set ys" and "x \<rightarrow>\<^bsub>T\<^esub> y"
   shows "y = hd ys"
 proof (rule ccontr)
   assume asm: "y \<noteq> hd ys"
   obtain i where i_def: "i < length ys" "ys!i = y" using assms(3) by (auto simp: in_set_conv_nth)
   then have "i \<noteq> 0" using asm by (metis drop0 hd_drop_conv_nth)
   then have "i \<in> {1..(length ys - 1)}" using i_def(1) by simp
   then obtain j where j_def: "j < i" "ys!j \<rightarrow>\<^bsub>T\<^esub> ys!i"
     using assms(1) forward_def by blast
   then show False using assms(4,2) j_def(2) i_def two_in_arcs_contr by fastforce
 qed
 
 corollary forward_arc_to_head:
   "\<lbrakk>forward ys; set xs \<inter> set ys = {}; x \<in> set xs; y \<in> set ys; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> y = hd ys"
   using forward_arc_to_head' by blast
 
 lemma forward_app':
   "\<lbrakk>forward s1; forward s2; set s1 \<inter> set s2 = {}; \<exists>x\<in>set s1. \<exists>y\<in>set s2. x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> forward (s1@s2)"
   using forward_app[of s1 s2] forward_arc_to_head by blast
 
 lemma reachable1_from_outside_dom:
   "\<lbrakk>x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; x \<notin> set ys; y \<in> set ys\<rbrakk> \<Longrightarrow> \<exists>x'. \<exists>y' \<in> set ys. x' \<notin> set ys \<and> x' \<rightarrow>\<^bsub>T\<^esub> y'"
   by (induction x y rule: trancl.induct) auto
 
 lemma hd_reachable1_from_outside':
   "\<lbrakk>x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; forward ys; x \<notin> set ys; y \<in> set ys\<rbrakk> \<Longrightarrow> \<exists>y' \<in> set ys. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> hd ys"
   apply(induction x y rule: trancl.induct)
   using forward_arc_to_head' by force+
 
 lemma hd_reachable1_from_outside:
   "\<lbrakk>x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; forward ys; set xs \<inter> set ys = {}; x \<in> set xs; y \<in> set ys\<rbrakk>
     \<Longrightarrow> \<exists>y' \<in> set ys. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> hd ys"
   using hd_reachable1_from_outside' by blast
 
 lemma reachable1_append_old_if_arc:
   assumes "\<exists>x\<in>set xs. \<exists>y\<in>set ys. x \<rightarrow>\<^bsub>T\<^esub> y"
       and "z \<notin> set xs"
       and "forward xs"
       and "y\<in>set (xs @ ys)"
       and "z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
   shows "\<exists>y\<in>set ys. z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof(cases "y \<in> set ys")
   case True
   then show ?thesis using assms(5) by blast
 next
   case False
   then have "y \<in> set xs" using assms(4) by simp
   then have 0: "z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> hd xs" using hd_reachable1_from_outside'[OF assms(5,3,2)] by blast
   then have 1: "hd xs \<in> verts T" using reachable1_in_verts(2) by auto
   obtain x y where x_def: "x\<in>set xs" "y\<in>set ys" "x \<rightarrow>\<^bsub>T\<^esub> y" using assms(1) by blast
   then have "hd xs \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x" using hd_reach_all_forward[OF 1 assms(3)] by simp
   then have "hd xs \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y" using x_def(3) by force
   then show ?thesis using reachable1_reachable_trans[OF 0] x_def(2) by blast
 qed
 
 lemma reachable1_append_old_if_arcU:
    "\<lbrakk>\<exists>x\<in>set xs. \<exists>y\<in>set ys. x \<rightarrow>\<^bsub>T\<^esub> y; set U \<inter> set xs = {}; z \<in> set U;
       forward xs; y\<in>set (xs @ ys); z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> \<exists>y\<in>set ys. z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
   using reachable1_append_old_if_arc[of xs ys] by auto
 
 lemma before_arc_to_hd: "before xs ys \<Longrightarrow> \<exists>x \<in> set xs. x \<rightarrow>\<^bsub>T\<^esub> hd ys"
   using forward_arc_to_head before_def seq_conform_alt by auto
 
 lemma no_back_backarc_app1:
   "\<lbrakk>j < length (xs@ys); j \<ge> length xs; i < j; no_back ys; (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i\<rbrakk>
     \<Longrightarrow> i < length xs"
   by (rule ccontr) (auto simp add: no_back_def nth_append)
 
 lemma no_back_backarc_app2: "\<lbrakk>no_back xs; i < j; (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i\<rbrakk> \<Longrightarrow> j \<ge> length xs"
   by (rule ccontr) (auto simp add: no_back_def nth_append)
 
 lemma no_back_backarc_i_in_xs:
   "\<lbrakk>no_back ys; j < length (xs@ys); i < j; (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i\<rbrakk>
     \<Longrightarrow> xs!i \<in> set xs \<and> (xs@ys)!i = xs!i"
   by (auto simp add: no_back_def nth_append)
 
 lemma no_back_backarc_j_in_ys:
   "\<lbrakk>no_back xs; j < length (xs@ys); i < j; (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i\<rbrakk>
     \<Longrightarrow> ys!(j-length xs) \<in> set ys \<and> (xs@ys)!j = ys!(j-length xs)"
   by (auto simp add: no_back_def nth_append)
 
 lemma no_back_backarc_difsets:
   assumes "no_back xs" and "no_back ys"
       and "i < j" and "j < length (xs @ ys)" and "(xs @ ys) ! j \<rightarrow>\<^bsub>T\<^esub> (xs @ ys) ! i"
     shows "\<exists>x \<in> set xs. \<exists>y \<in> set ys. y \<rightarrow>\<^bsub>T\<^esub> x"
   using no_back_backarc_i_in_xs[OF assms(2,4,3)] no_back_backarc_j_in_ys[OF assms(1,4,3)] assms(5)
   by auto
 
 lemma no_back_backarc_difsets':
   "\<lbrakk>no_back xs; no_back ys; \<exists>i j. i < j \<and> j < length (xs@ys) \<and> (xs@ys)!j \<rightarrow>\<^bsub>T\<^esub> (xs@ys)!i\<rbrakk>
     \<Longrightarrow> \<exists>x \<in> set xs. \<exists>y \<in> set ys. y \<rightarrow>\<^bsub>T\<^esub> x"
   using no_back_backarc_difsets by blast
 
 lemma no_back_before_aux:
   assumes "seq_conform xs" and "seq_conform ys"
       and "set xs \<inter> set ys = {}" and "(\<exists>x\<in>set xs. \<exists>y\<in>set ys. x \<rightarrow>\<^bsub>T\<^esub> y)"
     shows "no_back (xs @ ys)"
   unfolding no_back_def by (metis assms adj_in_verts(2) forward_arc_to_head hd_reach_all_forward
     inf_commute reachable1_not_reverse reachable_rtranclI rtrancl_into_trancl1 seq_conform_alt
     no_back_backarc_difsets')
 
 lemma no_back_before: "before xs ys \<Longrightarrow> no_back (xs@ys)"
   using before_def no_back_before_aux by simp
 
 lemma seq_conform_if_before: "before xs ys \<Longrightarrow> seq_conform (xs@ys)"
   using no_back_before before_def seq_conform_alt forward_app before_arc_to_hd by simp
 
 lemma no_back_arc_if_fwd_dstct:
   assumes "forward (as@bs)" and "distinct (as@bs)"
   shows "\<not>(\<exists>x\<in>set bs. \<exists>y\<in>set as. x \<rightarrow>\<^bsub>T\<^esub> y)"
 proof
   assume "\<exists>x\<in>set bs. \<exists>y\<in>set as. x \<rightarrow>\<^bsub>T\<^esub> y"
   then obtain x y where x_def: "x\<in>set bs" "y\<in>set as" "x \<rightarrow>\<^bsub>T\<^esub> y" by blast
   then obtain i where i_def: "as!i = y" "i < length as" by (auto simp: in_set_conv_nth)
   obtain j where j_def: "bs!j = x" "j < length bs" using x_def(1) by (auto simp: in_set_conv_nth)
   then have "(as@bs)!(j+length as) = x" by (simp add: nth_append)
   moreover have "(as@bs)!i = y" using i_def by (simp add: nth_append)
   moreover have "i < (j+length as)" using i_def(2) by simp
   moreover have "(j+length as) < length (as @ bs)" using j_def by simp
   ultimately show False
     using no_back_if_distinct_forward[OF assms] x_def(3) unfolding no_back_def by blast
 qed
 
 lemma no_back_reach1_if_fwd_dstct:
   assumes "forward (as@bs)" and "distinct (as@bs)"
   shows "\<not>(\<exists>x\<in>set bs. \<exists>y\<in>set as. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
 proof
   assume "\<exists>x\<in>set bs. \<exists>y\<in>set as. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
   then obtain x y where x_def: "x\<in>set bs" "y\<in>set as" "x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y" by blast
   have fwd_as: "forward as" using forward_split[OF assms(1)] by blast
   have x_as: "x \<notin> set as" using x_def(1) assms(2) by auto
   show False
   using assms(1) x_def append.assoc list.distinct(1) Nil_is_append_conv append_Nil2[of "as@bs"]
       append_eq_append_conv2[of "as@bs" "as@bs" bs as] forward_arc_to_head' hd_append2
       hd_reach_all_forward hd_reachable1_from_outside'[OF x_def(3) fwd_as x_as x_def(2)]
       in_set_conv_decomp_first[of y as] in_set_conv_decomp_last reachable1_from_outside_dom
       reachable1_in_verts(2) reachable1_not_reverse reachable1_reachable_trans
   by metis
 qed
 
 lemma split_length_i: "i \<le> length bs \<Longrightarrow> \<exists>xs ys. xs@ys = bs \<and> length xs = i"
   using length_take append_take_drop_id min_absorb2 by metis
 
 lemma split_length_i_prefix:
   assumes "length as \<le> i" "i < length (as@bs)"
   shows "\<exists>xs ys. xs@ys = bs \<and> length (as@xs) = i"
 proof -
   obtain n where n_def: "n + length as = i"
     using assms(1) ab_semigroup_add_class.add.commute le_Suc_ex by blast
   then have "n \<le> length bs" using assms(2) by simp
   then show ?thesis using split_length_i n_def by fastforce
 qed
 
 lemma forward_alt_aux1:
   assumes "i \<in> {1..length xs - 1}" and "j<i" and "xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i"
   shows "\<exists>as bs. as@bs = xs \<and> length as = i \<and> (\<exists>x \<in> set as. x \<rightarrow>\<^bsub>T\<^esub> xs!i)"
 proof -
   obtain as bs where "as@bs = xs \<and> length as = i"
     using assms(1) atLeastAtMost_iff diff_le_self le_trans split_length_i[of i xs] by metis
   then show ?thesis using assms(2,3) nth_append[of as bs j] by force
 qed
 
 lemma forward_alt_aux1':
   "forward xs
     \<Longrightarrow> \<forall>i \<in> {1..length xs - 1}. \<exists>as bs. as@bs = xs \<and> length as = i \<and> (\<exists>x \<in> set as. x \<rightarrow>\<^bsub>T\<^esub> xs!i)"
   using forward_alt_aux1 unfolding forward_def by fastforce
 
 lemma forward_alt_aux2:
   "\<lbrakk>as@bs = xs; length as = i; \<exists>x \<in> set as. x \<rightarrow>\<^bsub>T\<^esub> xs!i\<rbrakk> \<Longrightarrow> \<exists>j<i. xs!j \<rightarrow>\<^bsub>T\<^esub> xs!i"
   by (auto simp add: nth_append in_set_conv_nth)
 
 lemma forward_alt_aux2':
   "\<forall>i \<in> {1..length xs - 1}. \<exists>as bs. as@bs = xs \<and> length as = i \<and> (\<exists>x \<in> set as. x \<rightarrow>\<^bsub>T\<^esub> xs!i)
     \<Longrightarrow> forward xs"
   using forward_alt_aux2 unfolding forward_def by blast
 
 corollary forward_alt:
   "\<forall>i \<in> {1..length xs - 1}. \<exists>as bs. as@bs = xs \<and> length as = i \<and> (\<exists>x \<in> set as. x \<rightarrow>\<^bsub>T\<^esub> xs!i)
     \<longleftrightarrow> forward xs"
   using forward_alt_aux1'[of xs] forward_alt_aux2' by blast
 
 lemma move_mid_forward_if_noarc_aux:
   assumes "as \<noteq> []"
       and "\<not>(\<exists>x \<in> set U. \<exists>y \<in> set bs. x \<rightarrow>\<^bsub>T\<^esub> y)"
       and "forward (as@U@bs@cs)"
       and "i \<in> {1..length (as@bs@U@cs) - 1}"
     shows "\<exists>j<i. (as@bs@U@cs) ! j \<rightarrow>\<^bsub>T\<^esub> (as@bs@U@cs) ! i"
 proof -
   have 0: "i \<in> {1..length (as@U@bs@cs) - 1}" using assms(4) by auto
   consider "i < length as" | "i \<in> {length as..length (as@bs) - 1}"
     | "i \<in> {length (as@bs)..length (as@bs@U) - 1}"
     | "i \<ge> length (as@bs@U)"
     by fastforce
   then show ?thesis
   proof(cases)
     case 1
     then have "(as@U@bs@cs)!i = (as@bs@U@cs)!i" by (simp add: nth_append)
     then obtain j where j_def: "j<i" "(as@U@bs@cs)!j \<rightarrow>\<^bsub>T\<^esub> ((as@bs)@U@cs)!i"
       using assms(3) 0 unfolding forward_def by fastforce
     then have "(as@U@bs@cs)!j = ((as@bs)@U@cs)!j" using 1 by (simp add: nth_append)
     then show ?thesis using j_def by auto
   next
     case 2
     have "((as@bs)@U@cs)!i = bs!(i - length as)"
       using 2 assms(4) nth_append root_in_T directed_tree_axioms in_degree_root_zero
       by (metis directed_tree.in_deg_one_imp_not_root atLeastAtMost_iff diff_diff_cancel
           diff_is_0_eq diff_le_self diff_less_mono neq0_conv zero_less_diff)
     then have i_in_bs: "((as@bs)@U@cs)!i \<in> set bs" using assms(4) 2 by auto
     have "(i - length as) < length bs" using 2 assms(4) by force
     then have "((as@bs)@U@cs)!i = (as@U@bs@cs)!(i + length U)"
       using 2 by (auto simp: nth_append)
     moreover have "(i + length U) \<in> {1.. length (as@U@bs@cs) - 1}" using 2 0 by force
     ultimately obtain j where j_def:
         "j < (i + length U)" "(as@U@bs@cs)!j \<rightarrow>\<^bsub>T\<^esub> ((as@bs)@U@cs)!i"
       using assms(3) unfolding forward_def by fastforce
     have "i < length (as@bs)" using \<open>i - length as < length bs\<close> by force
     moreover have "length as \<le> i" using 2 by simp
     ultimately obtain xs ys where xs_def: "bs = xs@ys" "length (as@xs) = i"
       using split_length_i_prefix by blast
     then have "j < (length (as@U@xs))" using 2 j_def(1) by simp
     then have "(as@U@bs@cs)!j \<in> set (as@U@xs)" by (auto simp: xs_def(1) nth_append)
     then have "(as@U@bs@cs)!j \<in> set (as@xs)" using assms(2) j_def(2) i_in_bs by auto
     then obtain j' where j'_def: "j' < length (as@xs)" "(as@xs)!j' = (as@U@bs@cs)!j"
       using in_set_conv_nth[of "(as@U@bs@cs)!j"] nth_append by blast
     then have "((as@bs)@U@cs)!j' = (as@U@bs@cs)!j"
       using nth_append[of "as@xs"] xs_def(1) by simp
     then show ?thesis using j_def(2) j'_def(1) xs_def(2) by force
   next
     case 3
     then have i_len_U: "i - length (as@bs) < length U" using assms(4) by fastforce
     have i_len_asU: "i - length bs < length (as@U)" using 3 assms(4) by force
     have "((as@bs)@U@cs)!i = (U@cs)!(i - length (as@bs))"
       using 3 by (auto simp: nth_append)
     also have "\<dots> = (as@U)!(i - length bs)"
       using 3 i_len_U by (auto simp: ab_semigroup_add_class.add.commute nth_append)
     also have "\<dots> = (as@U@bs@cs)!(i - length bs)"
       using i_len_asU nth_append[of "as@U"] by simp
     finally have 1: "((as@bs)@U@cs)!i = (as@U@bs@cs)!(i - length bs)" .
     have "(i - length bs) \<ge> length as" using 3 by auto
     then have "(i - length bs) \<ge> 1" using assms(1) length_0_conv[of as] by force
     then have "(i - length bs) \<in> {1.. length (as@U@bs@cs) - 1}" using 0 by auto
     then obtain j where j_def: "j < (i - length bs)" "(as@U@bs@cs)!j \<rightarrow>\<^bsub>T\<^esub> ((as@bs)@U@cs)!i"
       using assms(3) 1 unfolding forward_def by fastforce
     have "length as \<le> (i - length bs)" using 3 by auto
     then obtain xs ys where xs_def: "U = xs@ys" "length (as@xs) = (i - length bs)"
       using split_length_i_prefix[of as] i_len_asU by blast
     then have "j < (length (as@xs))" using 3 j_def(1) by simp
     then have "(as@U@bs@cs)!j \<in> set (as@bs@xs)" by (auto simp: xs_def(1) nth_append)
     then obtain j' where j'_def: "j' < length (as@bs@xs)" "(as@bs@xs)!j' = (as@U@bs@cs)!j"
       using in_set_conv_nth[of "(as@U@bs@cs)!j"] by blast
     then have "((as@bs)@U@cs)!j' = (as@U@bs@cs)!j"
       using nth_append[of "as@bs@xs"] xs_def(1) by simp
     moreover have "j' < i" using j'_def(1) xs_def(2) 3 by auto
     ultimately show ?thesis using j_def(2) by force
   next
     case 4
     have len_eq: "length (as@U@bs) = length (as@bs@U)" by simp
     have "((as@bs)@U@cs)!i = cs!(i - length (as@bs@U))"
       using 4 nth_append[of "as@bs@U"] by simp
     also have "\<dots> = cs!(i - length (as@U@bs))" using len_eq by argo
     finally have "((as@bs)@U@cs)!i = ((as@U@bs)@cs)!i" using 4 nth_append[of "as@U@bs"] by simp
     then obtain j where j_def: "j < i" "(as@U@bs@cs)!j \<rightarrow>\<^bsub>T\<^esub> ((as@bs)@U@cs)!i"
       using assms(3) 0 unfolding forward_def by fastforce
     have "length (as@U@bs) \<le> i" using 4 by auto
     moreover have "i < length ((as@U@bs)@cs)" using 0 by auto
     ultimately obtain xs ys where xs_def: "xs@ys = cs" "length ((as@U@bs) @ xs) = i"
       using split_length_i_prefix[of "as@U@bs" i] by blast
     then have "j < (length (as@U@bs@xs))" using 4 j_def(1) by simp
     then have "(as@U@bs@cs)!j \<in> set (as@bs@U@xs)" by (auto simp: xs_def(1)[symmetric] nth_append)
     then obtain j' where j'_def: "j' < length (as@bs@U@xs)" "(as@bs@U@xs)!j' = (as@U@bs@cs)!j"
       using in_set_conv_nth[of "(as@U@bs@cs)!j"] by blast
     then have "((as@bs)@U@cs)!j' = (as@U@bs@cs)!j"
       using nth_append[of "as@bs@U@xs"] xs_def(1)[symmetric] by simp
     moreover have "j' < i" using j'_def(1) xs_def(2) 4 by auto
     ultimately show ?thesis using j_def(2) by auto
   qed
 qed
 
 lemma move_mid_forward_if_noarc:
   "\<lbrakk>as \<noteq> []; \<not>(\<exists>x \<in> set U. \<exists>y \<in> set bs. x \<rightarrow>\<^bsub>T\<^esub> y); forward (as@U@bs@cs)\<rbrakk>
     \<Longrightarrow> forward (as@bs@U@cs)"
   using move_mid_forward_if_noarc_aux unfolding forward_def by blast
 
 lemma move_mid_backward_if_noarc_aux:
   assumes "\<exists>x\<in>set U. x \<rightarrow>\<^bsub>T\<^esub> hd V"
       and "forward V"
       and "forward (as@U@bs@V@cs)"
       and "i \<in> {1..length (as@U@V@bs@cs) - 1}"
     shows "\<exists>j<i. (as@U@V@bs@cs) ! j \<rightarrow>\<^bsub>T\<^esub> (as@U@V@bs@cs) ! i"
 proof -
   have 0: "i \<in> {1..length (as@U@bs@V@cs) - 1}" using assms(4) by auto
   consider "i < length (as@U)" | "i = length (as@U)" "i \<le> length (as@U@V) - 1"
     | "i \<in> {length (as@U) + 1..length (as@U@V) - 1}"
     | "i \<in> {length (as@U@V)..length (as@U@V@bs) - 1}"
     | "i \<ge> length (as@U@V@bs)"
     by fastforce
   then show ?thesis
   proof(cases)
     case 1
     then have "(as@U@bs@V@cs)!i = (as@U@V@bs@cs)!i" by (simp add: nth_append)
     then obtain j where j_def: "j<i" "(as@U@bs@V@cs)!j \<rightarrow>\<^bsub>T\<^esub> (as@U@V@bs@cs)!i"
       using assms(3) 0 unfolding forward_def by fastforce
     then have "(as@U@V@bs@cs)!j = (as@U@bs@V@cs)!j" using 1 by (simp add: nth_append)
     then show ?thesis using j_def by auto
   next
     case 2
     have "(as@U@V@bs@cs)!i = (V@bs@cs)!0" using 2(1) by (auto simp: nth_append)
     then have "(as@U@V@bs@cs)!i = hd V"
       using 2 assms(4) hd_append hd_conv_nth Suc_n_not_le_n atLeastAtMost_iff le_diff_conv2
       by (metis ab_semigroup_add_class.add.commute append.right_neutral Suc_eq_plus1_left)
     then obtain x where x_def: "x \<in> set U" "x \<rightarrow>\<^bsub>T\<^esub> (as@U@V@bs@cs)!i" using assms(1) by auto
     then obtain j where j_def: "(as@U)!j = x" "j < i" using in_set_conv_nth[of x] 2 by fastforce
     then have "(as@U@V@bs@cs)!j = x" using 2(1) by (auto simp: nth_append)
     then show ?thesis using j_def(2) x_def(2) by blast
   next
     case 3
     have "i - length (as@U) \<in> {1 .. length V - 1}" using 3 by force
     then obtain j where j_def: "j < (i - length (as@U))" "V!j \<rightarrow>\<^bsub>T\<^esub> V!(i - length (as@U))"
       using assms(2) unfolding forward_def by blast
     then have "(as@U@V@bs@cs)!(j+length (as@U)) = V!j"
       using 3 nth_append[of "as@U"] nth_append[of V] by auto
     moreover have "(as@U@V@bs@cs)!i = V!(i - length (as@U))"
       using 3 nth_append[of "as@U"] nth_append[of V] by auto
     moreover have "j+length (as@U) < i" using j_def(1) by simp
     ultimately show ?thesis using j_def(2) by auto
   next
     case 4
     have "(as@U@V@bs@cs)!i = (bs@cs)!(i - length (as@U@V))" using 4 nth_append[of "as@U@V"] by simp
     also have "\<dots> = bs!(i - length (as@U@V))" using 4 assms(4) by (auto simp: nth_append)
     also have "\<dots> = (as@U@bs)!(i - length (as@U@V) + length (as@U))" by (simp add: nth_append)
     also have "\<dots> = (as@U@bs)!(i - length V)" using 4 by simp
     finally have 1: "(as@U@V@bs@cs)!i = (as@U@bs@V@cs)!(i - length V)"
       using 4 assms(4) nth_append[of "as@U@bs"] by auto
     have "(i - length V) \<ge> length (as@U)" using 4 by auto
     then have "(i - length V) \<ge> 1" using assms(1) length_0_conv by fastforce
     then have "(i - length V) \<in> {1.. length (as@U@bs@V@cs) - 1}" using 0 by auto
     then obtain j where j_def: "j < i - length V" "(as@U@bs@V@cs)!j \<rightarrow>\<^bsub>T\<^esub> (as@U@V@bs@cs)!i"
       using assms(3) 1 unfolding forward_def by fastforce
     have "length (as@U) \<le> (i - length V)" using 4 by fastforce
     moreover have "(i - length V) < length ((as@U)@bs)" using 4 assms(4) by auto
     ultimately obtain xs ys where xs_def: "xs@ys = bs" "length ((as@U)@ xs) = i - length V"
       using split_length_i_prefix[of "as@U"] by blast
     then have "j < (length (as@U@xs))" using 4 j_def(1) by simp
     then have "(as@U@bs@V@cs)!j \<in> set (as@U@V@xs)" by (auto simp: xs_def(1)[symmetric] nth_append)
     then obtain j' where j'_def: "j' < length (as@U@V@xs)" "(as@U@V@xs)!j' = (as@U@bs@V@cs)!j"
       using in_set_conv_nth[of "(as@U@bs@V@cs)!j"] by blast
     then have "(as@U@V@bs@cs)!j' = (as@U@bs@V@cs)!j"
       using nth_append[of "as@U@V@xs"] xs_def(1) by auto
     moreover have "j' < i" using j'_def(1) xs_def(2) 4 by auto
     ultimately show ?thesis using j_def(2) by auto
   next
     case 5
     have len_eq: "length (as@U@bs@V) = length (as@U@V@bs)" by simp
     have "(as@U@V@bs@cs)!i = cs!(i - length (as@U@V@bs))"
       using 5 nth_append[of "as@U@V@bs"] by auto
     also have "\<dots> = cs!(i - length (as@U@bs@V))" using len_eq by argo
     finally have "(as@U@V@bs@cs)!i = ((as@U@bs@V)@cs)!i"
       using 5 nth_append[of "as@U@bs@V"] by simp
     then obtain j where j_def: "j < i" "(as@U@bs@V@cs)!j \<rightarrow>\<^bsub>T\<^esub> (as@U@V@bs@cs)!i"
       using assms(3) 0 unfolding forward_def by fastforce
     have "length (as@U@bs@V) \<le> i" using 5 by auto
     moreover have "i < length ((as@U@bs@V)@cs)" using 0 by auto
     ultimately obtain xs ys where xs_def: "xs@ys = cs" "length ((as@U@bs@V) @ xs) = i"
       using split_length_i_prefix[of "as@U@bs@V" i] by blast
     then have "j < (length (as@U@bs@V@xs))" using 5 j_def(1) by simp
     then have "(as@U@bs@V@cs)!j \<in> set (as@U@V@bs@xs)"
       by (auto simp: xs_def(1)[symmetric] nth_append)
     then obtain j' where j'_def: "j' < length (as@U@V@bs@xs)" "(as@U@V@bs@xs)!j' = (as@U@bs@V@cs)!j"
       using in_set_conv_nth[of "(as@U@bs@V@cs)!j"] by blast
     then have "(as@U@V@bs@cs)!j' = (as@U@bs@V@cs)!j"
       using nth_append[of "as@U@V@bs@xs"] xs_def(1) by force
     moreover have "j' < i" using j'_def(1) xs_def(2) 5 by auto
     ultimately show ?thesis using j_def(2) by auto
   qed
 qed
 
 lemma move_mid_backward_if_noarc:
   "\<lbrakk>before U V; forward (as@U@bs@V@cs)\<rbrakk> \<Longrightarrow> forward (as@U@V@bs@cs)"
   using before_forward2I
   by (simp add: forward_def before_arc_to_hd move_mid_backward_if_noarc_aux)
 
 lemma move_mid_backward_if_noarc':
   "\<lbrakk>\<exists>x\<in>set U. \<exists>y\<in>set V. x \<rightarrow>\<^bsub>T\<^esub> y; forward V; set U \<inter> set V = {}; forward (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> forward (as@U@V@bs@cs)"
   using move_mid_backward_if_noarc_aux[of U V as bs cs] forward_arc_to_head[of V U] forward_def
   by blast
 
 end
 
 subsection \<open>Sublist Additions\<close>
 
 lemma fst_sublist_if_not_snd_sublist:
   "\<lbrakk>xs@ys=A@B; \<not> sublist B ys\<rbrakk> \<Longrightarrow> \<exists>as bs. as @ bs = xs \<and> bs @ ys = B"
   by (metis suffix_append suffix_def suffix_imp_sublist)
 
 lemma sublist_before_if_mid:
   assumes "sublist U (A@V)" and "A @ V @ B = xs" and "set U \<inter> set V = {}" and "U\<noteq>[]"
   shows "\<exists>as bs cs. as @ U @ bs @ V @ cs = xs"
 proof -
   obtain C D where C_def: "(C @ U) @ D = A @ V" using assms(1) by (auto simp: sublist_def)
   have "sublist V D"
     using assms(3,4) fst_sublist_if_not_snd_sublist[OF C_def] disjoint_iff_not_equal last_appendR
     by (metis Int_iff Un_Int_eq(1) append_Nil2 append_self_conv2 set_append last_in_set sublist_def)
   then show ?thesis using assms(2) C_def sublist_def append.assoc by metis
 qed
 
 lemma list_empty_if_subset_dsjnt: "\<lbrakk>set xs \<subseteq> set ys; set xs \<inter> set ys = {}\<rbrakk> \<Longrightarrow> xs = []"
   using semilattice_inf_class.inf.orderE by fastforce
 
 lemma empty_if_sublist_dsjnt: "\<lbrakk>sublist xs ys; set xs \<inter> set ys = {}\<rbrakk> \<Longrightarrow> xs = []"
   using set_mono_sublist list_empty_if_subset_dsjnt by fast
 
 lemma sublist_snd_if_fst_dsjnt:
   assumes "sublist U (V@B)" and "set U \<inter> set V = {}"
   shows "sublist U B"
 proof -
   consider "sublist U V" | "sublist U B" | "(\<exists>xs1 xs2. U = xs1@xs2 \<and> suffix xs1 V \<and> prefix xs2 B)"
     using assms(1) sublist_append by blast
   then show ?thesis
   proof(cases)
     case 1
     then show ?thesis using assms(2) empty_if_sublist_dsjnt by blast
   next
     case 2
     then show ?thesis by simp
   next
     case 3
     then obtain xs ys where xs_def: "U = xs@ys" "suffix xs V" "prefix ys B" by blast
     then have "set xs \<subseteq> set V" by (simp add: set_mono_suffix)
     then have "xs = []" using xs_def(1) assms(2) list_empty_if_subset_dsjnt by fastforce
     then show ?thesis using xs_def(1,3) by simp
   qed
 qed
 
 lemma sublist_fst_if_snd_dsjnt:
   assumes "sublist U (B@V)" and "set U \<inter> set V = {}"
   shows "sublist U B"
 proof -
   consider "sublist U V" | "sublist U B" | "(\<exists>xs1 xs2. U = xs1@xs2 \<and> suffix xs1 B \<and> prefix xs2 V)"
     using assms(1) sublist_append by blast
   then show ?thesis
   proof(cases)
     case 1
     then show ?thesis using assms(2) empty_if_sublist_dsjnt by blast
   next
     case 2
     then show ?thesis by simp
   next
     case 3
     then obtain xs ys where xs_def: "U = xs@ys" "suffix xs B" "prefix ys V" by blast
     then have "set ys \<subseteq> set V" by (simp add: set_mono_prefix)
     then have "ys = []" using xs_def(1) assms(2) list_empty_if_subset_dsjnt by fastforce
     then show ?thesis using xs_def(1,2) by simp
   qed
 qed
 
 lemma sublist_app: "sublist (A @ B) C \<Longrightarrow> sublist A C \<and> sublist B C"
   using sublist_order.dual_order.trans by blast
 
 lemma sublist_Cons: "sublist (A # B) C \<Longrightarrow> sublist [A] C \<and> sublist B C"
   using sublist_app[of "[A]"] by simp
 
 lemma sublist_set_elem: "\<lbrakk>sublist xs (A@B); x \<in> set xs\<rbrakk> \<Longrightarrow> x \<in> set A \<or> x \<in> set B"
   using set_mono_sublist by fastforce
 
 lemma subset_snd_if_hd_notin_fst:
   assumes "sublist ys (V @ B)" and "hd ys \<notin> set V" and "ys \<noteq> []"
   shows "set ys \<subseteq> set B"
 proof -
   have "\<not> sublist ys V" using assms(2,3) by(auto simp: sublist_def)
   then consider "sublist ys B" | "(\<exists>xs1 xs2. ys = xs1@xs2 \<and> suffix xs1 V \<and> prefix xs2 B)"
     using assms(1) sublist_append by blast
   then show ?thesis
   proof(cases)
     case 1
     then show ?thesis using set_mono_sublist by blast
   next
     case 2
     then obtain xs zs where xs_def: "ys = xs@zs" "suffix xs V" "prefix zs B" by blast
     then have "set xs \<subseteq> set V" by (simp add: set_mono_suffix)
     then have "xs = []" using xs_def(1) assms(2,3) hd_append hd_in_set subsetD by fastforce
     then show ?thesis using xs_def(1,3) by (simp add: set_mono_prefix)
   qed
 qed
 
 lemma suffix_ndjsnt_snd_if_nempty: "\<lbrakk>suffix xs (A@V); V \<noteq> []; xs \<noteq> []\<rbrakk> \<Longrightarrow> set xs \<inter> set V \<noteq> {}"
   using empty_if_sublist_dsjnt disjoint_iff
   by (metis sublist_append_leftI suffix_append suffix_imp_sublist)
 
 lemma sublist_not_mid:
   assumes "sublist U ((A @ V) @ B)" and "set U \<inter> set V = {}" and "V \<noteq> []"
   shows "sublist U A \<or> sublist U B"
 proof -
   consider "sublist U A" | "sublist U V" | "(\<exists>xs1 xs2. U = xs1@xs2 \<and> suffix xs1 A \<and> prefix xs2 V)"
      | "sublist U B" | "(\<exists>xs1 xs2. U = xs1@xs2 \<and> suffix xs1 (A@V) \<and> prefix xs2 B)"
     using assms(1) sublist_append by metis
   then show ?thesis
   proof(cases)
     case 2
     then show ?thesis using assms(2) empty_if_sublist_dsjnt by blast
   next
     case 3
     then show ?thesis using assms(2) sublist_append sublist_fst_if_snd_dsjnt by blast
   next
     case 5
     then obtain xs ys where xs_def: "U = xs@ys" "suffix xs (A@V)" "prefix ys B" by blast
     then have "set xs \<inter> set V \<noteq> {} \<or> xs = []" using suffix_ndjsnt_snd_if_nempty assms(3) by blast
     then have "xs = []" using xs_def(1) assms(2) by auto
     then show ?thesis using xs_def(1,3) by simp
   qed(auto)
 qed
 
 lemma sublist_Y_cases_UV:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "U \<in> Y"
       and "V \<in> Y"
       and "U \<noteq> []"
       and "V \<noteq> []"
       and "(\<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs))"
       and "xs \<in> Y"
     shows "sublist xs as \<or> sublist xs bs \<or> sublist xs cs \<or> U = xs \<or> V = xs"
   using assms append_assoc sublist_not_mid by metis
 
 lemma sublist_behind_if_nbefore:
   assumes "sublist U xs" "sublist V xs" "\<nexists>as bs cs. as @ U @ bs @ V @ cs = xs" "set U \<inter> set V = {}"
   shows "\<exists>as bs cs. as @ V @ bs @ U @ cs = xs"
 proof -
   have "V \<noteq> []" using assms(1,3) unfolding sublist_def by blast
   obtain A B where A_def: "A @ V @ B = xs" using assms(2) by (auto simp: sublist_def)
   then have "\<not>sublist U A" unfolding sublist_def using assms(3) by fastforce
   moreover have "sublist U ((A @ V) @ B)" using assms(1) A_def by simp
   ultimately have "sublist U B" using assms(4) sublist_not_mid \<open>V\<noteq>[]\<close> by blast
   then show ?thesis unfolding sublist_def using A_def by blast
 qed
 
 lemma sublists_preserv_move_U:
   "\<lbrakk>set xs \<inter> set U = {}; set xs \<inter> set V = {}; V\<noteq>[]; sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> sublist xs (as@bs@U@V@cs)"
   using append_assoc self_append_conv2 sublist_def sublist_not_mid by metis
 
 lemma sublists_preserv_move_UY:
   "\<lbrakk>\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}; xs \<in> Y; U \<in> Y; V \<in> Y;
     V \<noteq> []; sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> sublist xs (as@bs@U@V@cs)"
   using sublists_preserv_move_U append_assoc sublist_appendI by metis
 
 lemma sublists_preserv_move_UY_all:
   "\<lbrakk>\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}; U \<in> Y; V \<in> Y;
     V \<noteq> []; \<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> \<forall>xs \<in> Y. sublist xs (as@bs@U@V@cs)"
   using sublists_preserv_move_UY[of Y] by simp
 
 lemma sublists_preserv_move_V:
   "\<lbrakk>set xs \<inter> set U = {}; set xs \<inter> set V = {}; U\<noteq>[]; sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> sublist xs (as@U@V@bs@cs)"
   using append_assoc self_append_conv2 sublist_def sublist_not_mid by metis
 
 lemma sublists_preserv_move_VY:
   "\<lbrakk>\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}; xs \<in> Y; U \<in> Y; V \<in> Y;
     U \<noteq> []; sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> sublist xs (as@U@V@bs@cs)"
   using sublists_preserv_move_V append_assoc sublist_appendI by metis
 
 lemma sublists_preserv_move_VY_all:
   "\<lbrakk>\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}; U \<in> Y; V \<in> Y;
     U \<noteq> []; \<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)\<rbrakk>
     \<Longrightarrow> \<forall>xs \<in> Y. sublist xs (as@U@V@bs@cs)"
   using sublists_preserv_move_VY[of Y] by simp
 
 lemma distinct_sublist_first:
   "\<lbrakk>sublist as (x#xs); distinct (x#xs); x \<in> set as\<rbrakk> \<Longrightarrow> take (length as) (x#xs) = as"
   unfolding sublist_def using distinct_app_trans_l distinct_ys_not_xs hd_in_set
   by (metis list.sel(1) append_assoc append_eq_conv_conj append_self_conv2 hd_append2)
 
 lemma distinct_sublist_first_remainder:
   "\<lbrakk>sublist as (x#xs); distinct (x#xs); x \<in> set as\<rbrakk> \<Longrightarrow> as @ drop (length as) (x#xs) = x#xs"
   using distinct_sublist_first append_take_drop_id[of "length as" "x#xs"] by fastforce
 
 lemma distinct_set_diff: "distinct (xs@ys) \<Longrightarrow> set ys = set (xs@ys) - set xs"
   by auto
 
 lemma list_of_sublist_concat_eq:
   assumes "\<forall>as \<in> Y. \<forall>bs \<in> Y. as = bs \<or> set as \<inter> set bs = {}"
       and "\<forall>as \<in> Y. sublist as xs"
       and "distinct xs"
       and "set xs = \<Union>(set ` Y)"
       and "finite Y"
     shows "\<exists>ys. set ys = Y \<and> concat ys = xs \<and> distinct ys"
 using assms proof(induction "Finite_Set.card Y" arbitrary: Y xs)
   case (Suc n)
   show ?case
   proof(cases xs)
     case Nil
     then have "Y = {[]} \<or> Y = {}" using Suc.prems(4) by auto
     then have "set [[]] = Y \<and> concat [[]] = xs \<and> distinct [[]]" using Nil Suc.hyps(2) by auto
     then show ?thesis by blast
   next
     case (Cons x xs')
     then obtain as where as_def: "x \<in> set as" "as \<in> Y" using Suc.prems(4) by auto
     then have 0: "as @ (drop (length as) xs) = xs"
       using Suc.prems(2,3) distinct_sublist_first_remainder Cons by fast
     then have "\<forall>bs \<in> (Y - {as}). sublist bs (drop (length as) xs)"
       using Suc.prems(1,2) as_def(2) by (metis DiffE insertI1 sublist_snd_if_fst_dsjnt)
     moreover have "\<forall>cs \<in> (Y - {as}). \<forall>bs \<in> (Y - {as}). cs = bs \<or> set cs \<inter> set bs = {}"
       using Suc.prems(1) by simp
     moreover have "distinct (drop (length as) xs)" using Suc.prems(3) by simp
     moreover have "set (drop (length as) xs) = \<Union> (set ` (Y-{as}))"
       using Suc.prems(1,3,4) distinct_set_diff[of as "drop (length as) xs"] as_def(2) 0 by auto
     moreover have "n = Finite_Set.card (Y-{as})" using Suc.hyps(2) as_def(2) Suc.prems(5) by simp
     ultimately obtain ys where ys_def:
         "set ys = (Y-{as})" "concat ys = drop (length as) xs" "distinct ys"
       using Suc.hyps(1) Suc.prems(5) by blast
     then have "set (as#ys) = Y \<and> concat (as#ys) = xs \<and> distinct (as#ys)" using 0 as_def(2) by auto
     then show ?thesis by blast
   qed
 qed(auto)
 
 lemma extract_length_decr[termination_simp]:
   "List.extract P xs = Some (as,x,bs) \<Longrightarrow> length bs < length xs"
   by (simp add: extract_Some_iff)
 
 fun separate_P :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
   "separate_P P acc xs = (case List.extract P xs of
       None \<Rightarrow> (acc,xs)
     | Some (as,x,bs) \<Rightarrow> (case separate_P P (x#acc) bs of (acc',xs') \<Rightarrow> (acc', as@xs')))"
 
 lemma separate_not_P_snd: "separate_P P acc xs = (as,bs) \<Longrightarrow> \<forall>x \<in> set bs. \<not>P x"
 proof(induction P acc xs arbitrary: as bs rule: separate_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case None
     then have "bs = xs" using "1.prems" by simp
     then show ?thesis using None by (simp add: extract_None_iff)
   next
     case (Some a)
     then obtain cs x ds where x_def[simp]: "a = (cs,x,ds)" by(cases a) auto
     then obtain acc' xs' where acc'_def: "separate_P P (x#acc) ds = (acc',xs')" by fastforce
     then have "(acc', cs@xs') = (as,bs)" using "1.prems" Some by simp
     moreover have "\<forall>x \<in> set xs'. \<not>P x" using "1.IH" acc'_def Some x_def by blast
     ultimately show ?thesis using Some by (auto simp: extract_Some_iff)
   qed
 qed
 
 lemma separate_input_impl_none: "separate_P P acc xs = (acc,xs) \<Longrightarrow> List.extract P xs = None"
   using extract_None_iff separate_not_P_snd by fast
 
 lemma separate_input_iff_none: "List.extract P xs = None \<longleftrightarrow> separate_P P acc xs = (acc,xs)"
   using separate_input_impl_none by auto
 
 lemma separate_P_fst_acc:
   "separate_P P acc xs = (as,bs) \<Longrightarrow> \<exists>as'. as = as'@acc \<and> (\<forall>x \<in> set as'. P x)"
 proof(induction P acc xs arbitrary: as bs rule: separate_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case None
     then show ?thesis using "1.prems" by simp
   next
     case (Some a)
     then obtain cs x ds where x_def[simp]: "a = (cs,x,ds)" by(cases a) auto
     then obtain acc' xs' where acc'_def: "separate_P P (x#acc) ds = (acc',xs')" by fastforce
     then have "(acc', cs@xs') = (as,bs)" using "1.prems" Some by simp
     then have "\<exists>as'. as = as'@(x#acc) \<and> (\<forall>x \<in> set as'. P x)"
       using "1.IH" acc'_def Some x_def by blast
     then show ?thesis using Some by (auto simp: extract_Some_iff)
   qed
 qed
 
 lemma separate_P_fst: "separate_P P [] xs = (as,bs) \<Longrightarrow> \<forall>x \<in> set as. P x"
   using separate_P_fst_acc by fastforce
 
 subsection \<open>Optimal Solution for Lists of Fixed Sets\<close>
 
 lemma distinct_seteq_set_length_eq:
   "x \<in> {ys. set ys = xs \<and> distinct ys} \<Longrightarrow> length x = Finite_Set.card xs"
   using distinct_card by fastforce
 
 lemma distinct_seteq_set_Cons:
   "\<lbrakk>Finite_Set.card xs = Suc n; x \<in> {ys. set ys = xs \<and> distinct ys}\<rbrakk>
     \<Longrightarrow> \<exists>y ys. y # ys = x \<and> length ys = n \<and> distinct ys \<and> finite (set ys)"
   using distinct_seteq_set_length_eq[of x] Suc_length_conv[of n x] by force
 
 lemma distinct_seteq_set_Cons':
   "\<lbrakk>Finite_Set.card xs = Suc n; x \<in> {ys. set ys = xs \<and> distinct ys}\<rbrakk>
     \<Longrightarrow> \<exists>y ys zs. y # ys = x \<and> Finite_Set.card zs = n \<and> distinct ys \<and> set ys = zs"
   using distinct_seteq_set_length_eq[of x] Suc_length_conv[of n x] by force
 
 lemma distinct_seteq_set_Cons'':
   "\<lbrakk>Finite_Set.card xs = Suc n; x \<in> {ys. set ys = xs \<and> distinct ys}\<rbrakk>
     \<Longrightarrow> \<exists>y ys zs. y # ys = x \<and> y \<in> xs
         \<and> set ys = zs \<and> Finite_Set.card zs = n \<and> distinct ys \<and> finite zs"
   using distinct_seteq_set_Cons by fastforce
 
 lemma distinct_seteq_set_Cons_in_set:
   "\<lbrakk>Finite_Set.card xs = Suc n; x \<in> {ys. set ys = xs \<and> distinct ys}\<rbrakk>
     \<Longrightarrow> \<exists>y ys zs. y#ys = x \<and> y \<in> xs \<and> Finite_Set.card zs = n \<and> ys\<in>{ys. set ys = zs \<and> distinct ys}"
   using distinct_seteq_set_Cons'' by auto
 
 lemma distinct_seteq_set_Cons_in_set':
   "\<lbrakk>Finite_Set.card xs = Suc n; x \<in> {ys. set ys = xs \<and> distinct ys}\<rbrakk>
     \<Longrightarrow> \<exists>y ys. x = y#ys \<and> y \<in> xs \<and> ys\<in>{ys. set ys = (xs - {y}) \<and> distinct ys}"
   using distinct_seteq_set_Cons'' by fastforce
 
 lemma distinct_seteq_eq_set_union:
   "Finite_Set.card xs = Suc n
     \<Longrightarrow> {ys. set ys = xs \<and> distinct ys}
       = {y # ys |y ys. y \<in> xs \<and> ys \<in> {as. set as = (xs - {y}) \<and> distinct as}}"
   using distinct_seteq_set_Cons_in_set' by force
 
 lemma distinct_seteq_sub_set_union:
   "Finite_Set.card xs = Suc n
     \<Longrightarrow> {ys. set ys = xs \<and> distinct ys}
       \<subseteq> {y # ys |y ys. y \<in> xs \<and> ys \<in> {as. \<exists>a \<in> xs. set as = (xs - {a}) \<and> distinct as}}"
   using distinct_seteq_set_Cons_in_set' by fast
 
 lemma finite_set_union: "\<lbrakk>finite ys; \<forall>y \<in> ys. finite y\<rbrakk> \<Longrightarrow> finite (\<Union>y \<in> ys. y)"
   by simp
 
 lemma Cons_set_eq_union_set:
   "{x # y | x y y'. x \<in> xs \<and> y \<in> y' \<and> y' \<in> ys} = {x # y | x y. x \<in> xs \<and> y \<in> (\<Union>y \<in> ys. y)}"
   by blast
 
 lemma finite_set_Cons_union_finite:
   "\<lbrakk>finite xs; finite ys; \<forall>y \<in> ys. finite y\<rbrakk>
     \<Longrightarrow> finite {x # y | x y. x \<in> xs \<and> y \<in> (\<Union>y \<in> ys. y)}"
   by (simp add: finite_image_set2)
 
 lemma finite_set_Cons_finite:
   "\<lbrakk>finite xs; finite ys; \<forall>y \<in> ys. finite y\<rbrakk>
     \<Longrightarrow> finite {x # y | x y y'. x \<in> xs \<and> y \<in> y' \<and> y' \<in> ys}"
   using Cons_set_eq_union_set[of xs] by (simp add: finite_image_set2)
 
 lemma finite_set_Cons_finite':
   "\<lbrakk>finite xs; finite ys\<rbrakk> \<Longrightarrow> finite {x # y |x y. x \<in> xs \<and> y \<in> ys}"
   by (auto simp add: finite_image_set2)
 
 lemma Cons_set_alt: "{x # y |x y. x \<in> xs \<and> y \<in> ys} = {zs. \<exists>x y. x # y = zs \<and> x \<in> xs \<and> y \<in> ys}"
   by blast
 
 lemma Cons_set_sub:
   assumes "Finite_Set.card xs = Suc n"
   shows "{ys. set ys = xs \<and> distinct ys}
     \<subseteq> {x # y |x y. x \<in> xs \<and> y \<in> (\<Union>y \<in> xs. {as. set as = xs - {y} \<and> distinct as})}"
   using distinct_seteq_eq_set_union[OF assms] by auto
 
 lemma distinct_seteq_finite: "finite xs \<Longrightarrow> finite {ys. set ys = xs \<and> distinct ys}"
-proof(induction "Finite_Set.card xs" arbitrary: xs)
-  case (Suc n)
-  have "finite (\<Union>y \<in> xs. {as. set as = xs - {y} \<and> distinct as})" using Suc by simp
-  then have "finite {x # y |x y. x \<in> xs \<and> y \<in> (\<Union>y \<in> xs. {as. set as = xs - {y} \<and> distinct as})}"
-    using finite_set_Cons_finite'[OF Suc.prems] by blast
-  then show ?case using finite_subset[OF Cons_set_sub] Suc.hyps(2)[symmetric] by blast
-qed(simp)
+by(blast intro: rev_finite_subset[OF finite_subset_distinct])
 
 lemma distinct_setsub_split:
   "{ys. set ys \<subseteq> xs \<and> distinct ys}
   = {ys. set ys = xs \<and> distinct ys} \<union> (\<Union>y \<in> xs. {ys. set ys \<subseteq> (xs-{y}) \<and> distinct ys})"
   by blast
 
-lemma distinct_setsub_finite: "finite xs \<Longrightarrow> finite {ys. set ys \<subseteq> xs \<and> distinct ys}"
-proof(induction "Finite_Set.card xs" arbitrary: xs)
-  case (Suc x)
-  then show ?case using distinct_seteq_finite distinct_setsub_split[of xs] by auto
-qed(simp)
-
 lemma valid_UV_lists_finite:
   "finite xs \<Longrightarrow> finite {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x}"
   using distinct_seteq_finite by force
 
 lemma valid_UV_lists_r_subset:
   "{x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]}
   \<subseteq> {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x}"
   by blast
 
 lemma valid_UV_lists_r_finite:
   "finite xs \<Longrightarrow> finite {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]}"
   using valid_UV_lists_finite finite_subset[OF valid_UV_lists_r_subset] by fast
 
 lemma valid_UV_lists_arg_min_ex_aux:
   "\<lbrakk>finite ys; ys \<noteq> {}; ys = {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using arg_min_if_finite(1)[of ys f] arg_min_least[of ys, where ?f = f] by auto
 
 lemma valid_UV_lists_arg_min_ex:
   "\<lbrakk>finite xs; ys \<noteq> {}; ys = {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using valid_UV_lists_finite valid_UV_lists_arg_min_ex_aux[of ys] by blast
 
 lemma valid_UV_lists_arg_min_r_ex_aux:
   "\<lbrakk>finite ys; ys \<noteq> {};
     ys = {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using arg_min_if_finite(1)[of ys f] arg_min_least[of ys, where ?f = f] by auto
 
 lemma valid_UV_lists_arg_min_r_ex:
   "\<lbrakk>finite xs; ys \<noteq> {};
     ys = {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using valid_UV_lists_r_finite[of xs] valid_UV_lists_arg_min_r_ex_aux[of ys] by blast
 
 lemma valid_UV_lists_nemtpy:
   assumes "finite xs" "set (U@V) \<subseteq> xs" "distinct (U@V)"
   shows "{x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x} \<noteq> {}"
 proof -
   obtain cs where "set cs = xs - set (U@V) \<and> distinct cs"
     using assms(1) finite_distinct_list[of "xs - set (U@V)"] by blast
   then have "[]@U@[]@V@cs = U@V@cs" "set (U@V@cs) = xs" "distinct (U@V@cs)" using assms by auto
   then show ?thesis by blast
 qed
 
 lemma valid_UV_lists_nemtpy':
   "\<lbrakk>finite xs; set U \<inter> set V = {}; set U \<subseteq> xs; set V \<subseteq> xs; distinct U; distinct V\<rbrakk>
     \<Longrightarrow> {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x} \<noteq> {}"
   using valid_UV_lists_nemtpy[of xs] by simp
 
 lemma valid_UV_lists_nemtpy_r:
   assumes "finite xs" and "set (U@V) \<subseteq> xs" and "distinct (U@V)"
       and "take 1 U = [r] \<or> r \<notin> set U \<union> set V" and "r \<in> xs"
   shows "{x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]} \<noteq> {}"
 proof(cases "take 1 U = [r]")
   case True
   obtain cs where "set cs = xs - set (U@V) \<and> distinct cs"
     using assms(1) finite_distinct_list by auto
   then have "[]@U@[]@V@cs = U@V@cs" "set (U@V@cs) = xs" "distinct (U@V@cs)" using assms by auto
   then show ?thesis using True take1_singleton_app by fast
 next
   case False
   obtain cs where cs_def: "set cs = xs - ({r} \<union> set (U@V)) \<and> distinct cs"
     using assms(1) finite_distinct_list by auto
   then have "[r]@U@[]@V@cs = [r]@U@V@cs" "set ([r]@U@V@cs) = xs" "distinct ([r]@U@V@cs)"
       "take 1 ([r]@U@V@cs) = [r]"
     using assms False by auto
   then show ?thesis by (smt (verit, del_insts) empty_Collect_eq)
 qed
 
 lemma valid_UV_lists_nemtpy_r':
   "\<lbrakk>finite xs; set U \<inter> set V = {}; set U \<subseteq> xs; set V \<subseteq> xs; distinct U; distinct V;
     take 1 U = [r] \<or> r \<notin> set U \<union> set V; r \<in> xs\<rbrakk>
     \<Longrightarrow> {x. \<exists>as bs cs. as@U@bs@V@cs = x \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]} \<noteq> {}"
   using valid_UV_lists_nemtpy_r[of xs] by simp
 
 lemma valid_UV_lists_arg_min_ex':
   "\<lbrakk>finite xs; set U \<inter> set V = {}; set U \<subseteq> xs; set V \<subseteq> xs; distinct U; distinct V;
     ys = {x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using valid_UV_lists_arg_min_ex[of xs] valid_UV_lists_nemtpy'[of xs] by simp
 
 lemma valid_UV_lists_arg_min_r_ex':
   "\<lbrakk>finite xs; set U \<inter> set V = {}; set U \<subseteq> xs; set V \<subseteq> xs; distinct U; distinct V;
     take 1 U = [r] \<or> r \<notin> set U \<union> set V; r \<in> xs;
     ys = {x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x \<and> take 1 x = [r]}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using valid_UV_lists_arg_min_r_ex[of xs] valid_UV_lists_nemtpy_r'[of xs] by simp
 
 lemma valid_UV_lists_alt:
   assumes "P = (\<lambda>x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x)"
   shows "{x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x} = {ys. P ys}"
   using assms by simp
 
 lemma valid_UV_lists_argmin_ex:
   fixes cost :: "'a list \<Rightarrow> real"
   assumes "P = (\<lambda>x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x)"
       and "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
     shows "\<exists>as' bs' cs'. P (as'@U@bs'@V@cs') \<and>
       (\<forall>as bs cs. P (as@U@bs@V@cs) \<longrightarrow> cost (as'@U@bs'@V@cs') \<le> cost (as@U@bs@V@cs))"
 proof -
   obtain y where "y \<in> {ys. P ys} \<and> (\<forall>z \<in> {ys. P ys}. cost y \<le> cost z)"
     using valid_UV_lists_arg_min_ex'[OF assms(2-7)] assms(1) by fastforce
   then show ?thesis using assms(1) by blast
 qed
 
 lemma valid_UV_lists_argmin_ex_noP:
   fixes cost :: "'a list \<Rightarrow> real"
   assumes "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
     shows "\<exists>as' bs' cs'. set (as' @ U @ bs' @ V @ cs') = xs \<and> distinct (as' @ U @ bs' @ V @ cs')
     \<and> (\<forall>as bs cs. set (as @ U @ bs @ V @ cs) = xs \<and> distinct (as @ U @ bs @ V @ cs)
         \<longrightarrow> cost (as' @ U @ bs' @ V @ cs') \<le> cost (as @ U @ bs @ V @ cs))"
     using valid_UV_lists_argmin_ex[OF refl assms] by metis
 
 lemma valid_UV_lists_argmin_r_ex:
   fixes cost :: "'a list \<Rightarrow> real"
   assumes "P = (\<lambda>x. (\<exists>as bs cs. as@U@bs@V@cs = x) \<and> set x = xs \<and> distinct x \<and> take 1 x = [r])"
       and "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
       and "take 1 U = [r] \<or> r \<notin> set U \<union> set V"
       and "r \<in> xs"
     shows "\<exists>as' bs' cs'. P (as'@U@bs'@V@cs') \<and>
       (\<forall>as bs cs. P (as@U@bs@V@cs) \<longrightarrow> cost (as'@U@bs'@V@cs') \<le> cost (as@U@bs@V@cs))"
 proof -
   obtain y where "y \<in> {ys. P ys} \<and> (\<forall>z \<in> {ys. P ys}. cost y \<le> cost z)"
     using valid_UV_lists_arg_min_r_ex'[OF assms(2-9)] assms(1) by fastforce
   then show ?thesis using assms(1) by blast
 qed
 
 lemma valid_UV_lists_argmin_r_ex_noP:
   fixes cost :: "'a list \<Rightarrow> real"
   assumes "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
       and "take 1 U = [r] \<or> r \<notin> set U \<union> set V"
       and "r \<in> xs"
     shows "\<exists>as' bs' cs'. set (as' @ U @ bs' @ V @ cs') = xs
     \<and> distinct (as' @ U @ bs' @ V @ cs') \<and> take 1 (as' @ U @ bs' @ V @ cs') = [r]
     \<and> (\<forall>as bs cs. set (as @ U @ bs @ V @ cs) = xs
       \<and> distinct (as @ U @ bs @ V @ cs) \<and> take 1 (as @ U @ bs @ V @ cs) = [r]
         \<longrightarrow> cost (as' @ U @ bs' @ V @ cs') \<le> cost (as @ U @ bs @ V @ cs))"
   using valid_UV_lists_argmin_r_ex[OF refl assms] by metis
 
 lemma valid_UV_lists_argmin_r_ex_noP':
   fixes cost :: "'a list \<Rightarrow> real"
   assumes "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
       and "take 1 U = [r] \<or> r \<notin> set U \<union> set V"
       and "r \<in> xs"
     shows "\<exists>as' bs' cs'. set (as' @ U @ bs' @ V @ cs') = xs
     \<and> distinct (as' @ U @ bs' @ V @ cs') \<and> take 1 (as' @ U @ bs' @ V @ cs') = [r]
     \<and> (\<forall>as bs cs. set (as @ U @ bs @ V @ cs) = xs
       \<and> distinct (as @ U @ bs @ V @ cs) \<and> take 1 (as @ U @ bs @ V @ cs) = [r]
         \<longrightarrow> cost (rev (as' @ U @ bs' @ V @ cs')) \<le> cost (rev (as @ U @ bs @ V @ cs)))"
   using valid_UV_lists_argmin_r_ex_noP[OF assms] by meson
 
 lemma take1_split_nempty: "ys \<noteq> [] \<Longrightarrow> take 1 (xs@ys@zs) = take 1 (xs@ys)"
   by (metis append.assoc append_Nil2 gr_zeroI length_0_conv less_one same_append_eq
       take_append take_eq_Nil zero_less_diff)
 
 lemma take1_elem: "\<lbrakk>take 1 (xs@ys) = [r]; r \<in> set xs\<rbrakk> \<Longrightarrow> take 1 xs = [r]"
   using in_set_conv_decomp_last[of r xs] by auto
 
 lemma take1_nelem: "\<lbrakk>take 1 (xs@ys) = [r]; r \<notin> set ys\<rbrakk> \<Longrightarrow> take 1 xs = [r]"
   using take1_elem[of xs ys r] append_self_conv2[of xs] hd_in_set[of ys]
   by (fastforce dest: hd_eq_take1)
 
 lemma take1_split_nelem_nempty: "\<lbrakk>take 1 (xs@ys@zs) = [r]; ys \<noteq> []; r \<notin> set ys\<rbrakk> \<Longrightarrow> take 1 xs = [r]"
   using take1_split_nempty take1_nelem by fastforce
 
 lemma take1_empty_if_nelem: "\<lbrakk>take 1 (as@bs@cs) = [r]; r \<notin> set as\<rbrakk> \<Longrightarrow> as = []"
   using take1_split_nelem_nempty[of "[]" as "bs@cs"] by auto
 
 lemma take1_empty_if_mid: "\<lbrakk>take 1 (as@bs@cs) = [r]; r \<in> set bs; distinct (as@bs@cs)\<rbrakk> \<Longrightarrow> as = []"
   using take1_empty_if_nelem by fastforce
 
 lemma take1_mid_if_elem:
   "\<lbrakk>take 1 (as@bs@cs) = [r]; r \<in> set bs; distinct (as@bs@cs)\<rbrakk> \<Longrightarrow> take 1 bs = [r]"
   using take1_empty_if_mid[of as bs cs] by (fastforce intro: take1_elem)
 
 lemma contr_optimal_nogap_no_r:
   assumes "asi rank r cost"
       and "rank (rev V) \<le> rank (rev U)"
       and "finite xs"
       and "set U \<inter> set V = {}"
       and "set U \<subseteq> xs"
       and "set V \<subseteq> xs"
       and "distinct U"
       and "distinct V"
       and "r \<notin> set U \<union> set V"
       and "r \<in> xs"
     shows "\<exists>as' cs'. distinct (as' @ U @ V @ cs') \<and> take 1 (as' @ U @ V @ cs') = [r]
       \<and> set (as' @ U @ V @ cs') = xs \<and> (\<forall>as bs cs. set (as @ U @ bs @ V @ cs) = xs
         \<and> distinct (as @ U @ bs @ V @ cs) \<and> take 1 (as @ U @ bs @ V @ cs) = [r]
           \<longrightarrow> cost (rev (as' @ U @ V @ cs')) \<le> cost (rev (as @ U @ bs @ V @ cs)))"
 proof -
   define P where "P ys \<equiv> set ys = xs \<and> distinct ys \<and> take 1 ys = [r]" for ys
   obtain as' bs' cs' where bs'_def:
     "set (as'@U@bs'@V@cs') = xs" "distinct (as'@U@bs'@V@cs')" "take 1 (as'@U@bs'@V@cs') = [r]"
     "\<forall>as bs cs. P (as @ U @ bs @ V @ cs) \<longrightarrow>
          cost (rev (as' @ U @ bs' @ V @ cs')) \<le> cost (rev (as @ U @ bs @ V @ cs))"
     using valid_UV_lists_argmin_r_ex_noP'[OF assms(3-8)] assms(9,10) unfolding P_def by blast
   then consider "U = []" | "V = [] \<or> bs' = []"
     | "rank (rev bs') \<le> rank (rev U)" "U \<noteq> []" "bs' \<noteq> []"
     | "rank (rev U) \<le> rank (rev bs')" "U \<noteq> []" "V \<noteq> []" "bs' \<noteq> []"
     by fastforce
   then show ?thesis
   proof(cases)
     case 1
     then have "\<forall>as bs cs. P (as @ U @ bs @ V @ cs) \<longrightarrow>
          cost (rev ((as'@bs')@U@V@cs')) \<le> cost (rev (as @ U @ bs @ V @ cs))"
       using bs'_def(4) by simp
     moreover have "set ((as'@bs')@U@V@cs') = xs" using bs'_def(1) by auto
     moreover have "distinct ((as'@bs')@U@V@cs')" using bs'_def(2) by auto
     moreover have "take 1 ((as'@bs')@U@V@cs') = [r]" using bs'_def(3) 1 by auto
     ultimately show ?thesis unfolding P_def by blast
   next
     case 2
     then have "\<forall>as bs cs. P (as @ U @ bs @ V @ cs) \<longrightarrow>
          cost (rev (as'@U@V@bs'@cs')) \<le> cost (rev (as @ U @ bs @ V @ cs))" using bs'_def(4) by auto
     moreover have "set (as'@U@V@bs'@cs') = xs" using bs'_def(1) by auto
     moreover have "distinct (as'@U@V@bs'@cs')" using bs'_def(2) by auto
     moreover have "take 1 (as'@U@V@bs'@cs') = [r]" using bs'_def(3) 2 by auto
     ultimately show ?thesis unfolding P_def by blast
   next
     case 3
     have 0: "distinct (as'@bs'@U@V@cs')" using bs'_def(2) by auto
     have 1: "take 1 (as'@bs'@U@V@cs') = [r]"
       using bs'_def(3) assms(9) 3(2) take1_split_nelem_nempty[of as' U "bs'@V@cs'"] by simp
     then have "cost (rev (as'@bs'@U@V@cs')) \<le> cost (rev (as'@U@bs'@V@cs'))"
       using asi_le_rfst[OF assms(1) 3(1,3,2) 0] bs'_def(3) by blast
     then have "\<forall>as bs cs. P (as @ U @ bs @ V @ cs) \<longrightarrow>
          cost (rev ((as'@bs')@U@V@cs')) \<le> cost (rev (as @ U @ bs @ V @ cs))"
       using bs'_def(4) by fastforce
     moreover have "set ((as'@bs')@U@V@cs') = xs" using bs'_def(1) by auto
     moreover have "distinct ((as'@bs')@U@V@cs')" using 0 by simp
     moreover have "take 1 ((as'@bs')@U@V@cs') = [r]" using 1 by simp
     ultimately show ?thesis using P_def by blast
   next
     case 4
     then have 3: "rank (rev V) \<le> rank (rev bs')" using assms(2) by simp
     have 0: "distinct ((as'@U)@V@bs'@cs')" using bs'_def(2) by auto
     have 1: "take 1 (as'@U@V@bs'@cs') = [r]"
       using bs'_def(3) assms(9) 4(2) take1_split_nelem_nempty[of as' U "bs'@V@cs'"] by simp
     then have "cost (rev (as'@U@V@bs'@cs')) \<le> cost (rev ((as'@U)@bs'@V@cs'))"
       using asi_le_rfst[OF assms(1) 3 4(3,4) 0] bs'_def(3) by simp
     then have "\<forall>as bs cs. P (as @ U @ bs @ V @ cs) \<longrightarrow>
          cost (rev (as'@U@V@bs'@cs')) \<le> cost (rev (as @ U @ bs @ V @ cs))"
       using bs'_def(4) by fastforce
     moreover have "set (as'@U@V@bs'@cs') = xs" using bs'_def(1) by auto
     moreover have "distinct (as'@U@V@bs'@cs')" using 0 by simp
     ultimately show ?thesis using P_def 1 by blast
   qed
 qed
 
 fun combine_lists_P :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
   "combine_lists_P _ y [] = [y]"
 | "combine_lists_P P y (x#xs) = (if P (x@y) then combine_lists_P P (x@y) xs else (x@y)#xs)"
 
 fun make_list_P :: "('a list \<Rightarrow> bool) \<Rightarrow> 'a list list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
   "make_list_P P acc xs = (case List.extract P xs of
       None \<Rightarrow> rev acc @ xs
     | Some (as,y,bs) \<Rightarrow> make_list_P P (combine_lists_P P y (rev as @ acc)) bs)"
 
 lemma combine_lists_concat_rev_eq: "concat (rev (combine_lists_P P y xs)) = concat (rev xs) @ y"
   by (induction P y xs rule: combine_lists_P.induct) auto
 
 lemma make_list_concat_rev_eq: "concat (make_list_P P acc xs) = concat (rev acc) @ concat xs"
 proof(induction P acc xs rule: make_list_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case (Some a)
     then obtain as x bs where x_def[simp]: "a = (as,x,bs)" by(cases a) auto
     then have "concat (make_list_P P acc xs)
       = concat (rev (combine_lists_P P x (rev as @ acc))) @ concat bs"
       using 1 Some by simp
     also have "\<dots> = concat (rev acc) @ concat (as@x#bs)"
       using combine_lists_concat_rev_eq[of P] by simp
     finally show ?thesis using Some extract_SomeE by force
   qed(simp)
 qed
 
 lemma combine_lists_sublists:
   "\<exists>x \<in> {y} \<union> set xs. sublist as x \<Longrightarrow> \<exists>x \<in> set (combine_lists_P P y xs). sublist as x"
 proof (induction P y xs rule: combine_lists_P.induct)
   case (2 P y x xs)
   then show ?case
   proof(cases "sublist as x \<or> sublist as y")
     case True
     then have "sublist as (x@y)" using sublist_order.dual_order.trans by blast
     then show ?thesis using 2 by force
   next
     case False
     then show ?thesis using 2 by simp
   qed
 qed(simp)
 
 lemma make_list_sublists:
   "\<exists>x \<in> set acc \<union> set xs. sublist cs x \<Longrightarrow> \<exists>x \<in> set (make_list_P P acc xs). sublist cs x"
 proof(induction P acc xs rule: make_list_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case (Some a)
     then obtain as x bs where x_def[simp]: "a = (as,x,bs)" by(cases a) auto
     then have "make_list_P P acc xs = make_list_P P (combine_lists_P P x (rev as @ acc)) bs"
       using Some by simp
     then have "\<exists>a \<in> set (combine_lists_P P x (rev as @ acc)) \<union> set bs. sublist cs a"
       using Some combine_lists_sublists[of x "rev as @ acc" cs] "1.prems"
       by (auto simp: extract_Some_iff)
     then show ?thesis using 1 Some by simp
   qed(simp)
 qed
 
 lemma combine_lists_nempty: "\<lbrakk>[] \<notin> set xs; y \<noteq> []\<rbrakk> \<Longrightarrow> [] \<notin> set (combine_lists_P P y xs)"
   by (induction P y xs rule: combine_lists_P.induct) auto
 
 lemma make_list_nempty:
   "\<lbrakk>[] \<notin> set acc; [] \<notin> set xs\<rbrakk> \<Longrightarrow> [] \<notin> set (make_list_P P acc xs)"
 proof (induction P acc xs rule: make_list_P.induct)
   case (1 P acc xs)
   show ?case
   proof(cases "List.extract P xs")
     case None
     then show ?thesis using 1 by simp
   next
     case (Some a)
     then show ?thesis using 1 by (auto simp: extract_Some_iff combine_lists_nempty)
   qed
 qed
 
 lemma combine_lists_notP:
   "\<forall>x\<in>set xs. \<not>P x \<Longrightarrow> (\<exists>x. combine_lists_P P y xs = [x]) \<or> (\<forall>x\<in>set (combine_lists_P P y xs). \<not>P x)"
   by (induction P y xs rule: combine_lists_P.induct) auto
 
 lemma combine_lists_single: "xs = [x] \<Longrightarrow> combine_lists_P P y xs = [x@y]"
   by auto
 
 lemma combine_lists_lastP:
   "P (last xs) \<Longrightarrow> (\<exists>x. combine_lists_P P y xs = [x]) \<or> (P (last (combine_lists_P P y xs)))"
   by (induction P y xs rule: combine_lists_P.induct) auto
 
 lemma make_list_notP:
   "\<lbrakk>(\<forall>x \<in> set acc. \<not>P x) \<or> P (last acc)\<rbrakk>
     \<Longrightarrow> (\<forall>x\<in>set (make_list_P P acc xs). \<not>P x) \<or> (\<exists>y ys. make_list_P P acc xs = y # ys \<and> P y)"
 proof(induction P acc xs rule: make_list_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case None
     then show ?thesis
     proof(cases "\<forall>x \<in> set acc. \<not>P x")
       case True
       from None have "\<forall>x \<in> set xs. \<not> P x" by (simp add: extract_None_iff)
       then show ?thesis using True "1.prems" None by auto
     next
       case False
       then have "acc \<noteq> []" by auto
       then have "make_list_P P acc xs = last acc # rev (butlast acc) @ xs" using None by simp
       then show ?thesis using False "1.prems" by blast
     qed
   next
     case (Some a)
     then obtain as x bs where x_def[simp]: "a = (as,x,bs)" by(cases a) auto
     show ?thesis
     proof(cases "\<forall>x \<in> set acc. \<not>P x")
       case True
       then have "\<forall>x \<in> set (rev as @ acc). \<not>P x" using Some by (auto simp: extract_Some_iff)
       then have "(\<forall>x\<in>set (combine_lists_P P x (rev as @ acc)). \<not> P x)
                 \<or> P (last (combine_lists_P P x (rev as @ acc)))"
         using combine_lists_notP[of "rev as @ acc" P] by force
       then show ?thesis using "1.IH" Some by simp
     next
       case False
       then have "P (last acc) \<and> acc \<noteq> []" using "1.prems" by auto
       then have "P (last (rev as @ acc))" using "1.prems" by simp
       then have "(\<forall>x\<in>set (combine_lists_P P x (rev as @ acc)). \<not> P x)
                 \<or> P (last (combine_lists_P P x (rev as @ acc)))"
         using combine_lists_lastP[of P] by force
       then show ?thesis using "1.IH" Some by simp
     qed
   qed
 qed
 
 corollary make_list_notP_empty_acc:
   "(\<forall>x\<in>set (make_list_P P [] xs). \<not>P x) \<or> (\<exists>y ys. make_list_P P [] xs = y # ys \<and> P y)"
   using make_list_notP[of "[]"] by auto
 
 definition unique_set_r :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list \<Rightarrow> bool" where
  "unique_set_r r Y ys \<longleftrightarrow> set ys = \<Union>(set ` Y) \<and> distinct ys \<and> take 1 ys = [r]"
 
 context directed_tree
 begin
 
 definition fwd_sub :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list \<Rightarrow> bool" where
  "fwd_sub r Y ys \<longleftrightarrow> unique_set_r r Y ys \<and> forward ys \<and> (\<forall>xs \<in> Y. sublist xs ys)"
 
 lemma distinct_mid_unique1: "\<lbrakk>distinct (xs@U@ys); U\<noteq>[]; xs@U@ys = as@U@bs\<rbrakk> \<Longrightarrow> as = xs"
   using distinct_app_trans_r distinct_ys_not_xs[of xs "U@ys"] hd_append2[of U] append_is_Nil_conv[of U]
   by (metis append_Cons_eq_iff distinct.simps(2) list.exhaust_sel list.set_sel(1))
 
 lemma distinct_mid_unique2: "\<lbrakk>distinct (xs@U@ys); U\<noteq>[]; xs@U@ys = as@U@bs\<rbrakk> \<Longrightarrow> ys = bs"
   using distinct_mid_unique1 by blast
 
 lemma concat_all_sublist: "\<forall>x \<in> set xs. sublist x (concat xs)"
   using split_list by force
 
 lemma concat_all_sublist_rev: "\<forall>x \<in> set xs. sublist x (concat (rev xs))"
   using split_list by force
 
 lemma concat_all_sublist1:
   assumes "distinct (as@U@bs)"
       and "concat cs @ U @ concat ds = as@U@bs"
       and "U \<noteq> []"
       and "set (cs@U#ds) = Y"
     shows "\<exists>X. X \<subseteq> Y \<and> set as = \<Union>(set ` X) \<and> (\<forall>xs \<in> X. sublist xs as)"
 proof -
   have eq: "concat cs = as"
     using distinct_mid_unique1[of "concat cs" U "concat ds"] assms(1-3) by simp
   then have "\<forall>xs \<in> set cs. sublist xs as" using concat_all_sublist by blast
   then show ?thesis using eq assms(4) by fastforce
 qed
 
 lemma concat_all_sublist2:
   assumes "distinct (as@U@bs)"
       and "concat cs @ U @ concat ds = as@U@bs"
       and "U \<noteq> []"
       and "set (cs@U#ds) = Y"
     shows "\<exists>X. X \<subseteq> Y \<and> set bs = \<Union>(set ` X) \<and> (\<forall>xs \<in> X. sublist xs bs)"
 proof -
   have eq: "concat ds = bs"
     using distinct_mid_unique1[of "concat cs" U "concat ds"] assms(1-3) by simp
   then have "\<forall>xs \<in> set ds. sublist xs bs" using concat_all_sublist by blast
   then show ?thesis using eq assms(4) by fastforce
 qed
 
 lemma concat_split_mid:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "finite Y"
       and "U \<in> Y"
       and "distinct (as@U@bs)"
       and "set (as@U@bs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs)"
       and "U \<noteq> []"
     shows "\<exists>cs ds. concat cs = as \<and> concat ds = bs \<and> set (cs@U#ds) = Y \<and> distinct (cs@U#ds)"
 proof -
   obtain ys where ys_def: "set ys = Y" "concat ys = as@U@bs" "distinct ys"
     using list_of_sublist_concat_eq[OF assms(1,6,4,5,2)] by blast
   then obtain cs ds where cs_def: "cs@U#ds = ys"
     using assms(3) in_set_conv_decomp_first[of U ys] by blast
   then have "List.extract ((=) U) ys = Some (cs,U,ds)"
     using extract_Some_iff[of "(=) U"] ys_def(3) by auto
   then have "concat cs @ U @ concat ds = as@U@bs" using ys_def(2) cs_def by auto
   then have "concat cs = as \<and> concat ds = bs"
     using distinct_mid_unique1[of "concat cs" U] assms(4,7) by auto
   then show ?thesis using ys_def(1,3) cs_def by blast
 qed
 
 lemma mid_all_sublists_set1:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "finite Y"
       and "U \<in> Y"
       and "distinct (as@U@bs)"
       and "set (as@U@bs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs)"
       and "U \<noteq> []"
     shows "\<exists>X. X \<subseteq> Y \<and> set as = \<Union>(set ` X) \<and> (\<forall>xs \<in> X. sublist xs as)"
 proof -
   obtain ys where ys_def: "set ys = Y" "concat ys = as@U@bs" "distinct ys"
     using list_of_sublist_concat_eq[OF assms(1,6,4,5,2)] by blast
   then obtain cs ds where cs_def: "cs@U#ds = ys"
     using assms(3) in_set_conv_decomp_first[of U ys] by blast
   then have "List.extract ((=) U) ys = Some (cs,U,ds)"
     using extract_Some_iff[of "(=) U"] ys_def(3) by auto
   then have "concat cs @ U @ concat ds = as@U@bs" using ys_def(2) cs_def by auto
   then show ?thesis using cs_def ys_def(1) concat_all_sublist1[OF assms(4)] assms(7) by force
 qed
 
 lemma mid_all_sublists_set2:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "finite Y"
       and "U \<in> Y"
       and "distinct (as@U@bs)"
       and "set (as@U@bs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs)"
       and "U \<noteq> []"
     shows "\<exists>X. X \<subseteq> Y \<and> set bs = \<Union>(set ` X) \<and> (\<forall>xs \<in> X. sublist xs bs)"
 proof -
   obtain ys where ys_def: "set ys = Y" "concat ys = as@U@bs" "distinct ys"
     using list_of_sublist_concat_eq[OF assms(1,6,4,5,2)] by blast
   then obtain cs ds where cs_def: "cs@U#ds = ys"
     using assms(3) in_set_conv_decomp_first[of U ys] by blast
   then have "List.extract ((=) U) ys = Some (cs,U,ds)"
     using extract_Some_iff[of "(=) U"] ys_def(3) by auto
   then have "concat cs @ U @ concat ds = as@U@bs" using ys_def(2) cs_def by auto
   then show ?thesis using cs_def ys_def(1) concat_all_sublist2[OF assms(4)] assms(7) by force
 qed
 
 lemma nonempty_notin_distinct_prefix:
   assumes "distinct (as@bs@V@cs)" and "concat as' = as" and "V \<noteq> []"
   shows "V \<notin> set as'"
 proof
   assume "V \<in> set as'"
   then have "set V \<subseteq> set as" using assms(2) by auto
   then have "set as \<inter> set V \<noteq> {}" using assms(3) by (simp add: Int_absorb1)
   then show False using assms(1) by auto
 qed
 
 lemma concat_split_UV:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "distinct (as@U@bs@V@cs)"
       and "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)"
       and "U \<noteq> []"
       and "V \<noteq> []"
     shows "\<exists>as' bs' cs'. concat as' = as \<and> concat bs' = bs \<and> concat cs' = cs
           \<and> set (as'@U#bs'@V#cs') = Y \<and> distinct (as'@U#bs'@V#cs')"
 proof -
   obtain as' ds where as'_def:
       "concat as' = as" "concat ds = bs@V@cs" "set (as'@U#ds) = Y" "distinct (as'@U#ds)"
     using concat_split_mid[OF assms(1-3,5-8)] by auto
   have 0: "distinct (bs@V@cs)" using assms(5) by simp
   have "V \<notin> set as'"
     using assms(5,9) as'_def(1) nonempty_notin_distinct_prefix[of as "U@bs"] by auto
   moreover have "V \<noteq> U" using assms(5,8,9) empty_if_sublist_dsjnt[of U] by auto
   ultimately have "V \<in> set ds" using as'_def(3) assms(4) by auto
   then show ?thesis
     using as'_def 0 assms(9) concat_append distinct_mid_unique1
     by (metis concat.simps(2) distinct_mid_unique2 split_list)
 qed
 
 lemma cost_decr_if_noarc_lessrank:
   assumes "asi rank r cost"
       and "b \<noteq> []"
       and "r \<notin> set U"
       and "U \<noteq> []"
       and "set (as@U@bs@cs) = \<Union>(set ` Y)"
       and "distinct (as@U@bs@cs)"
       and "take 1 (as@U@bs@cs) = [r]"
       and "forward (as@U@bs@cs)"
       and "concat (b#bs') = bs"
       and "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U
             \<or> (\<exists>x \<in> set (b#bs'). sublist xs x) \<or> sublist xs cs)"
       and "\<not>(\<exists>x \<in> set U. \<exists>y \<in> set b. x \<rightarrow>\<^bsub>T\<^esub> y)"
       and "rank (rev b) < rank (rev U)"
     shows "fwd_sub r Y (as@b@U@concat bs'@cs)
           \<and> cost (rev (as@b@U@concat bs'@cs)) < cost (rev (as@U@bs@cs))"
 proof -
   have rank_yU: "rank (rev b) < rank (rev U)" using assms(12) by simp
   have 0: "take 1 (as@b@U@concat bs'@cs) = [r]"
     using take1_singleton_app take1_split_nelem_nempty[OF assms(7,4,3)] by fast
   have 1: "distinct (as@b@U@ concat bs'@cs)" using assms(6,9) by force
   have "take 1 (as@U@b@concat bs'@cs) = [r]" using assms(7,9) by force
   then have cost_lt: "cost (rev (as@b@U@concat bs'@cs)) < cost (rev (as@U@bs@cs))"
     using asi_lt_rfst[OF assms(1) rank_yU assms(2,4) 1 0] assms(9) by fastforce
   have P: "set (as@b@U@concat bs'@cs) = \<Union>(set ` Y)" using assms(5,9) by fastforce
   then have P: "unique_set_r r Y (as@b@U@concat bs'@cs)"
     using 0 1 unfolding unique_set_r_def by blast
   have "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U \<or> sublist xs b
           \<or> sublist xs (concat bs') \<or> sublist xs cs)"
     using assms(10) concat_all_sublist[of bs']
       sublist_order.dual_order.trans[where a = "concat bs'"] by auto
   then have all_sub: "\<forall>xs \<in> Y. sublist xs (as@b@U@concat bs'@cs)"
     by (metis sublist_order.order.trans sublist_append_leftI sublist_append_rightI)
   have "as \<noteq> []" using take1_split_nelem_nempty[OF assms(7,4,3)] by force
   then have "forward (as@b@U@concat bs'@cs)"
     using move_mid_forward_if_noarc assms(8,9,11) by auto
   then show ?thesis using assms(12) P all_sub cost_lt fwd_sub_def by blast
 qed
 
 lemma cost_decr_if_noarc_lessrank':
   assumes "asi rank r cost"
       and "b \<noteq> []"
       and "r \<notin> set U"
       and "U \<noteq> []"
       and "set (as@U@bs@cs) = \<Union>(set ` Y)"
       and "distinct (as@U@bs@cs)"
       and "take 1 (as@U@bs@cs) = [r]"
       and "forward (as@U@bs@cs)"
       and "concat (b#bs') = bs"
       and "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U
             \<or> (\<exists>x \<in> set (b#bs'). sublist xs x) \<or> sublist xs cs)"
       and "\<not>(\<exists>x \<in> set U. \<exists>y \<in> set b. x \<rightarrow>\<^bsub>T\<^esub> y)"
       and "rank (rev b) < rank (rev V)"
       and "rank (rev V) \<le> rank (rev U)"
     shows "fwd_sub r Y (as@b@U@concat bs'@cs)
           \<and> cost (rev (as@b@U@concat bs'@cs)) < cost (rev (as@U@bs@cs))"
   using cost_decr_if_noarc_lessrank[OF assms(1-11)] assms(12,13) by simp
 
 lemma sublist_exists_append:
   "\<exists>a\<in>set ((x # xs) @ [b]). sublist ys a \<Longrightarrow> \<exists>a\<in>set(xs @ [x@b]). sublist ys a"
   using sublist_order.dual_order.trans by auto
 
 lemma sublist_set_concat_cases:
   "\<exists>a\<in>set ((x # xs) @ [b]). sublist ys a \<Longrightarrow> sublist ys (concat (rev xs)) \<or> sublist ys x \<or> sublist ys b"
   using sublist_order.dual_order.trans concat_all_sublist_rev[of xs] by auto
 
 lemma sublist_set_concat_or_cases_aux1:
   "sublist ys as \<or> sublist ys U \<or> sublist ys cs
     \<Longrightarrow> sublist ys (as @ U @ concat (rev xs)) \<or> sublist ys cs"
   using sublist_order.dual_order.trans by blast
 
 lemma sublist_set_concat_or_cases_aux2:
   "\<exists>a\<in>set ((x # xs) @ [b]). sublist ys a
     \<Longrightarrow> sublist ys (as @ U @ concat (rev xs)) \<or> sublist ys x \<or> sublist ys b"
   using sublist_set_concat_cases[of x xs b ys] sublist_order.dual_order.trans by blast
 
 lemma sublist_set_concat_or_cases:
   "sublist ys as \<or> sublist ys U \<or> (\<exists>a\<in>set ((x#xs) @ [b]). sublist ys a) \<or> sublist ys cs \<Longrightarrow>
     sublist ys (as@U@ concat (rev xs)) \<or> sublist ys x \<or> (\<exists>a\<in>set [b]. sublist ys a) \<or> sublist ys cs"
   using sublist_set_concat_or_cases_aux1[of ys as U cs] sublist_set_concat_or_cases_aux2[of x xs b ys]
   by auto
 
 corollary not_reachable1_append_if_not_old:
   "\<lbrakk>\<not> (\<exists>z\<in>set U. \<exists>y\<in>set b. z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); set U \<inter> set x = {}; forward x;
     \<exists>z\<in>set x. \<exists>y\<in>set b. z \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> \<not> (\<exists>z\<in>set U. \<exists>y\<in>set (x@b). z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
   using reachable1_append_old_if_arcU[of x b U] by auto
 
 lemma combine_lists_notP:
   assumes "asi rank r cost"
       and "b \<noteq> []"
       and "r \<notin> set U"
       and "U \<noteq> []"
       and "set (as@U@bs@cs) = \<Union>(set ` Y)"
       and "distinct (as@U@bs@cs)"
       and "take 1 (as@U@bs@cs) = [r]"
       and "forward (as@U@bs@cs)"
       and "concat (rev ys @ [b]) = bs"
       and "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U
             \<or> (\<exists>x \<in> set (ys @ [b]). sublist xs x) \<or> sublist xs cs)"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<not>(\<exists>x \<in> set U. \<exists>y \<in> set b. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
       and "rank (rev b) < rank (rev V)"
       and "P = (\<lambda>x. rank (rev x) < rank (rev V))"
       and "\<forall>x\<in>set ys. \<not>P x"
       and "\<forall>xs. fwd_sub r Y xs \<longrightarrow> cost (rev (as@U@bs@cs)) \<le> cost (rev xs)"
       and "\<forall>x \<in> set ys. x \<noteq> []"
       and "\<forall>x \<in> set ys. forward x"
       and "forward b"
     shows "\<forall>x\<in>set (combine_lists_P P b ys). \<not>P x \<and> forward x"
 using assms proof(induction P b ys rule: combine_lists_P.induct)
   case (1 P b)
   have 0: "concat (b#[]) = bs" using "1.prems"(9) by simp
   have 2: "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U
         \<or> (\<exists>x \<in> set ([b]). sublist xs x) \<or> sublist xs cs)" using "1.prems"(10) by simp
   have 3: "\<not> (\<exists>x\<in>set U. \<exists>y\<in>set b. x \<rightarrow>\<^bsub>T\<^esub> y)" using "1.prems"(12) by blast
   show ?case
     using cost_decr_if_noarc_lessrank'[OF 1(1-8) 0 2 3 1(13,11)] 1(16) by auto
 next
   case (2 P b x xs)
   have "take 1 as = [r]" using "2.prems"(3,4,7) take1_split_nelem_nempty by fast
   then have "r \<in> set as" using in_set_takeD[of r 1] by simp
   then have "r \<notin> set x" using "2.prems"(6,9) by force
   then have "x \<noteq> []" using "2.prems"(17) by simp
   text \<open>Arc between x and b otherwise not optimal.\<close>
   have 4: "as@U@bs@cs = (as@U@concat (rev xs)) @ x @ b @ cs" using "2.prems"(9) by simp
   have set: "set ((as@U@concat (rev xs)) @ x @ b @ cs) = \<Union> (set ` Y)"
     using "2.prems"(5) 4 by simp
   have dst: "distinct ((as@U@concat (rev xs)) @ x @ b @ cs)" using "2.prems"(6) 4 by simp
   have tk1: "take 1 ((as@U@concat (rev xs)) @ x @ b @ cs) = [r]" using "2.prems"(7) 4 by simp
   have fwd: "forward ((as@U@concat (rev xs)) @ x @ b @ cs)" using "2.prems"(8) 4 by simp
   have cnct: "concat (b # []) = b" by simp
   have sblst: "\<forall>xs' \<in> Y. sublist xs' (as @ U @ concat (rev xs)) \<or> sublist xs' x
           \<or> (\<exists>a\<in>set [b]. sublist xs' a) \<or> sublist xs' cs"
     using "2.prems"(10) sublist_set_concat_or_cases[where as = as] by simp
   have "rank (rev b) < rank (rev x)" using "2.prems"(13-15) by simp
   then have arc_xb: "\<exists>z\<in>set x. \<exists>y\<in>set b. z \<rightarrow>\<^bsub>T\<^esub> y"
     using "2.prems"(16) 4
       cost_decr_if_noarc_lessrank[OF 2(2,3) \<open>r\<notin>set x\<close> \<open>x\<noteq>[]\<close> set dst tk1 fwd cnct sblst]
     by fastforce
   have "set x \<inter> set b = {}" using dst by auto
   then have fwd: "forward (x@b)" using forward_app' arc_xb "2.prems"(18,19) by simp
   show ?case
   proof(cases "P (x @ b)")
     case True
     have 0: "x @ b \<noteq> []" using "2.prems"(2) by blast
     have 1: "concat (rev xs @ [x @ b]) = bs" using "2.prems"(9) by simp
     have 3: "\<forall>xs' \<in> Y. sublist xs' as \<or> sublist xs' U
             \<or> (\<exists>a\<in>set (xs @ [x @ b]). sublist xs' a) \<or> sublist xs' cs"
       using "2.prems"(10) sublist_exists_append by fast
     have "set U \<inter> set x = {}" using 4 "2.prems"(6) by force
     then have 4: "\<not> (\<exists>z\<in>set U. \<exists>y\<in>set (x @ b). z \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
       using not_reachable1_append_if_not_old[OF "2.prems"(12)] "2.prems"(18) arc_xb by simp
     have 5: "rank (rev (x @ b)) < rank (rev V)" using True "2.prems"(14) by simp
     show ?thesis
       using "2.IH"[OF True 2(2) 0 2(4-9) 1 3 2(12) 4 5 2(15)] 2(16-19) fwd by auto
   next
     case False
     then show ?thesis using "2.prems"(15,18) fwd by simp
   qed
 qed
 
 lemma sublist_app_l: "sublist ys cs \<Longrightarrow> sublist ys (xs @ cs)"
   using sublist_order.dual_order.trans by blast
 
 lemma sublist_split_concat:
   assumes "a \<in> set (acc @ (as@x#bs))" and "sublist ys a"
   shows "(\<exists>a\<in>set (rev acc @ as @ [x]). sublist ys a) \<or> sublist ys (concat bs @ cs)"
 proof(cases "a \<in> set (rev acc @ as @ [x])")
   case True
   then show ?thesis using assms(2) by blast
 next
   case False
   then have "a \<in> set bs" using assms(1) by simp
   then show ?thesis
     using assms(2) concat_all_sublist[of bs]
       sublist_order.dual_order.trans[where c = ys, where b = "concat bs"]
     by fastforce
 qed
 
 lemma sublist_split_concat':
   "\<exists>a \<in> set (acc @ (as@x#bs)). sublist ys a \<or> sublist ys cs
     \<Longrightarrow> (\<exists>a\<in>set (rev acc @ as @ [x]). sublist ys a) \<or> sublist ys (concat bs @ cs)"
   using sublist_split_concat sublist_app_l[of ys cs] by blast
 
 lemma make_list_notP:
   assumes "asi rank r cost"
       and "r \<notin> set U"
       and "U \<noteq> []"
       and "set (as@U@bs@cs) = \<Union>(set ` Y)"
       and "distinct (as@U@bs@cs)"
       and "take 1 (as@U@bs@cs) = [r]"
       and "forward (as@U@bs@cs)"
       and "concat (rev acc @ ys) = bs"
       and "(\<forall>xs \<in> Y. sublist xs as \<or> sublist xs U
             \<or> (\<exists>x \<in> set (acc @ ys). sublist xs x) \<or> sublist xs cs)"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<And>xs. \<lbrakk>xs \<in> set ys; \<exists>x \<in> set U. \<exists>y \<in> set xs. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
       and "P = (\<lambda>x. rank (rev x) < rank (rev V))"
       and "\<forall>xs. fwd_sub r Y xs \<longrightarrow> cost (rev (as@U@bs@cs)) \<le> cost (rev xs)"
       and "\<forall>x \<in> set ys. x \<noteq> []"
       and "\<forall>x \<in> set ys. forward x"
       and "\<forall>x \<in> set acc. x \<noteq> []"
       and "\<forall>x \<in> set acc. forward x"
       and "\<forall>x \<in> set acc. \<not>P x"
     shows "\<forall>x\<in>set (make_list_P P acc ys). \<not>P x"
 using assms proof(induction P acc ys rule: make_list_P.induct)
   case (1 P acc xs)
   then show ?case
   proof(cases "List.extract P xs")
     case None
     then have "\<forall>x \<in> set xs. \<not> P x" by (simp add: extract_None_iff)
     then show ?thesis using "1.prems"(18) None by auto
   next
     case (Some a)
     then obtain as' x bs' where x_def[simp]: "a = (as',x,bs')" by(cases a) auto
     then have x: "\<forall>x \<in> set (rev as' @ acc). \<not>P x" "xs = as'@x#bs'" "rank (rev x) < rank (rev V)"
       using Some "1.prems"(12,18) by (auto simp: extract_Some_iff)
     have "x \<noteq> []" using "1.prems"(14) Some by (simp add: extract_Some_iff)
     have eq: "as@U@bs@cs = as@U@(concat (rev acc @ as' @ [x])) @ (concat bs' @ cs)"
       using "1.prems"(8) Some by (simp add: extract_Some_iff)
     then have 0: "set (as@U@(concat (rev acc @ as' @ [x])) @ (concat bs' @ cs)) = \<Union> (set ` Y)"
       using "1.prems"(4) by argo
     have 2: "distinct (as@U@(concat (rev acc @ as' @ [x])) @ (concat bs' @ cs))"
       using "1.prems"(5) eq by argo
     have 3: "take 1 (as@U@(concat (rev acc @ as' @ [x])) @ (concat bs' @ cs)) = [r]"
       using "1.prems"(6) eq by argo
     have 4: "forward (as@U@(concat (rev acc @ as' @ [x])) @ (concat bs' @ cs))"
       using "1.prems"(7) eq by argo
     have 5: "concat (rev (rev as' @ acc) @ [x]) = concat (rev acc @ as' @ [x])" by simp
     have 6: "\<forall>xs\<in>Y. sublist xs as \<or> sublist xs U
           \<or> (\<exists>x\<in>set ((rev as' @ acc) @ [x]). sublist xs x) \<or> sublist xs (concat bs' @ cs)"
       using "1.prems"(9) x(2) sublist_split_concat'[of acc as' x bs', where cs = cs]
       by auto
     have 7: "\<not> (\<exists>x'\<in>set U. \<exists>y\<in>set x. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)" using "1.prems"(11) x(2,3) by fastforce
     have 8: "\<forall>xs. fwd_sub r Y xs
             \<longrightarrow> cost (rev (as@U@concat(rev acc@as'@[x])@concat bs'@cs)) \<le> cost (rev xs)"
       using "1.prems"(13) eq by simp
     have notP: "\<forall>x\<in>set (combine_lists_P P x (rev as' @ acc)). \<not> P x \<and> forward x"
       using "1.prems"(14-17) x(2)
         combine_lists_notP[OF 1(2) \<open>x\<noteq>[]\<close> 1(3,4) 0 2 3 4 5 6 1(11) 7 x(3) 1(13) x(1) 8]
       by auto
     have cnct: "concat (rev (combine_lists_P P x (rev as' @ acc)) @ bs') = bs"
       using "1.prems"(8) combine_lists_concat_rev_eq[of P] x(2) by simp
     have sblst: "\<forall>xs\<in>Y. sublist xs as \<or> sublist xs U
         \<or> (\<exists>a\<in>set (combine_lists_P P x (rev as' @ acc) @ bs'). sublist xs a) \<or> sublist xs cs"
       using "1.prems"(9) x(2) combine_lists_sublists[of x "rev as'@acc", where P=P] by auto
     have "\<forall>x\<in>set (combine_lists_P P x (rev as' @ acc)). x \<noteq> []"
       using combine_lists_nempty[of "rev as' @ acc"] "1.prems"(14,16) x(2) by auto
     then have "\<forall>x\<in>set (make_list_P P (combine_lists_P P x (rev as' @ acc)) bs'). \<not> P x"
       using "1.IH"[OF Some x_def[symmetric] refl 1(2-8) cnct sblst 1(11-14)] notP x(2) 1(15,16)
       by simp
     then show ?thesis using Some by simp
   qed
 qed
 
 lemma no_back_reach1_if_fwd_dstct_bs:
   "\<lbrakk>forward (as@concat bs@V@cs); distinct (as@concat bs@V@cs); xs \<in> set bs\<rbrakk>
     \<Longrightarrow> \<not>(\<exists>x'\<in>set V. \<exists>y\<in>set xs. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
     using no_back_reach1_if_fwd_dstct[of "as@concat bs" "V@cs"] by auto
 
 lemma mid_ranks_ge_if_reach1:
   assumes "[] \<notin> Y"
       and "U \<in> Y"
       and "distinct (as@U@bs@V@cs)"
       and "forward (as@U@bs@V@cs)"
       and "concat bs' = bs"
       and "concat cs' = cs"
       and "set (as'@U#bs'@V#cs') = Y"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "\<forall>xs \<in> set bs'. (\<exists>x\<in>set U. \<exists>y\<in>set xs. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<longrightarrow> rank (rev V) \<le> rank (rev xs)"
 proof -
   have "\<forall>xs \<in> set bs'. \<forall>y\<in>set xs. \<not>(\<exists>x\<in>set V.  x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
     using assms(3-6) no_back_reach1_if_fwd_dstct_bs[of "as@U"] by fastforce
   then have 0: "\<forall>xs \<in> set bs'. (\<exists>y\<in>set xs. \<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)
     \<longrightarrow> (\<exists>y\<in>set xs. \<exists>x\<in>set U. \<not> (\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
     by blast
   have "\<forall>xs \<in> set bs'. xs \<noteq> U"
     using assms(1-3,5) concat_all_sublist empty_if_sublist_dsjnt[of U U] by fastforce
   then have "\<And>xs. \<lbrakk>xs \<in> set bs'; \<exists>y\<in>set xs. \<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> xs \<noteq> U \<and> (\<exists>y\<in>set xs. \<exists>x\<in>set U. \<not> (\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<in> Y"
     using 0 assms(7) by auto
   then show ?thesis using assms(8) by blast
 qed
 
 lemma bs_ranks_only_ge:
   assumes "asi rank r cost"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "r \<notin> set U"
       and "U \<in> Y"
       and "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
       and "distinct (as@U@bs@V@cs)"
       and "take 1 (as@U@bs@V@cs) = [r]"
       and "forward (as@U@bs@V@cs)"
       and "concat as' = as"
       and "concat bs' = bs"
       and "concat cs' = cs"
       and "set (as'@U#bs'@V#cs') = Y"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<forall>zs. fwd_sub r Y zs \<longrightarrow> cost (rev (as@U@bs@V@cs)) \<le> cost (rev zs)"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "\<exists>zs. concat zs = bs \<and> (\<forall>z \<in> set zs. rank (rev V) \<le> rank (rev z)) \<and> [] \<notin> set zs"
 proof -
   let ?P = "\<lambda>x. rank (rev x) < rank (rev V)"
   have "U \<noteq> []" using assms(3,5) by blast
   have cnct: "concat (rev [] @ bs') = bs" using assms(11) by simp
   have "\<forall>xs\<in>Y. sublist xs as \<or> xs = U \<or> xs = V
         \<or> (\<exists>x\<in>set ([] @ bs'). sublist xs x) \<or> sublist xs cs"
     using assms(10,12,13) concat_all_sublist by auto
   then have sblst:
       "\<forall>xs\<in>Y. sublist xs as \<or> sublist xs U \<or> (\<exists>x\<in>set ([] @ bs'). sublist xs x) \<or> sublist xs (V@cs)"
     using sublist_app_l by fast
   have 0: "\<And>xs. \<lbrakk>xs \<in> set bs'; \<exists>x\<in>set U. \<exists>y\<in>set xs. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     using mid_ranks_ge_if_reach1[OF assms(3,5,7,9,11-13)] assms(16) by blast
   have "\<forall>x\<in>set bs'. x \<noteq> []" using assms(3,13) by auto
   moreover have 2: "\<forall>x\<in>set bs'. forward x" using assms(2,13) by auto
   ultimately have "(\<forall>x\<in>set (make_list_P ?P [] bs'). rank (rev V) \<le> rank (rev x))"
     using assms(15)
       make_list_notP[OF assms(1,4) \<open>U\<noteq>[]\<close> assms(6-9) cnct sblst assms(14) 0 refl]
     by fastforce
   then show ?thesis
     using assms(3,11,13) make_list_concat_rev_eq[of ?P "[]"] make_list_nempty[of "[]" bs'] by auto
 qed
 
 lemma cost_ge_if_all_bs_ge:
   assumes "asi rank r cost"
       and "V \<noteq> []"
       and "distinct (as@ds@concat bs@V@cs)"
       and "take 1 as = [r]"
       and "forward V"
       and "\<forall>z\<in>set bs. rank (rev V) \<le> rank (rev z)"
       and "[] \<notin> set bs"
     shows "cost (rev (as@ds@V@concat bs@cs)) \<le> cost (rev (as@ds@concat bs@V@cs))"
 using assms proof(induction bs arbitrary: ds)
   case (Cons b bs)
   have 0: "distinct (as@(ds@b)@concat bs@V@cs)" using Cons.prems(3) by simp
   have r_b: "rank (rev V) \<le> rank (rev b)" using Cons.prems(6) by simp
   have "b \<noteq> []" using Cons.prems(7) by auto
   have dst: "distinct ((as@ds)@V@b@concat bs@cs)" using Cons.prems(3) by auto
   have "take 1 ((as@ds)@V@b@concat bs@cs) = [r]"
     using Cons.prems(4) take1_singleton_app by metis
   moreover have "take 1 ((as@ds)@b@V@concat bs@cs) = [r]"
     using Cons.prems(4) take1_singleton_app by metis
   ultimately have "cost (rev (as@ds@V@b@concat bs@cs)) \<le> cost (rev (as@ds@b@V@concat bs@cs))"
     using asi_le_rfst[OF Cons.prems(1) r_b Cons.prems(2) \<open>b\<noteq>[]\<close> dst] by simp
   then show ?case using Cons.IH[OF Cons.prems(1,2) 0] Cons.prems(4-7) by simp
 qed(simp)
 
 lemma bs_ge_if_all_ge:
   assumes "asi rank r cost"
       and "V \<noteq> []"
       and "distinct (as@bs@V@cs)"
       and "take 1 as = [r]"
       and "forward V"
       and "concat bs' = bs"
       and "\<forall>z\<in>set bs'. rank (rev V) \<le> rank (rev z)"
       and "[] \<notin> set bs'"
       and "bs \<noteq> []"
     shows "rank (rev V) \<le> rank (rev bs)"
 proof -
   have dst: "distinct (as@[]@concat bs'@V@cs)" using assms(3,6) by simp
   then have cost_le: "cost (rev (as@V@bs@cs)) \<le> cost (rev (as@bs@V@cs))"
     using cost_ge_if_all_bs_ge[OF assms(1,2) dst] assms(3-9) by simp
   have tk1: "take 1 ((as)@bs@V@cs) = [r]" using assms(4) take1_singleton_app by metis
   have tk1': "take 1 ((as)@V@bs@cs) = [r]" using assms(4) take1_singleton_app by metis
   have dst: "distinct ((as)@V@bs@cs)" using assms(3) by auto
   show ?thesis using asi_le_iff_rfst[OF assms(1,2,9) tk1' tk1 dst] cost_le by simp
 qed
 
 lemma bs_ge_if_optimal:
   assumes "asi rank r cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "r \<notin> set U"
       and "U \<in> Y"
       and "V \<in> Y"
       and "distinct (as@U@bs@V@cs)"
       and "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)"
       and "take 1 (as@U@bs@V@cs) = [r]"
       and "forward (as@U@bs@V@cs)"
       and "bs \<noteq> []"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<forall>zs. fwd_sub r Y zs \<longrightarrow> cost (rev (as@U@bs@V@cs)) \<le> cost (rev zs)"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "rank (rev V) \<le> rank (rev bs)"
 proof -
   obtain as' bs' cs' where bs'_def: "concat as' = as" "concat bs' = bs" "concat cs' = cs"
       "set (as'@U#bs'@V#cs') = Y"
     using concat_split_UV[OF assms(2,5,7-11)] assms(4,7,8) by blast
   obtain bs2 where bs2_def:
       "concat bs2 = bs" "(\<forall>z\<in>set bs2. rank (rev V) \<le> rank (rev z))" "[] \<notin> set bs2"
     using bs_ranks_only_ge[OF assms(1,3,4,6,7,10,9,12,13) bs'_def assms(15-17)] by blast
   have "V \<noteq> []" using assms(4,8) by blast
   have "take 1 as = [r]" using take1_split_nelem_nempty[OF assms(12)] assms(4,6,7) by blast
   then have "take 1 (as@U) = [r]" using take1_singleton_app by fast
   then show ?thesis
     using bs_ge_if_all_ge[OF assms(1) \<open>V\<noteq>[]\<close>, of "as@U"] bs2_def assms(3,8,9,14) by auto
 qed
 
 lemma bs_ranks_only_ge_r:
   assumes "[] \<notin> Y"
       and "distinct (as@U@bs@V@cs)"
       and "forward (as@U@bs@V@cs)"
       and "as = []"
       and "concat bs' = bs"
       and "concat cs' = cs"
       and "set (U#bs'@V#cs') = Y"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "\<forall>z \<in> set bs'. rank (rev V) \<le> rank (rev z)"
 proof -
   have "U \<in> Y" using assms(7) by auto
   then have "U \<noteq> []" using assms(1) by blast
   have "V \<noteq> []" using assms(1,7) by auto
   have 0: "\<And>xs. \<lbrakk>xs \<in> set bs'; \<exists>x\<in>set U. \<exists>y\<in>set xs. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     using mid_ranks_ge_if_reach1[OF assms(1) \<open>U\<in>Y\<close> assms(2,3,5,6), of "[]"] assms(7,8) by auto
   have "\<exists>x y ys. x#y#ys= as@U@bs@V@cs"
     using \<open>U\<noteq>[]\<close> \<open>V\<noteq>[]\<close> append_Cons append.left_neutral list.exhaust by metis
   then have hd_T: "hd (as@U@bs@V@cs) \<in> verts T" using hd_in_verts_if_forward assms(3) by metis
   moreover have "\<forall>x\<in>set bs'. \<forall>y\<in>set x. y \<in> set (as@U@bs@V@cs)" using assms(5) by auto
   ultimately have "\<forall>x\<in>set bs'. \<forall>y\<in>set x. hd (U@bs@V@cs) \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y"
     using hd_reach_all_forward assms(3,4) by auto
   then have 1: "\<forall>x\<in>set bs'. \<forall>y\<in>set x. hd U \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y" using assms(1,7) by auto
   have "\<forall>x\<in>set bs'. \<forall>y\<in>set x. y \<notin> set U" using assms(2,5) by auto
   then have "\<forall>x\<in>set bs'. \<forall>y\<in>set x. y \<noteq> hd U" using assms(1,7) by fastforce
   then have "\<forall>x\<in>set bs'. \<forall>y\<in>set x. hd U \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y" using 1 by blast
   then have "\<forall>x\<in>set bs'. \<exists>y\<in>set x. hd U \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y" using assms(1,7) by auto
   then show ?thesis using 0 \<open>U \<noteq> []\<close> hd_in_set by blast
 qed
 
 lemma bs_ge_if_rU:
   assumes "asi rank r cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "r \<in> set U"
       and "U \<in> Y"
       and "V \<in> Y"
       and "distinct (as@U@bs@V@cs)"
       and "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)"
       and "take 1 (as@U@bs@V@cs) = [r]"
       and "forward (as@U@bs@V@cs)"
       and "bs \<noteq> []"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "rank (rev V) \<le> rank (rev bs)"
 proof -
   obtain as' bs' cs' where bs'_def: "concat as' = as" "concat bs' = bs" "concat cs' = cs"
       "set (as'@U#bs'@V#cs') = Y"
     using concat_split_UV[OF assms(2,5,7-11)] assms(4,7,8) by blast
   have "take 1 U = [r]" using take1_mid_if_elem[OF assms(12,6,9)] .
   moreover have "as = []" using take1_empty_if_mid[OF assms(12,6,9)] .
   ultimately have tk1: "take 1 (as@U) = [r]" by simp
   then have "set (U#bs'@V#cs') = Y" using bs'_def(1,4) assms(4) \<open>as=[]\<close> by auto
   then have 0: "(\<forall>z\<in>set bs'. rank (rev V) \<le> rank (rev z))"
     using bs_ranks_only_ge_r[OF assms(4,9,13) \<open>as=[]\<close> bs'_def(2,3)] assms(15) by blast
   have "V \<noteq> []" using assms(4,8) by blast
   have "[] \<notin> set bs'" using assms(4) bs'_def(2,4) by auto
   then show ?thesis
     using bs_ge_if_all_ge[OF assms(1) \<open>V\<noteq>[]\<close>, of "as@U"] 0 bs'_def(2) tk1 assms(3,8,9,14) by auto
 qed
 
 lemma sublist_before_if_before:
   assumes "hd xs = root" and "forward xs" and "distinct xs"
       and "sublist U xs" and "sublist V xs" and "before U V"
     shows "\<exists>as bs cs. as @ U @ bs @ V @ cs = xs"
 proof (rule ccontr)
   assume "\<nexists>as bs cs. as @ U @ bs @ V @ cs = xs"
   then obtain as bs cs where V_bf_U: "xs = as @ V @ bs @ U @ cs"
     using sublist_behind_if_nbefore[OF assms(4,5)] assms(6) before_def by blast
   obtain x y where x_def: "x \<in> set U" "y \<in> set V" "x \<rightarrow>\<^bsub>T\<^esub> y"
     using assms(6) before_def by auto
   then obtain i where i_def: "V!i = y" "i < length V" by (auto simp: in_set_conv_nth)
   then have i_xs: "(as@V@bs@U@cs)!(i + length as) = y" by (simp add: nth_append)
   have "root \<noteq> y" using x_def(3) dominated_not_root by auto
   then have "i + length as > 0" using i_def(2) i_xs assms(1,5) V_bf_U hd_conv_nth[of xs] by force
   then have "i + length as \<ge> 1" by linarith
   then have "i + length as \<in> {1..length (as@V@bs@U@cs) - 1}" using i_def(2) by simp
   then obtain j where j_def: "j < i + length as" "(as@V@bs@U@cs)!j \<rightarrow>\<^bsub>T\<^esub> y"
     using assms(2) V_bf_U i_xs unfolding forward_def by blast
   then have "(as@V@bs@U@cs)!j = (as@V)!j" using i_def(2) by (auto simp: nth_append)
   then have "(as@V@bs@U@cs)!j \<in> set (as@V)" using i_def(2) j_def(1) nth_mem[of "j" "as@V"] by simp
   then have "(as@V@bs@U@cs)!j \<noteq> x" using assms(3) V_bf_U x_def(1) by auto
   then show False using j_def(2) x_def(3) two_in_arcs_contr by fastforce
 qed
 
 lemma forward_UV_lists_subset:
   "{x. set x = X \<and> distinct x \<and> take 1 x = [r] \<and> forward x \<and> (\<forall>xs \<in> Y. sublist xs x)}
   \<subseteq> {x. set x = X \<and> distinct x}"
   by blast
 
 lemma forward_UV_lists_finite:
   "finite xs
     \<Longrightarrow> finite {x. set x = xs \<and> distinct x \<and> take 1 x = [r] \<and> forward x \<and> (\<forall>xs \<in> Y. sublist xs x)}"
   using distinct_seteq_finite finite_subset[OF forward_UV_lists_subset] by auto
 
 lemma forward_UV_lists_arg_min_ex_aux:
   "\<lbrakk>finite ys; ys \<noteq> {};
     ys = {x. set x = xs \<and> distinct x \<and> take 1 x = [r] \<and> forward x \<and> (\<forall>xs \<in> Y. sublist xs x)}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using arg_min_if_finite(1)[of ys f] arg_min_least[of ys, where ?f = f] by auto
 
 lemma forward_UV_lists_arg_min_ex:
   "\<lbrakk>finite xs; ys \<noteq> {};
     ys = {x. set x = xs \<and> distinct x \<and> take 1 x = [r] \<and> forward x \<and> (\<forall>xs \<in> Y. sublist xs x)}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using forward_UV_lists_finite forward_UV_lists_arg_min_ex_aux by auto
 
 lemma forward_UV_lists_argmin_ex':
   fixes f :: "'a list \<Rightarrow> real"
   assumes "P = (\<lambda>x. set x = X \<and> distinct x \<and> take 1 x = [r])"
       and "Q = (\<lambda>ys. P ys \<and> forward ys \<and> (\<forall>xs \<in> Y. sublist xs ys))"
       and "\<exists>x. Q x"
     shows "\<exists>zs. Q zs \<and> (\<forall>as. Q as \<longrightarrow> f zs \<le> f as)"
   using forward_UV_lists_arg_min_ex[of X "{x. Q x}"] using assms by fastforce
 
 lemma forward_UV_lists_argmin_ex:
   fixes f :: "'a list \<Rightarrow> real"
   assumes "\<exists>x. fwd_sub r Y x"
   shows "\<exists>zs. fwd_sub r Y zs \<and> (\<forall>as. fwd_sub r Y as \<longrightarrow> f zs \<le> f as)"
   using forward_UV_lists_argmin_ex' assms unfolding fwd_sub_def unique_set_r_def by simp
 
 lemma no_gap_if_contr_seq_fwd:
   assumes "asi rank root cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "before U V"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
             \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
       and "\<exists>x. fwd_sub root Y x"
     shows "\<exists>zs. fwd_sub root Y zs \<and> sublist (U@V) zs
           \<and> (\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 proof -
   obtain zs where zs_def:
       "set zs = \<Union>(set ` Y)" "distinct zs" "take 1 zs = [root]" "forward zs"
       "(\<forall>xs \<in> Y. sublist xs zs)" "(\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using forward_UV_lists_argmin_ex[OF assms(11), of "\<lambda>xs. cost (rev xs)"]
     unfolding unique_set_r_def fwd_sub_def by blast
   then have "hd zs = root" using hd_eq_take1 by fast
   then obtain as bs cs where bs_def: "as @ U @ bs @ V @ cs = zs"
     using sublist_before_if_before zs_def(2,4,5) assms(6-8) by blast
   then have bs_prems: "distinct (as@U@bs@V@cs)" "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
     "\<forall>xs\<in>Y. sublist xs (as@U@bs@V@cs)" "take 1 (as@U@bs@V@cs) = [root]" "forward (as@U@bs@V@cs)"
     using zs_def(1-5) by auto
   show ?thesis
   proof(cases "bs = []")
     case True
     then have "sublist (U@V) zs" using bs_def sublist_def by force
     then show ?thesis using zs_def unfolding unique_set_r_def fwd_sub_def by blast
   next
     case bs_nempty: False
     then have rank_le: "rank (rev V) \<le> rank (rev bs)"
     proof(cases "root \<in> set U")
       case True
       then show ?thesis
         using bs_ge_if_rU[OF assms(1-5) True assms(6,7) bs_prems bs_nempty assms(10)]
         by blast
     next
       case False
       have "\<forall>zs. fwd_sub root Y zs \<longrightarrow> cost (rev (as@U@bs@V@cs)) \<le> cost (rev zs)"
         using zs_def(6) bs_def by blast
       then show ?thesis
         using bs_ge_if_optimal[OF assms(1-5)] bs_nempty bs_prems False assms(6,7,9,10)
         by blast
     qed
     have 0: "distinct ((as@U)@V@bs@cs)" using bs_def zs_def(2) by auto
     have "take 1 (as@U) = [root]"
       using bs_def assms(4,6) take1_split_nempty[of U as] zs_def(3) by fastforce
     then have 1: "take 1 (as@U@V@bs@cs) = [root]"
       using take1_singleton_app[of "as@U" root "V@bs@cs"] by simp
     have 2: "\<forall>xs\<in>Y. sublist xs (as@U@V@bs@cs)"
       using zs_def(5) bs_def sublists_preserv_move_VY_all[OF assms(2,6,7)] assms(4,6) by blast
     have "V \<noteq> []" using assms(4,7) by blast
     have "cost (rev (as@U@V@bs@cs)) \<le> cost (rev zs)"
       using asi_le_rfst[OF assms(1) rank_le \<open>V\<noteq>[]\<close> bs_nempty 0] 1 zs_def(3) bs_def by simp
     then have cost_le: "\<forall>ys. fwd_sub root Y ys \<longrightarrow> cost (rev (as@U@V@bs@cs)) \<le> cost (rev ys)"
       using zs_def(6) by fastforce
     have "forward (as@U@V@bs@cs)"
       using move_mid_backward_if_noarc assms(8) zs_def(4) bs_def by blast
     moreover have "set (as@U@V@bs@cs) = \<Union> (set ` Y)"
       unfolding zs_def(1)[symmetric] bs_def[symmetric] by force
     ultimately have "fwd_sub root Y (as@U@V@bs@cs)"
       unfolding unique_set_r_def fwd_sub_def using 0 1 2 by fastforce
     moreover have "sublist (U@V) (as@U@V@bs@cs)" unfolding sublist_def by fastforce
     ultimately show ?thesis using cost_le by blast
   qed
 qed
 
 lemma combine_union_sets_alt:
   fixes X Y
   defines "Z \<equiv> X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}"
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> set xs \<inter> set ys = {}"
     shows "Z = X \<union> (Y - {x. set x \<inter> \<Union>(set ` X) \<noteq> {}})"
   unfolding assms(1) using assms(2,3) by fast
 
 lemma combine_union_sets_disjoint:
   fixes X Y
   defines "Z \<equiv> X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}"
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> set xs \<inter> set ys = {}"
     shows "\<forall>xs \<in> Z. \<forall>ys \<in> Z. xs = ys \<or> set xs \<inter> set ys = {}"
   unfolding Z_def using assms(2,3) by force
 
 lemma combine_union_sets_set_sub1_aux:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys"
       and "x \<in> \<Union>(set ` Y)"
   shows "x \<in> \<Union>(set ` (X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}))"
 proof -
   let ?Z = "X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}"
   obtain ys where ys_def: "x \<in> set ys" "ys \<in> Y" using assms(3) by blast
   then show ?thesis
   proof(cases "ys \<in> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}")
     case True
     then show ?thesis using ys_def(1) by auto
   next
     case False
     then obtain U V where U_def: "U \<in> Y" "V \<in> Y" "U@V \<in> X" "set ys \<inter> set (U@V) \<noteq> {}"
       using ys_def(2) assms(2) by fast
     then consider "set ys \<inter> set U \<noteq> {}" | "set ys \<inter> set V \<noteq> {}" by fastforce
     then show ?thesis
     proof(cases)
       case 1
       then have "U = ys" using assms(1) U_def(1) ys_def(2) by blast
       then show ?thesis using ys_def(1) U_def(3) by fastforce
     next
       case 2
       then have "V = ys" using assms(1) U_def(2) ys_def(2) by blast
       then show ?thesis using ys_def(1) U_def(3) by fastforce
     qed
   qed
 qed
 
 lemma combine_union_sets_set_sub1:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys"
     shows "\<Union>(set ` Y) \<subseteq> \<Union>(set ` (X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}))"
   using combine_union_sets_set_sub1_aux[OF assms] by blast
 
 lemma combine_union_sets_set_sub2:
   assumes "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys"
   shows "\<Union>(set ` (X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}})) \<subseteq> \<Union>(set ` Y)"
   using assms by fastforce
 
 lemma combine_union_sets_set_eq:
   assumes "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys"
     shows "\<Union>(set ` (X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}})) = \<Union>(set ` Y)"
   using combine_union_sets_set_sub1[OF assms] combine_union_sets_set_sub2[OF assms(2)] by blast
 
 lemma combine_union_sets_sublists:
   assumes "sublist x ys"
       and "\<forall>xs \<in> X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}. sublist xs ys"
       and "xs \<in> insert x X \<union> {xs. xs \<in> Y \<and> set xs \<inter> \<Union>(set ` (insert x X)) = {}}"
     shows "sublist xs ys"
   using assms by auto
 
 lemma combine_union_sets_optimal_cost:
   assumes "asi rank root cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "\<exists>x. fwd_sub root Y x"
       and "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys \<and> before U V \<and> rank (rev V) \<le> rank (rev U)
           \<and> (\<forall>xs \<in> Y. (\<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<noteq> U)
             \<longrightarrow> rank (rev V) \<le> rank (rev xs))"
       and "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> \<not>(\<exists>x\<in>set xs. \<exists>y\<in>set ys. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
       and "finite X"
     shows "\<exists>zs. fwd_sub root (X \<union> {x. x \<in> Y \<and> set x \<inter> \<Union>(set ` X) = {}}) zs
             \<and> (\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 using assms(10,1-9) proof(induction X rule: finite_induct)
   case empty
   then show ?case using forward_UV_lists_argmin_ex by simp
 next
   case (insert x X)
   let ?Y = "X \<union> {xs. xs \<in> Y \<and> set xs \<inter> \<Union>(set ` X) = {}}"
   let ?X = "insert x X \<union> {xs. xs \<in> Y \<and> set xs \<inter> \<Union>(set ` (insert x X)) = {}}"
   obtain zs where zs_def:
       "fwd_sub root ?Y zs" "(\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using insert.IH[OF insert(4-9)] insert.prems(7,8,9) by auto
   obtain U V where U_def: "U \<in> Y" "V \<in> Y" "U@V = x" "before U V" "rank (rev V) \<le> rank (rev U)"
     "\<forall>xs \<in> Y. (\<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<noteq> U)
       \<longrightarrow> rank (rev V) \<le> rank (rev xs)"
     using insert.prems(7) by auto
   then have U: "U \<in> ?Y" using insert.prems(2,8) insert.hyps(2) by fastforce
   have V: "V \<in> ?Y" using U_def(2,3) insert.prems(8) insert.hyps(2) by fastforce
   have disj: "\<forall>xs \<in> ?Y. \<forall>ys \<in> ?Y. xs = ys \<or> set xs \<inter> set ys = {}"
     using combine_union_sets_disjoint[of Y X] insert.prems(2,8) by blast
   have fwd: "\<forall>xs \<in> ?Y. forward xs"
     using insert.prems(3,7) seq_conform_alt seq_conform_if_before by fastforce
   have nempty: "[] \<notin> ?Y" using insert.prems(4,7) by blast
   have fin: "finite ?Y" using insert.prems(5) insert.hyps(1) by simp
   have 0: "\<And>xs. \<lbrakk>xs \<in> ?Y; \<exists>y\<in>set xs. \<not> (\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); xs \<noteq> U\<rbrakk>
          \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
     using U_def(3,6) insert.prems(9) insert.hyps(2) by auto
   then have "\<exists>zs. fwd_sub root ?Y zs \<and> sublist (U@V) zs
                 \<and> (\<forall>as. fwd_sub root ?Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using no_gap_if_contr_seq_fwd[OF insert.prems(1) disj fwd nempty fin U V U_def(4,5)] zs_def(1)
     unfolding fwd_sub_def unique_set_r_def by blast
   then obtain xs where xs_def:
       "fwd_sub root ?Y xs" "sublist (U@V) xs"
       "(\<forall>as. fwd_sub root ?Y as \<longrightarrow> cost (rev xs) \<le> cost (rev as))"
     by blast
   then have cost: "(\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev xs) \<le> cost (rev as))"
     using zs_def by fastforce
   have 0: "\<forall>ys \<in> (insert x X). \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys" using insert.prems(7) by fastforce
   then have "\<forall>ys \<in> X. \<exists>U \<in> Y. \<exists>V \<in> Y. U@V = ys" by simp
   then have "\<Union>(set ` ?Y) = \<Union>(set ` Y)"
     using combine_union_sets_set_eq[OF insert.prems(2)] by simp
   then have "\<Union>(set ` ?X) = \<Union>(set ` ?Y)"
     using combine_union_sets_set_eq[OF insert.prems(2) 0] by simp
   then have P_eq: "unique_set_r root ?X = unique_set_r root ?Y" unfolding unique_set_r_def by simp
   have "\<And>ys. \<lbrakk>sublist (U@V) ys; (\<forall>xs \<in> ?Y. sublist xs ys)\<rbrakk> \<Longrightarrow> (\<forall>xs \<in> ?X. sublist xs ys)"
     using combine_union_sets_sublists[of x, where Y=Y and X=X] U_def(3) by blast
   then have "\<And>ys. \<lbrakk>sublist (U@V) ys; fwd_sub root ?Y ys\<rbrakk> \<Longrightarrow> fwd_sub root ?X ys"
     unfolding P_eq fwd_sub_def by blast
   then show ?case using xs_def(1,2) cost by blast
 qed
 
 lemma bs_ge_if_geV:
   assumes "asi rank r cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "distinct (as@U@bs@V@cs)"
       and "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
       and "\<forall>xs \<in> Y. sublist xs (as@U@bs@V@cs)"
       and "take 1 (as@U@bs@V@cs) = [r]"
       and "bs \<noteq> []"
       and "\<forall>xs \<in> Y. xs \<noteq> U \<longrightarrow> rank (rev V) \<le> rank (rev xs)"
     shows "rank (rev V) \<le> rank (rev bs)"
 proof -
   obtain as' bs' cs' where bs'_def: "concat as' = as" "concat bs' = bs" "concat cs' = cs"
       "set (as'@U#bs'@V#cs') = Y"
     using concat_split_UV[OF assms(2,5-10)] assms(4,6,7) by blast
   have tk1: "take 1 (as@U) = [r]"
     using take1_split_nempty[of U as] assms(4,6,11) by force
   have "\<forall>z\<in>set bs'. z \<noteq> U"
     using bs'_def(2) assms(4,6,8) concat_all_sublist by (fastforce dest!: empty_if_sublist_dsjnt)
   then have 0: "\<forall>z\<in>set bs'. rank (rev V) \<le> rank (rev z)"
     using assms(13) bs'_def(4) by auto
   have "V \<noteq> []" using assms(4,7) by blast
   have "[] \<notin> set bs'" using assms(4) bs'_def(2,4) by auto
   then show ?thesis
     using bs_ge_if_all_ge[OF assms(1) \<open>V\<noteq>[]\<close>, of "as@U"] 0 bs'_def(2) tk1 assms(3,7,8,12) by auto
 qed
 
 lemma no_gap_if_geV:
   assumes "asi rank root cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "before U V"
       and "\<forall>xs \<in> Y. xs \<noteq> U \<longrightarrow> rank (rev V) \<le> rank (rev xs)"
       and "\<exists>x. fwd_sub root Y x"
     shows "\<exists>zs. fwd_sub root Y zs \<and> sublist (U@V) zs
           \<and> (\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 proof -
   obtain zs where zs_def:
       "set zs = \<Union>(set ` Y)" "distinct zs" "take 1 zs = [root]" "forward zs"
       "(\<forall>xs \<in> Y. sublist xs zs)" "(\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using forward_UV_lists_argmin_ex[OF assms(10), of "\<lambda>x. cost (rev x)"]
     unfolding fwd_sub_def unique_set_r_def by blast
   then have "hd zs = root" using hd_eq_take1 by fast
   then obtain as bs cs where bs_def: "as @ U @ bs @ V @ cs = zs"
     using sublist_before_if_before zs_def(2,4,5) assms(6-8) by blast
   then have bs_prems: "distinct (as@U@bs@V@cs)" "set (as@U@bs@V@cs) = \<Union>(set ` Y)"
     "\<forall>xs\<in>Y. sublist xs (as@U@bs@V@cs)" "take 1 (as@U@bs@V@cs) = [root]"
     using zs_def(1-5) by auto
   show ?thesis
   proof(cases "bs = []")
     case True
     then have "sublist (U@V) zs" using bs_def sublist_def by force
     then show ?thesis using zs_def unfolding fwd_sub_def unique_set_r_def by blast
   next
     case False
     then have rank_le: "rank (rev V) \<le> rank (rev bs)"
       using bs_ge_if_geV[OF assms(1-7) bs_prems False assms(9)] by blast
     have 0: "distinct ((as@U)@V@bs@cs)" using bs_def zs_def(2) by auto
     have "take 1 (as@U) = [root]"
       using bs_def assms(4,6) take1_split_nempty[of U as] zs_def(3) by fastforce
     then have 1: "take 1 (as@U@V@bs@cs) = [root]"
       using take1_singleton_app[of "as@U" root "V@bs@cs"] by simp
     have 2: "\<forall>xs\<in>Y. sublist xs (as@U@V@bs@cs)"
       using zs_def(5) bs_def sublists_preserv_move_VY_all[OF assms(2,6,7)] assms(4,6) by blast
     have "V \<noteq> []" using assms(4,7) by blast
     have "cost (rev (as@U@V@bs@cs)) \<le> cost (rev zs)"
       using asi_le_rfst[OF assms(1) rank_le \<open>V\<noteq>[]\<close> False 0] 1 zs_def(3) bs_def by simp
     then have cost_le: "\<forall>ys. fwd_sub root Y ys \<longrightarrow> cost (rev (as@U@V@bs@cs)) \<le> cost (rev ys)"
       using zs_def(6) by fastforce
     have "forward (as@U@V@bs@cs)"
       using move_mid_backward_if_noarc assms(8) zs_def(4) bs_def by blast
     moreover have "set (as@U@V@bs@cs) = \<Union>(set ` Y)" using bs_def zs_def(1) by fastforce
     ultimately have "fwd_sub root Y (as@U@V@bs@cs)"
       unfolding fwd_sub_def unique_set_r_def using 0 1 2 by auto
     moreover have "sublist (U@V) (as@U@V@bs@cs)" unfolding sublist_def by fastforce
     ultimately show ?thesis using cost_le by blast
   qed
 qed
 
 lemma app_UV_set_optimal_cost:
   assumes "asi rank root cost"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. forward xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "before U V"
       and "\<forall>xs \<in> Y. xs \<noteq> U \<longrightarrow> rank (rev V) \<le> rank (rev xs)"
       and "\<exists>x. fwd_sub root Y x"
     shows "\<exists>zs. fwd_sub root ({U@V} \<union> {x. x \<in> Y \<and> x \<noteq> U \<and> x \<noteq> V}) zs
             \<and> (\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 proof -
   have P_eq: "unique_set_r root Y = unique_set_r root ({U@V} \<union> {x. x \<in> Y \<and> x \<noteq> U \<and> x \<noteq> V})"
     unfolding unique_set_r_def using assms(6,7) by auto
   have "\<exists>zs. fwd_sub root Y zs \<and> sublist (U@V) zs
           \<and> (\<forall>as. fwd_sub root Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using no_gap_if_geV[OF assms(1-10)] by blast
   then show ?thesis unfolding P_eq fwd_sub_def by blast
 qed
 
 end
 
 context tree_query_graph
 begin
 
 lemma no_cross_ldeep_rev_if_forward:
   assumes "xs \<noteq> []" and "r \<in> verts G" and "directed_tree.forward (dir_tree_r r) (rev xs)"
   shows "no_cross_products (create_ldeep_rev xs)"
 using assms proof(induction xs rule: create_ldeep_rev.induct)
   case (3 x y ys)
   then interpret T: directed_tree "dir_tree_r r" r using directed_tree_r by blast
   have split: "create_ldeep_rev (x#y#ys) = Join (create_ldeep_rev (y#ys)) (Relation x)" by simp
   have "rev (x#y#ys) ! (length (y#ys)) = x" using nth_append_length[of "rev (y#ys)"] by simp
   moreover have "length (y#ys) \<in> {1..length (rev (x#y#ys)) - 1}" by simp
   ultimately obtain j where j_def: "j < (length (y#ys))" "rev (x#y#ys)!j \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x"
     using "3.prems"(3) unfolding T.forward_def by fastforce
   then have "rev (x#y#ys)!j \<in> set (y#ys)"
     using nth_mem[of j "rev (y#ys)"] by (auto simp add: nth_append)
   then have "\<exists>x'\<in>relations (create_ldeep_rev (y#ys)). x' \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x"
     using j_def(2) create_ldeep_rev_relations[of "y#ys"] by blast
   then have 1: "\<exists>x'\<in>relations (create_ldeep_rev (y#ys)). x' \<rightarrow>\<^bsub>G\<^esub>x"
     using assms(2) dir_tree_r_dom_in_G by blast
   have "T.forward (rev (y#ys))" using "3.prems"(3) T.forward_cons by blast
   then show ?case using 1 3 by simp
 qed(auto)
 
 lemma no_cross_ldeep_if_forward:
   "\<lbrakk>xs \<noteq> []; r \<in> verts G; directed_tree.forward (dir_tree_r r) xs\<rbrakk>
     \<Longrightarrow> no_cross_products (create_ldeep xs)"
   unfolding create_ldeep_def using no_cross_ldeep_rev_if_forward by simp
 
 lemma no_cross_ldeep_if_forward':
   "\<lbrakk>set xs = verts G; r \<in> verts G; directed_tree.forward (dir_tree_r r) xs\<rbrakk>
     \<Longrightarrow> no_cross_products (create_ldeep xs)"
   using no_cross_ldeep_if_forward[of xs] by fastforce
 
 lemma forward_if_ldeep_rev_no_cross:
   assumes "r \<in> verts G" and "no_cross_products (create_ldeep_rev xs)"
       and "hd (rev xs) = r" and "distinct xs"
     shows "directed_tree.forward_arcs (dir_tree_r r) xs"
 using assms proof(induction xs rule: create_ldeep_rev.induct)
   case 1
   then show ?case using directed_tree_r directed_tree.forward_arcs.simps(1) by fast
 next
   case (2 x)
   then show ?case using directed_tree_r directed_tree.forward_arcs.simps(2) by fast
 next
   case (3 x y ys)
   then interpret T: directed_tree "dir_tree_r r" r using directed_tree_r by blast
   have "hd (rev (y # ys)) = r" using "3.prems"(3) hd_append2[of "rev (y#ys)" "[x]"] by simp
   then have ind: "T.forward_arcs (y#ys)" using 3 by fastforce
   have matching: "matching_rels (create_ldeep_rev (x#y#ys))"
     using matching_rels_if_no_cross "3.prems"(2) by simp
   have "r \<in> relations (create_ldeep_rev (x#y#ys))" using "3.prems"(3)
     using create_ldeep_rev_relations[of "x#y#ys"] hd_rev[of "x#y#ys"] by simp
   then obtain p' where p'_def:
       "awalk r p' x \<and> set (awalk_verts r p') \<subseteq> relations (create_ldeep_rev (x#y#ys))"
     using no_cross_awalk[OF matching "3.prems"(2)] by force
   then obtain p where p_def:
       "apath r p x" "set (awalk_verts r p) \<subseteq> relations (create_ldeep_rev (x#y#ys))"
     using apath_awalk_to_apath awalk_to_apath_verts_subset by blast
   then have "pre_digraph.apath (dir_tree_r r) r p x" using apath_in_dir_if_apath_G by blast
   moreover have "r \<noteq> x"
     using "3.prems"(3,4) T.no_back_arcs.cases[of "rev (x#y#ys)"] distinct_first_uneq_last[of x]
     by fastforce
   ultimately obtain u where u_def:
       "u \<rightarrow>\<^bsub>dir_tree_r r\<^esub> x" "u \<in> set (pre_digraph.awalk_verts (dir_tree_r r) r p)"
     using p_def(2) T.awalk_verts_dom_if_uneq T.awalkI_apath by blast
   then have "u \<in> relations (create_ldeep_rev (x#y#ys))"
     using awalk_verts_G_T "3.prems"(1) p_def(2) by auto
   then have "u \<in> set (x#y#ys)" by (simp add: create_ldeep_rev_relations)
   then show ?case using u_def(1) ind T.forward_arcs.simps(3) T.loopfree.adj_not_same by auto
 qed
 
 lemma forward_if_ldeep_no_cross:
   "\<lbrakk>r \<in> verts G; no_cross_products (create_ldeep xs); hd xs = r; distinct xs\<rbrakk>
     \<Longrightarrow> directed_tree.forward (dir_tree_r r) xs"
   using forward_if_ldeep_rev_no_cross directed_tree.forward_arcs_alt directed_tree_r
   by (fastforce simp: create_ldeep_def)
 
 lemma no_cross_ldeep_iff_forward:
   "\<lbrakk>xs \<noteq> []; r \<in> verts G; hd xs = r; distinct xs\<rbrakk>
     \<Longrightarrow> no_cross_products (create_ldeep xs) \<longleftrightarrow> directed_tree.forward (dir_tree_r r) xs"
   using forward_if_ldeep_no_cross no_cross_ldeep_if_forward by blast
 
 lemma no_cross_if_fwd_ldeep:
   "\<lbrakk>r \<in> verts G; left_deep t; directed_tree.forward (dir_tree_r r) (inorder t)\<rbrakk>
     \<Longrightarrow> no_cross_products t"
   using no_cross_ldeep_if_forward[OF inorder_nempty] by fastforce
 
 lemma forward_if_ldeep_no_cross':
   "\<lbrakk>first_node t \<in> verts G; distinct_relations t; left_deep t; no_cross_products t\<rbrakk>
     \<Longrightarrow> directed_tree.forward (dir_tree_r (first_node t)) (inorder t)"
   using forward_if_ldeep_no_cross by (simp add: first_node_eq_hd distinct_relations_def)
 
 lemma no_cross_iff_forward_ldeep:
   "\<lbrakk>first_node t \<in> verts G; distinct_relations t; left_deep t\<rbrakk>
     \<Longrightarrow> no_cross_products t \<longleftrightarrow> directed_tree.forward (dir_tree_r (first_node t)) (inorder t)"
   using no_cross_if_fwd_ldeep forward_if_ldeep_no_cross' by blast
 
 lemma sublist_before_if_before:
   assumes "hd xs = r" and "no_cross_products (create_ldeep xs)" and "r \<in> verts G" and "distinct xs"
       and "sublist U xs" and "sublist V xs" and "directed_tree.before (dir_tree_r r) U V"
     shows "\<exists>as bs cs. as @ U @ bs @ V @ cs = xs"
   using directed_tree.sublist_before_if_before[OF directed_tree_r] forward_if_ldeep_no_cross assms
   by blast
 
 lemma nocross_UV_lists_subset:
   "{x. set x = X \<and> distinct x \<and> take 1 x = [r]
      \<and> no_cross_products (create_ldeep x) \<and> (\<forall>xs \<in> Y. sublist xs x)}
   \<subseteq> {x. set x = X \<and> distinct x}"
   by blast
 
 lemma nocross_UV_lists_finite:
   "finite xs
     \<Longrightarrow> finite {x. set x = xs \<and> distinct x \<and> take 1 x = [r]
       \<and> no_cross_products (create_ldeep x) \<and> (\<forall>xs \<in> Y. sublist xs x)}"
   using distinct_seteq_finite finite_subset[OF nocross_UV_lists_subset] by auto
 
 lemma nocross_UV_lists_arg_min_ex_aux:
   "\<lbrakk>finite ys; ys \<noteq> {};
     ys = {x. set x = xs \<and> distinct x \<and> take 1 x = [r]
            \<and> no_cross_products (create_ldeep x) \<and> (\<forall>xs \<in> Y. sublist xs x)}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using arg_min_if_finite(1)[of ys f] arg_min_least[of ys, where ?f = f] by auto
 
 lemma nocross_UV_lists_arg_min_ex:
   "\<lbrakk>finite xs; ys \<noteq> {};
     ys = {x. set x = xs \<and> distinct x \<and> take 1 x = [r]
            \<and> no_cross_products (create_ldeep x) \<and> (\<forall>xs \<in> Y. sublist xs x)}\<rbrakk>
     \<Longrightarrow> \<exists>y \<in> ys. \<forall>z \<in> ys. (f :: 'a list \<Rightarrow> real) y \<le> f z"
   using nocross_UV_lists_finite nocross_UV_lists_arg_min_ex_aux by auto
 
 lemma nocross_UV_lists_argmin_ex:
   fixes f :: "'a list \<Rightarrow> real"
   assumes "P = (\<lambda>x. set x = X \<and> distinct x \<and> take 1 x = [r])"
       and "Q = (\<lambda>ys. P ys \<and> no_cross_products (create_ldeep ys) \<and> (\<forall>xs \<in> Y. sublist xs ys))"
       and "\<exists>x. Q x"
     shows "\<exists>zs. Q zs \<and> (\<forall>as. Q as \<longrightarrow> f zs \<le> f as)"
   using nocross_UV_lists_arg_min_ex[of X "{x. Q x}"] using assms by fastforce
 
 lemma no_gap_if_contr_seq:
   fixes Y r
   defines "X \<equiv> \<Union>(set ` Y)"
   defines "P \<equiv> (\<lambda>ys. set ys = X \<and> distinct ys \<and> take 1 ys = [r])"
   defines "Q \<equiv> (\<lambda>ys. P ys \<and> no_cross_products (create_ldeep ys) \<and> (\<forall>xs \<in> Y. sublist xs ys))"
   assumes "asi rank r c"
       and "\<forall>xs \<in> Y. \<forall>ys \<in> Y. xs = ys \<or> set xs \<inter> set ys = {}"
       and "\<forall>xs \<in> Y. directed_tree.forward (dir_tree_r r) xs"
       and "[] \<notin> Y"
       and "finite Y"
       and "U \<in> Y"
       and "V \<in> Y"
       and "r \<in> verts G"
       and "directed_tree.before (dir_tree_r r) U V"
       and "rank (rev V) \<le> rank (rev U)"
       and "\<And>xs. \<lbrakk>xs \<in> Y; \<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>dir_tree_r r\<^esub> y)
             \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>dir_tree_r r\<^esub> y); xs \<noteq> U\<rbrakk>
               \<Longrightarrow> rank (rev V) \<le> rank (rev xs)"
       and "\<exists>x. Q x"
     shows "\<exists>zs. Q zs \<and> sublist (U@V) zs \<and> (\<forall>as. Q as \<longrightarrow> c (rev zs) \<le> c (rev as))"
 proof -
   interpret T: directed_tree "dir_tree_r r" r using assms(11) directed_tree_r by auto
   let ?Q = "(\<lambda>ys. P ys \<and> T.forward ys \<and> (\<forall>xs \<in> Y. sublist xs ys))"
   have "?Q = Q"
     using no_cross_ldeep_iff_forward assms(11,2,3) hd_eq_take1 nempty_if_take1[where r=r] by fast
   then show ?thesis
     using T.no_gap_if_contr_seq_fwd[OF assms(4-10,12-14)] assms(15,1,2)
     unfolding T.fwd_sub_def unique_set_r_def by auto
 qed
 
 end
 
 subsection "Arc Invariants"
 
 function path_lverts :: "('a list,'b) dtree \<Rightarrow> 'a \<Rightarrow> 'a set" where
   "path_lverts (Node r {|(t,e)|}) x = (if x \<in> set r then {} else set r \<union> path_lverts t x)"
 | "\<forall>x. xs \<noteq> {|x|} \<Longrightarrow> path_lverts (Node r xs) x = (if x \<in> set r then {} else set r)"
   by (metis darcs_mset.cases old.prod.exhaust) fast+
 termination by lexicographic_order
 
 definition path_lverts_list :: "('a list \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'a set" where
   "path_lverts_list xs x = (\<Union>(t,e)\<in> set (takeWhile (\<lambda>(t,e). x \<notin> set t) xs). set t)"
 
 definition dom_children :: "('a list,'b) dtree \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
   "dom_children t1 T = (\<forall>t \<in> fst ` fset (sucs t1). \<forall>x \<in> dverts t.
       \<exists>r \<in> set (root t1) \<union> path_lverts t (hd x). r \<rightarrow>\<^bsub>T\<^esub> hd x)"
 
 abbreviation children_deg1 :: "(('a,'b) dtree \<times> 'b) fset \<Rightarrow> (('a,'b) dtree \<times> 'b) set" where
   "children_deg1 xs \<equiv> {(t,e). (t,e) \<in> fset xs \<and> max_deg t \<le> 1}"
 
 lemma path_lverts_subset_dlverts: "path_lverts t x \<subseteq> dlverts t"
   by(induction t x rule: path_lverts.induct) auto
 
 lemma path_lverts_to_list_eq:
   "path_lverts t x = path_lverts_list (dtree_to_list (Node r0 {|(t,e)|})) x"
    by (induction t rule: dtree_to_list.induct) (auto simp: path_lverts_list_def)
 
 lemma path_lverts_from_list_eq:
   "path_lverts (dtree_from_list r0 ys) x = path_lverts_list ((r0,e0)#ys) x"
   unfolding path_lverts_list_def using path_lverts.simps(2)[of "{||}"]
   by (induction ys rule: dtree_from_list.induct) (force, cases "x \<in> set r0", auto)
 
 lemma path_lverts_child_union_root_sub:
   assumes "t2 \<in> fst ` fset (sucs t1)"
   shows "path_lverts t1 x \<subseteq> set (root t1) \<union> path_lverts t2 x"
 proof(cases "\<forall>x. sucs t1 \<noteq> {|x|}")
   case True
   then show ?thesis using path_lverts.simps(2)[of "sucs t1" "root t1"] by simp
 next
   case False
   then obtain e2 where "sucs t1 = {|(t2,e2)|}" using assms by fastforce
   then show ?thesis
     using path_lverts.simps(1)[of "root t1" t2 e2] dtree.collapse[of t1]
     by(cases "x \<in> set (root t1)") fastforce+
 qed
 
 lemma path_lverts_simps1_sucs:
   "\<lbrakk>x \<notin> set (root t1); sucs t1 = {|(t2,e2)|}\<rbrakk>
     \<Longrightarrow> set (root t1) \<union> path_lverts t2 x = path_lverts t1 x"
   using path_lverts.simps(1)[of "root t1" t2 e2 x] dtree.exhaust_sel[of t1] by argo
 
 lemma subtree_path_lverts_sub:
   "\<lbrakk>wf_dlverts t1; max_deg t1 \<le> 1; is_subtree (Node r xs) t1; t2 \<in> fst ` fset xs; x\<in>set (root t2)\<rbrakk>
     \<Longrightarrow> set r \<subseteq> path_lverts t1 x"
 proof(induction t1)
   case (Node r1 xs1)
   then have "xs1 \<noteq> {||}" by force
   then have "max_deg (Node r1 xs1) = 1"
     using Node.prems(2) empty_if_mdeg_0[of r1 xs1] by fastforce
   then obtain t e where t_def: "xs1 = {|(t,e)|}" using mdeg_1_singleton by fastforce
   have x_t2: "x \<in> dlverts t2" using Node.prems(5) lverts_if_in_verts dtree.set_sel(1) by fast
   show ?case
   proof(cases "Node r1 xs1 = Node r xs")
     case True
     then show ?thesis using Node.prems(1,4) x_t2 t_def by force
   next
     case False
     then have 0: "is_subtree (Node r xs) t" using t_def Node.prems(3) by force
     moreover have "max_deg t \<le> 1" using t_def Node.prems(2) mdeg_ge_child[of t e xs1] by simp
     moreover have "x \<notin> set r1" using t_def x_t2 Node.prems(1,4) 0 subtree_in_dlverts by force
     ultimately show ?thesis using Node.IH t_def Node.prems(1,4,5) by auto
   qed
 qed
 
 lemma path_lverts_empty_if_roothd:
   assumes "root t \<noteq> []"
   shows "path_lverts t (hd (root t)) = {}"
 proof(cases "\<forall>x. sucs t \<noteq> {|x|}")
   case True
   then show ?thesis using path_lverts.simps(2)[of "sucs t" "root t"] by force
 next
   case False
   then obtain t1 e1 where t1_def: "sucs t = {|(t1, e1)|}" by auto
   then have "path_lverts t (hd (root t)) =
     (if hd (root t) \<in> set (root t) then {} else set (root t) \<union> path_lverts t1 (hd (root t)))"
     using path_lverts.simps(1) dtree.collapse by metis
   then show ?thesis using assms by simp
 qed
 
 lemma path_lverts_subset_root_if_childhd:
   assumes "t1 \<in> fst ` fset (sucs t)" and "root t1 \<noteq> []"
   shows "path_lverts t (hd (root t1)) \<subseteq> set (root t)"
 proof(cases "\<forall>x. sucs t \<noteq> {|x|}")
   case True
   then show ?thesis using path_lverts.simps(2)[of "sucs t" "root t"] by simp
 next
   case False
   then obtain e1 where "sucs t = {|(t1, e1)|}" using assms(1) by fastforce
   then have "path_lverts t (hd (root t1)) =
     (if hd (root t1) \<in> set (root t) then {} else set (root t) \<union> path_lverts t1 (hd (root t1)))"
     using path_lverts.simps(1) dtree.collapse by metis
   then show ?thesis using path_lverts_empty_if_roothd[OF assms(2)] by auto
 qed
 
 lemma path_lverts_list_merge_supset_xs_notin:
   "\<forall>v \<in> fst ` set ys. a \<notin> set v
     \<Longrightarrow> path_lverts_list xs a \<subseteq> path_lverts_list (Sorting_Algorithms.merge cmp xs ys) a"
 proof(induction xs ys taking: cmp rule: Sorting_Algorithms.merge.induct)
   case (3 x xs y ys)
   obtain v1 e1 where v1_def[simp]: "x = (v1,e1)" by force
   obtain v2 e2 where "y = (v2,e2)" by force
   then show ?case using 3 by (auto simp: path_lverts_list_def)
 qed (auto simp: path_lverts_list_def)
 
 lemma path_lverts_list_merge_supset_ys_notin:
   "\<forall>v \<in> fst ` set xs. a \<notin> set v
     \<Longrightarrow> path_lverts_list ys a \<subseteq> path_lverts_list (Sorting_Algorithms.merge cmp xs ys) a"
 proof(induction xs ys taking: cmp rule: Sorting_Algorithms.merge.induct)
   case (3 x xs y ys)
   obtain v1 e1 where v1_def[simp]: "x = (v1,e1)" by force
   obtain v2 e2 where "y = (v2,e2)" by force
   then show ?case using 3 by (auto simp: path_lverts_list_def)
 qed (auto simp: path_lverts_list_def)
 
 lemma path_lverts_list_merge_supset_xs:
   "\<lbrakk>\<exists>v \<in> fst ` set xs. a \<in> set v; \<forall>v1 \<in> fst ` set xs. \<forall>v2 \<in> fst ` set ys. set v1 \<inter> set v2 = {}\<rbrakk>
     \<Longrightarrow> path_lverts_list xs a \<subseteq> path_lverts_list (Sorting_Algorithms.merge cmp xs ys) a"
   using path_lverts_list_merge_supset_xs_notin by fast
 
 lemma path_lverts_list_merge_supset_ys:
   "\<lbrakk>\<exists>v \<in> fst ` set ys. a \<in> set v; \<forall>v1 \<in> fst ` set xs. \<forall>v2 \<in> fst ` set ys. set v1 \<inter> set v2 = {}\<rbrakk>
     \<Longrightarrow> path_lverts_list ys a \<subseteq> path_lverts_list (Sorting_Algorithms.merge cmp xs ys) a"
   using path_lverts_list_merge_supset_ys_notin by fast
 
 lemma dom_children_if_all_singletons:
   "\<forall>(t1,e1) \<in> fset xs. dom_children (Node r {|(t1, e1)|}) T \<Longrightarrow> dom_children (Node r xs) T"
   by (auto simp: dom_children_def)
 
 lemma dom_children_all_singletons:
   "\<lbrakk>dom_children (Node r xs) T; (t1,e1) \<in> fset xs\<rbrakk> \<Longrightarrow> dom_children (Node r {|(t1, e1)|}) T"
   by (auto simp: dom_children_def)
 
 lemma dom_children_all_singletons':
   "\<lbrakk>dom_children (Node r xs) T; t1\<in> fst ` fset xs\<rbrakk> \<Longrightarrow> dom_children (Node r {|(t1, e1)|}) T"
   by (auto simp: dom_children_def)
 
 lemma root_arc_if_dom_root_child_nempty:
   "\<lbrakk>dom_children (Node r xs) T; t1 \<in> fst ` fset xs; root t1 \<noteq> []\<rbrakk>
     \<Longrightarrow> \<exists>x\<in>set r. \<exists>y\<in>set (root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   unfolding dom_children_def using dtree.set_sel(1)  path_lverts_empty_if_roothd[of t1]
   by fastforce
 
 lemma root_arc_if_dom_root_child_wfdlverts:
   "\<lbrakk>dom_children (Node r xs) T; t1 \<in> fst ` fset xs; wf_dlverts t1\<rbrakk>
     \<Longrightarrow> \<exists>x\<in>set r. \<exists>y\<in>set (root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   using root_arc_if_dom_root_child_nempty dtree.set_sel(1)[of t1] empty_notin_wf_dlverts
   by fastforce
 
 lemma root_arc_if_dom_wfdlverts:
   "\<lbrakk>dom_children (Node r xs) T; t1 \<in> fst ` fset xs; wf_dlverts (Node r xs)\<rbrakk>
     \<Longrightarrow> \<exists>x\<in>set r. \<exists>y\<in>set (root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   using root_arc_if_dom_root_child_wfdlverts[of r xs T t1] by fastforce
 
 lemma children_deg1_sub_xs: "{(t,e). (t,e) \<in> fset xs \<and> max_deg t \<le> 1} \<subseteq> (fset xs)"
   by blast
 
 lemma finite_children_deg1: "finite {(t,e). (t,e) \<in> fset xs \<and> max_deg t \<le> 1}"
   using children_deg1_sub_xs[of xs] by (simp add: finite_subset)
 
 lemma finite_children_deg1': "{(t,e). (t,e) \<in> fset xs \<and> max_deg t \<le> 1} \<in> {A. finite A}"
   using finite_children_deg1 by blast
 
 lemma children_deg1_fset_id[simp]: "fset (Abs_fset (children_deg1 xs)) = children_deg1 xs"
   using Abs_fset_inverse[OF finite_children_deg1'] by auto
 
 lemma xs_sub_children_deg1: "\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1 \<Longrightarrow> (fset xs) \<subseteq> children_deg1 xs"
   by auto
 
 lemma children_deg1_full:
   "\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1 \<Longrightarrow> (Abs_fset (children_deg1 xs)) = xs"
   using xs_sub_children_deg1[of xs] children_deg1_sub_xs[of xs] by (simp add: fset_inverse)
 
 locale ranked_dtree_with_orig = ranked_dtree t rank cmp + directed_tree T root
   for t :: "('a list, 'b) dtree" and rank cost cmp and T :: "('a, 'b) pre_digraph" and root +
   assumes asi_rank: "asi rank root cost"
       and dom_mdeg_gt1:
     "\<lbrakk>is_subtree (Node r xs) t; t1 \<in> fst ` fset xs; max_deg (Node r xs) > 1\<rbrakk>
       \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
       and dom_sub_contr:
     "\<lbrakk>is_subtree (Node r xs) t; t1 \<in> fst ` fset xs;
       \<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r xs) \<and> rank (rev (Dtree.root t2)) < rank (rev v)\<rbrakk>
       \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
       and dom_contr:
     "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; rank (rev (Dtree.root t1)) < rank (rev r);
       max_deg (Node r {|(t1,e1)|}) = 1\<rbrakk>
       \<Longrightarrow> dom_children (Node r {|(t1,e1)|}) T"
       and dom_wedge:
     "\<lbrakk>is_subtree (Node r xs) t; fcard xs > 1\<rbrakk>
       \<Longrightarrow> dom_children (Node r (Abs_fset (children_deg1 xs))) T"
       and arc_in_dlverts:
     "\<lbrakk>is_subtree (Node r xs) t; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts (Node r xs)"
       and verts_conform: "v \<in> dverts t \<Longrightarrow> seq_conform v"
       and verts_distinct: "v \<in> dverts t \<Longrightarrow> distinct v"
 begin
 
 lemma dom_contr':
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; rank (rev (Dtree.root t1)) < rank (rev r);
     max_deg (Node r {|(t1,e1)|}) \<le> 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r {|(t1,e1)|}) T"
   using dom_contr mdeg_ge_sub mdeg_singleton[of r t1] by (simp add: fcard_single_1)
 
 lemma dom_self_contr:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; rank (rev (Dtree.root t1)) < rank (rev r)\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
   using dom_sub_contr by fastforce
 
 lemma dom_wedge_full:
   "\<lbrakk>is_subtree (Node r xs) t; fcard xs > 1; \<forall>t \<in> fst ` fset xs. max_deg t \<le> 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r xs) T"
   using dom_wedge children_deg1_full by fastforce
 
 lemma dom_wedge_singleton:
   "\<lbrakk>is_subtree (Node r xs) t; fcard xs > 1; t1 \<in> fst ` fset xs; max_deg t1 \<le> 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r {|(t1,e1)|}) T"
   using dom_children_all_singletons' dom_wedge children_deg1_fset_id by fastforce
 
 lemma arc_to_dverts_in_subtree:
   "\<lbrakk>is_subtree (Node r xs) t; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y; y \<in> set v; v \<in> dverts t\<rbrakk>
     \<Longrightarrow> v \<in> dverts (Node r xs)"
   using list_in_verts_if_lverts[OF arc_in_dlverts] dverts_same_if_set_wf[OF wf_lverts]
     dverts_subtree_subset by blast
 
 lemma dlverts_arc_in_dlverts:
   "\<lbrakk>is_subtree t1 t; x \<rightarrow>\<^bsub>T\<^esub> y; x \<in> dlverts t1\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
 proof(induction t1)
   case (Node r xs)
   then show ?case
   proof(cases "x \<in> set r")
     case True
     then show ?thesis using arc_in_dlverts Node.prems(1,2) by blast
   next
     case False
     then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset xs" "x \<in> dlverts t2"
       using Node.prems(3) by auto
     then have "is_subtree t2 (Node r xs)" using subtree_if_child
       by (metis image_iff prod.sel(1))
     then have "is_subtree t2 t" using Node.prems(1) subtree_trans by blast
     then show ?thesis using Node.IH Node.prems(2) t2_def by fastforce
   qed
 qed
 
 lemma dverts_arc_in_dlverts:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
   using dlverts_arc_in_dlverts by (simp add: lverts_if_in_verts)
 
 lemma dverts_arc_in_dverts:
   assumes "is_subtree t1 t"
       and "v1 \<in> dverts t1"
       and "x \<in> set v1"
       and "x \<rightarrow>\<^bsub>T\<^esub> y"
       and "y \<in> set v2"
       and "v2 \<in> dverts t"
     shows "v2 \<in> dverts t1"
 proof -
   have "x \<in> dlverts t1" using assms(2,3) lverts_if_in_verts by fast
   then obtain v where v_def: "v\<in>dverts t1" "y \<in> set v"
     using list_in_verts_if_lverts[OF dlverts_arc_in_dlverts] assms(1-4) lverts_if_in_verts by blast
   then show ?thesis
     using dverts_same_if_set_wf[OF wf_lverts] assms(1,5,6) dverts_subtree_subset by blast
 qed
 
 lemma dlverts_reach1_in_dlverts:
   "\<lbrakk>x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; is_subtree t1 t; x \<in> dlverts t1\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
   by(induction x y rule: trancl.induct) (auto simp: dlverts_arc_in_dlverts)
 
 lemma dlverts_reach_in_dlverts:
   "\<lbrakk>x \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y; is_subtree t1 t; x \<in> dlverts t1\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
   using dlverts_reach1_in_dlverts by blast
 
 lemma dverts_reach1_in_dlverts:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
   using dlverts_reach1_in_dlverts by (simp add: lverts_if_in_verts)
 
 lemma dverts_reach_in_dlverts:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts t1"
   using list_in_verts_iff_lverts dverts_reach1_in_dlverts by (cases "x=y",fastforce,blast)
 
 lemma dverts_reach1_in_dverts:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; y \<in> set v2; v2 \<in> dverts t\<rbrakk>
     \<Longrightarrow> v2 \<in> dverts t1"
   by (meson dverts_reach1_in_dlverts dverts_arc_in_dverts list_in_verts_if_lverts tranclE)
 
 lemma dverts_same_if_set_subtree:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<in> set v2; v2 \<in> dverts t\<rbrakk> \<Longrightarrow> v1 = v2"
   using dverts_same_if_set_wf[OF wf_lverts] dverts_subtree_subset by blast
 
 lemma dverts_reach_in_dverts:
   "\<lbrakk>is_subtree t1 t; v1 \<in> dverts t1; x \<in> set v1; x \<rightarrow>\<^sup>*\<^bsub>T\<^esub> y; y \<in> set v2; v2 \<in> dverts t\<rbrakk>
     \<Longrightarrow> v2 \<in> dverts t1"
   using dverts_same_if_set_subtree dverts_reach1_in_dverts by blast
 
 lemma dverts_reach1_in_dverts_root:
   "\<lbrakk>is_subtree t1 t; v \<in> dverts t; \<exists>x\<in>set (Dtree.root t1). \<exists>y\<in>set v. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> v \<in> dverts t1"
   using dverts_reach1_in_dverts dtree.set_sel(1) by blast
 
 lemma dverts_reach1_in_dverts_r:
   "\<lbrakk>is_subtree (Node r xs) t; v \<in> dverts t; \<exists>x\<in>set r. \<exists>y\<in>set v. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> v \<in> dverts (Node r xs)"
   using dverts_reach1_in_dverts[of "Node r xs"] by (auto intro: dtree.set_intros(1))
 
 lemma dom_mdeg_gt1_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r xs) tn; t1 \<in> fst ` fset xs; max_deg (Node r xs) > 1\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
   using dom_mdeg_gt1 subtree_trans by blast
 
 lemma dom_sub_contr_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r xs) tn; t1 \<in> fst ` fset xs;
     \<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r xs) \<and> rank (rev (Dtree.root t2)) < rank (rev v)\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
   using dom_sub_contr subtree_trans by blast
 
 lemma dom_contr_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r {|(t1,e1)|}) tn; rank (rev (Dtree.root t1)) < rank (rev r);
     max_deg (Node r {|(t1,e1)|}) = 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r {|(t1,e1)|}) T"
   using dom_contr subtree_trans by blast
 
 lemma dom_wedge_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r xs) tn; fcard xs > 1\<rbrakk>
       \<Longrightarrow> dom_children (Node r (Abs_fset (children_deg1 xs))) T"
   using dom_wedge subtree_trans by blast
 
 corollary dom_wedge_subtree':
   "is_subtree tn t \<Longrightarrow>\<forall>r xs. is_subtree (Node r xs) tn \<longrightarrow> fcard xs > 1
     \<longrightarrow> dom_children (Node r (Abs_fset {(t, e). (t, e) \<in> fset xs \<and> max_deg t \<le> Suc 0})) T"
   by (auto simp only: dom_wedge_subtree One_nat_def[symmetric])
 
 lemma dom_wedge_full_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r xs) tn; fcard xs > 1; \<forall>t \<in> fst ` fset xs. max_deg t \<le> 1\<rbrakk>
       \<Longrightarrow> dom_children (Node r xs) T"
   using dom_wedge_full subtree_trans by fast
 
 lemma arc_in_dlverts_subtree:
   "\<lbrakk>is_subtree tn t; is_subtree (Node r xs) tn; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts (Node r xs)"
   using arc_in_dlverts subtree_trans by blast
 
 corollary arc_in_dlverts_subtree':
   "is_subtree tn t \<Longrightarrow> \<forall>r xs. is_subtree (Node r xs) tn \<longrightarrow> (\<forall>x. x \<in> set r
     \<longrightarrow> (\<forall>y. x \<rightarrow>\<^bsub>T\<^esub> y \<longrightarrow> y \<in> set r \<or> (\<exists>c\<in>fset xs. y \<in> dlverts (fst c))))"
   using arc_in_dlverts_subtree by simp
 
 lemma verts_conform_subtree: "\<lbrakk>is_subtree tn t; v \<in> dverts tn\<rbrakk> \<Longrightarrow> seq_conform v"
   using verts_conform dverts_subtree_subset by blast
 
 lemma verts_distinct_subtree: "\<lbrakk>is_subtree tn t; v \<in> dverts tn\<rbrakk> \<Longrightarrow> distinct v"
   using verts_distinct dverts_subtree_subset by blast
 
 lemma ranked_dtree_orig_subtree: "is_subtree x t \<Longrightarrow> ranked_dtree_with_orig x rank cost cmp T root"
   unfolding ranked_dtree_with_orig_def ranked_dtree_with_orig_axioms_def
   by (simp add: ranked_dtree_subtree directed_tree_axioms dom_mdeg_gt1_subtree dom_contr_subtree
       dom_sub_contr_subtree dom_wedge_subtree' arc_in_dlverts_subtree'
       verts_conform_subtree verts_distinct_subtree asi_rank)
 
 corollary ranked_dtree_orig_rec:
   "\<lbrakk>Node r xs = t; (x,e) \<in> fset xs\<rbrakk> \<Longrightarrow> ranked_dtree_with_orig x rank cost cmp T root"
   using ranked_dtree_orig_subtree[of x] subtree_if_child[of x xs] by force
 
 lemma child_disjoint_root:
   "\<lbrakk>is_subtree (Node r xs) t; t1 \<in> fst ` fset xs\<rbrakk> \<Longrightarrow> set r \<inter> set (Dtree.root t1) = {}"
   using wf_dlverts_subtree[OF wf_lverts] dlverts_eq_dverts_union dtree.set_sel(1) by fastforce
 
 lemma distint_verts_subtree:
   assumes "is_subtree (Node r xs) t" and "t1 \<in> fst ` fset xs"
   shows "distinct (r @ Dtree.root t1)"
 proof -
   have "(Dtree.root t1) \<in> dverts t" using dtree.set_sel(1) assms dverts_subtree_subset by fastforce
   then show ?thesis
     using verts_distinct assms(1) dverts_subtree_subset child_disjoint_root[OF assms] by force
 qed
 
 corollary distint_verts_singleton_subtree:
   "is_subtree (Node r {|(t1,e1)|}) t \<Longrightarrow> distinct (r @ Dtree.root t1)"
   using distint_verts_subtree by simp
 
 lemma dom_between_child_roots:
   assumes "is_subtree (Node r {|(t1,e1)|}) t" and "rank (rev (Dtree.root t1)) < rank (rev r)"
   shows "\<exists>x\<in>set r. \<exists>y\<in>set (Dtree.root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   using dom_self_contr[OF assms] wf_dlverts_subtree[OF wf_lverts assms(1)]
     hd_in_set[of "Dtree.root t1"] dtree.set_sel(1)[of t1] empty_notin_wf_dlverts[of t1] by fastforce
 
 lemma contr_before:
   assumes "is_subtree (Node r {|(t1,e1)|}) t" and "rank (rev (Dtree.root t1)) < rank (rev r)"
   shows "before r (Dtree.root t1)"
 proof -
   have "(Dtree.root t1) \<in> dverts t" using dtree.set_sel(1) assms(1) dverts_subtree_subset by fastforce
   then have "seq_conform (Dtree.root t1)" using verts_conform by simp
   moreover have "seq_conform r" using verts_conform assms(1) dverts_subtree_subset by force
   ultimately show ?thesis
     using before_def dom_between_child_roots[OF assms] child_disjoint_root[OF assms(1)] by auto
 qed
 
 lemma contr_forward:
   assumes "is_subtree (Node r {|(t1,e1)|}) t" and "rank (rev (Dtree.root t1)) < rank (rev r)"
   shows "forward (r@Dtree.root t1)"
 proof -
   have "(Dtree.root t1) \<in> dverts t" using dtree.set_sel(1) assms(1) dverts_subtree_subset by fastforce
   then have "seq_conform (Dtree.root t1)" using verts_conform by simp
   moreover have "seq_conform r" using verts_conform assms(1) dverts_subtree_subset by force
   ultimately show ?thesis
     using seq_conform_def forward_arcs_alt dom_self_contr assms forward_app by simp
 qed
 
 lemma contr_seq_conform:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; rank (rev (Dtree.root t1)) < rank (rev r)\<rbrakk>
     \<Longrightarrow> seq_conform (r @ Dtree.root t1)"
   using seq_conform_if_before contr_before by simp
 
 lemma verts_forward: "\<forall>v \<in> dverts t. forward v"
   using seq_conform_alt verts_conform by simp
 
 lemma dverts_reachable1_if_dom_children_aux_root:
   assumes "\<forall>v\<in>dverts (Node r xs). \<exists>x\<in>set r0 \<union> X \<union> path_lverts (Node r xs) (hd v). x \<rightarrow>\<^bsub>T\<^esub> hd v"
       and "\<forall>y\<in>X. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
       and "forward r"
     shows "\<forall>y\<in>set r. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof(cases "r = []")
   case False
   then have "path_lverts (Node r xs) (hd r) = {}"
     using path_lverts_empty_if_roothd[of "Node r xs"] by simp
   then obtain x where x_def: "x\<in>set r0 \<union> X" "x \<rightarrow>\<^bsub>T\<^esub> hd r" using assms(1) by auto
   then have "hd r \<in> verts T" using adj_in_verts(2) by auto
   then have "\<forall>y\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
     using hd_reach_all_forward x_def(2) assms(3) reachable1_reachable_trans by blast
   moreover obtain y where "y \<in> set r0" "y \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x" using assms(2) x_def by auto
   ultimately show ?thesis using reachable_reachable1_trans by blast
 qed(simp)
 
 lemma dverts_reachable1_if_dom_children_aux:
   "\<lbrakk>\<forall>v\<in>dverts t1. \<exists>x\<in>set r0 \<union> X \<union> path_lverts t1 (hd v). x \<rightarrow>\<^bsub>T\<^esub> hd v;
      \<forall>y\<in>X. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; \<forall>v\<in>dverts t1. forward v; v\<in>dverts t1\<rbrakk>
     \<Longrightarrow> \<forall>y\<in>set v. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof(induction t1 arbitrary: X rule: dtree_to_list.induct)
   case (1 r t e)
   have r_reachable1: "\<forall>y\<in>set r. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
    using dverts_reachable1_if_dom_children_aux_root[OF "1.prems"(1,2)] "1.prems"(3) by simp
   then show ?case
   proof(cases "r = v")
     case True
     then show ?thesis using r_reachable1 by simp
   next
     case False
     have r_reach1: "\<forall>y\<in>set r \<union> X. \<exists>x\<in>set r0. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y" using "1.prems"(2) r_reachable1 by blast
     have "\<forall>x. path_lverts (Node r {|(t, e)|}) x \<subseteq> set r \<union> path_lverts t x"
       by simp
     then have 0: "\<forall>v\<in>dverts t. \<exists>x\<in>set r0 \<union> (set r \<union> X) \<union> (path_lverts t (hd v)). x \<rightarrow>\<^bsub>T\<^esub> hd v"
       using "1.prems"(1) by fastforce
     then show ?thesis using "1.IH"[OF 0 r_reach1] "1.prems"(3,4) False by simp
   qed
 next
   case (2 xs r)
   then show ?case
   proof(cases "\<exists>x\<in>set r0 \<union> X. x \<rightarrow>\<^bsub>T\<^esub> hd v")
     case True
     then obtain x where x_def: "x\<in>set r0 \<union> X" "x \<rightarrow>\<^bsub>T\<^esub> hd v" using "2.prems"(1,4) by blast
     then have "hd v \<in> verts T" using x_def(2) adj_in_verts(2) by auto
     moreover have "forward v" using "2.prems"(3,4) by blast
     ultimately have v_reach1: "\<forall>y\<in>set v. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
       using hd_reach_all_forward x_def(2) reachable1_reachable_trans by blast
     then show ?thesis using "2.prems"(2) x_def(1) reachable_reachable1_trans by blast
   next
     case False
     then obtain x where x_def: "x \<in> path_lverts (Node r xs) (hd v)" "x \<rightarrow>\<^bsub>T\<^esub> hd v"
       using "2.prems"(1,4) by blast
     then have "x \<in> set r" using path_lverts.simps(2)[OF "2.hyps"] empty_iff by metis
     then obtain x' where x'_def: "x'\<in>set r0" "x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> x"
       using dverts_reachable1_if_dom_children_aux_root[OF "2.prems"(1,2)] "2.prems"(3) by auto
     then have x'_v: "x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> hd v" using x_def(2) by simp
     then have "hd v \<in> verts T" using x_def(2) adj_in_verts(2) by auto
     moreover have "forward v" using "2.prems"(3,4) by blast
     ultimately have v_reach1: "\<forall>y\<in>set v. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
       using hd_reach_all_forward x'_v reachable1_reachable_trans by blast
     then show ?thesis using x'_def(1) by blast
   qed
 qed
 
 lemma dlverts_reachable1_if_dom_children_aux:
   "\<lbrakk>\<forall>v\<in>dverts t1. \<exists>x\<in>set r \<union> X \<union> path_lverts t1 (hd v). x \<rightarrow>\<^bsub>T\<^esub> hd v;
      \<forall>y\<in>X. \<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; \<forall>v\<in>dverts t1. forward v; y\<in>dlverts t1\<rbrakk>
     \<Longrightarrow> \<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
   using dverts_reachable1_if_dom_children_aux list_in_verts_iff_lverts[of y t1] by blast
 
 lemma dverts_reachable1_if_dom_children:
   assumes "dom_children t1 T" and "v \<in> dverts t1" and "v \<noteq> Dtree.root t1" and "\<forall>v\<in>dverts t1. forward v"
   shows "\<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t1). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof -
   obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t1)" "v \<in> dverts t2"
     using assms(2,3) dverts_root_or_suc by force
   then have 0: "\<forall>v\<in>dverts t2. \<exists>x\<in>set (Dtree.root t1) \<union> {} \<union> path_lverts t2 (hd v). x \<rightarrow>\<^bsub>T\<^esub> hd v"
     using assms(1) unfolding dom_children_def by blast
   moreover have "\<forall>v\<in>dverts t2. forward v" using assms(4) t2_def(1) dverts_suc_subseteq by blast
   ultimately show ?thesis using dverts_reachable1_if_dom_children_aux t2_def(2) by blast
 qed
 
 lemma subtree_dverts_reachable1_if_mdeg_gt1:
   "\<lbrakk>is_subtree t1 t; max_deg t1 > 1; v \<in> dverts t1; v \<noteq> Dtree.root t1\<rbrakk>
     \<Longrightarrow> \<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t1). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof(induction t1)
   case (Node r xs)
   then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset xs" "v \<in> dverts t2" by auto
   then obtain x where x_def: "x\<in>set r" "x \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t2)"
     using dom_mdeg_gt1 Node.prems(1,2) by fastforce
   then have t2_T: "hd (Dtree.root t2) \<in> verts T" using adj_in_verts(2) by simp
   have "is_subtree t2 (Node r xs)" using subtree_if_child[of t2 xs r] t2_def(1) by force
   then have subt2: "is_subtree t2 t" using subtree_trans Node.prems(1) by blast
   have "Dtree.root t2 \<in> dverts t"
     using subt2 dverts_subtree_subset by (fastforce simp: dtree.set_sel(1))
   then have fwd_t2: "forward (Dtree.root t2)" by (simp add: verts_forward)
   then have t2_reach1: "\<forall>y\<in>set (Dtree.root t2). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
     using hd_reach_all_forward[OF t2_T fwd_t2] x_def(2) reachable1_reachable_trans by blast
   then consider "Dtree.root t2 = v" | "Dtree.root t2 \<noteq> v" "max_deg t2 > 1" | "Dtree.root t2 \<noteq> v" "max_deg t2 \<le> 1"
     by fastforce
   then show ?case
   proof(cases)
     case 1
     then show ?thesis using t2_reach1 x_def(1) by auto
   next
     case 2
     then have "\<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t2). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y" using Node.IH subt2 t2_def by simp
     then show ?thesis
       using t2_reach1 x_def(1) reachable1_reachable reachable1_reachable_trans
       unfolding dtree.sel(1) by blast
   next
     case 3
     then have "fcard xs > 1" using Node.prems(2) t2_def(1) fcard_gt1_if_mdeg_gt_child1 by fastforce
     then have dom: "dom_children (Node r {|(t2,e2)|}) T"
       using dom_wedge_singleton[OF Node.prems(1)] t2_def(1) 3(2) by fastforce
     have "\<forall>v \<in> dverts (Node r xs). forward v"
       using Node.prems(1) seq_conform_alt verts_conform_subtree by blast
     then have "\<forall>v \<in> dverts (Node r {|(t2, e2)|}). forward v" using t2_def(1) by simp
     then show ?thesis
       using dverts_reachable1_if_dom_children[OF dom] t2_def(2) Node.prems(4)
       unfolding dtree.sel(1) by simp
   qed
 qed
 
 lemma subtree_dverts_reachable1_if_mdeg_gt1_singleton:
   assumes "is_subtree (Node r {|(t1,e1)|}) t"
       and "max_deg (Node r {|(t1,e1)|}) > 1"
       and "v \<in> dverts t1"
       and "v \<noteq> Dtree.root t1"
     shows "\<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t1). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof -
   have "is_subtree t1 t" using subtree_trans[OF subtree_if_child assms(1)] by simp
   then show ?thesis
     using assms(2-4) mdeg_eq_child_if_singleton_gt1[OF assms(2)]
       subtree_dverts_reachable1_if_mdeg_gt1 by simp
 qed
 
 lemma subtree_dverts_reachable1_if_mdeg_le1_subcontr:
   "\<lbrakk>is_subtree t1 t; max_deg t1 \<le> 1; is_subtree (Node v2 {|(t2,e2)|}) t1;
     rank (rev (Dtree.root t2)) < rank (rev v2); v \<in> dverts t1; v \<noteq> Dtree.root t1\<rbrakk>
     \<Longrightarrow> \<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t1). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof(induction t1)
   case (Node r xs)
   then show ?case
   proof(cases "Node v2 {|(t2,e2)|} = Node r xs")
     case True
     then have "dom_children (Node r xs) T" using dom_contr' Node.prems(1,2,4) by blast
     moreover have "\<forall>v \<in> dverts (Node r xs). forward v"
       using Node.prems(1) seq_conform_alt verts_conform_subtree by blast
     ultimately show ?thesis using dverts_reachable1_if_dom_children Node.prems(5,6) by blast
   next
     case False
     then obtain t3 e3 where t3_def: "(t3,e3) \<in> fset xs" "is_subtree (Node v2 {|(t2,e2)|}) t3"
       using Node.prems(3) by auto
     then have t3_xs: "xs = {|(t3,e3)|}"
       using Node.prems(2) by (simp add: singleton_if_mdeg_le1_elem)
     then have v_t3: "v \<in> dverts t3" using Node.prems(5,6) by simp
     then have t3_dom: "\<exists>x\<in>set r. x \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t3)"
       using dom_sub_contr Node.prems(1,3,4) t3_xs by fastforce
     then have t3_T: "hd (Dtree.root t3) \<in> verts T" using adj_in_verts(2) by blast
     have "is_subtree t3 (Node r xs)" using subtree_if_child[of t3 xs] t3_xs by simp
     then have sub_t3: "is_subtree t3 t" using subtree_trans Node.prems(1) by blast
     then have "Dtree.root t3 \<in> dverts t"
       using dverts_subtree_subset by (fastforce simp: dtree.set_sel(1))
     then have "forward (Dtree.root t3)" by (simp add: verts_forward)
     then have t3_reach1: "\<exists>x\<in>set r. \<forall>y\<in>set(Dtree.root t3). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
       using hd_reach_all_forward[OF t3_T] t3_dom reachable1_reachable_trans by blast
     show ?thesis
     proof(cases "v = Dtree.root t3")
       case True
       then show ?thesis using t3_reach1 by auto
     next
       case False
       moreover have "max_deg t3 \<le> 1" using Node.prems(2) t3_def(1) mdeg_ge_child by fastforce
       ultimately have "\<forall>y\<in>set v. \<exists>x\<in>set (Dtree.root t3). x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
         using Node.IH sub_t3 t3_def Node.prems(4) v_t3 by simp
       then show ?thesis
         using t3_reach1 reachable1_reachable_trans reachable1_reachable unfolding dtree.sel(1)
         by blast
     qed
   qed
 qed
 
 lemma subtree_y_reach_if_mdeg_gt1_notroot_reach:
   assumes "is_subtree (Node r {|(t1,e1)|}) t"
       and "max_deg (Node r {|(t1,e1)|}) > 1"
       and "v \<noteq> r"
       and "v \<in> dverts t"
       and "v \<noteq> Dtree.root t1"
       and "y \<in> set v"
       and "\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
     shows "\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof -
   have "v \<in> dverts (Node r {|(t1,e1)|})" using dverts_reach1_in_dverts_r assms(1,4,6,7) by blast
   then show ?thesis using subtree_dverts_reachable1_if_mdeg_gt1_singleton assms(1-3,5,6) by simp
 qed
 
 lemma subtree_eqroot_if_mdeg_gt1_reach:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; max_deg (Node r {|(t1,e1)|}) > 1; v \<in> dverts t;
     \<exists>y\<in>set v. \<not>(\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); v \<noteq> r\<rbrakk>
     \<Longrightarrow> Dtree.root t1 = v"
   using subtree_y_reach_if_mdeg_gt1_notroot_reach by blast
 
 lemma subtree_rank_ge_if_mdeg_gt1_reach:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; max_deg (Node r {|(t1,e1)|}) > 1; v \<in> dverts t;
     \<exists>y\<in>set v. \<not>(\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y); v \<noteq> r\<rbrakk>
     \<Longrightarrow> rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using subtree_eqroot_if_mdeg_gt1_reach by blast
 
 lemma subtree_y_reach_if_mdeg_le1_notroot_subcontr:
   assumes "is_subtree (Node r {|(t1,e1)|}) t"
       and "max_deg (Node r {|(t1,e1)|}) \<le> 1"
       and "is_subtree (Node v2 {|(t2,e2)|}) t1"
       and "rank (rev (Dtree.root t2)) < rank (rev v2)"
       and "v \<noteq> r"
       and "v \<in> dverts t"
       and "v \<noteq> Dtree.root t1"
       and "y \<in> set v"
       and "\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
     shows "\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
 proof -
   have 0: "is_subtree t1 (Node r {|(t1,e1)|})" using subtree_if_child[of t1 "{|(t1,e1)|}"] by simp
   then have subt1: "is_subtree t1 t" using assms(1) subtree_trans by blast
   have "v \<in> dverts (Node r {|(t1,e1)|})"
     using dverts_reach1_in_dverts_r assms(1,6,8,9) by blast
   then have "v \<in> dverts t1" using assms(5) by simp
   moreover have "max_deg t1 \<le> 1" using assms(2) mdeg_ge_sub[OF 0] by simp
   ultimately show ?thesis
     using subtree_dverts_reachable1_if_mdeg_le1_subcontr[OF subt1] assms(3,4,7,8) by blast
 qed
 
 lemma rank_ge_if_mdeg_le1_dvert_nocontr:
   assumes "max_deg t1 \<le> 1"
       and "\<nexists>v2 t2 e2. is_subtree (Node v2 {|(t2,e2)|}) t1 \<and> rank (rev (Dtree.root t2)) < rank (rev v2)"
       and "v \<in> dverts t1"
     shows "rank (rev (Dtree.root t1)) \<le> rank (rev v)"
 using assms proof(induction t1)
   case (Node r xs)
   then show ?case
   proof(cases "v = r")
     case False
     then obtain t2 e2 where t2_def: "xs = {|(t2,e2)|}" "v \<in> dverts t2"
       using Node.prems(1,3) singleton_if_mdeg_le1_elem by fastforce
     have "max_deg t2 \<le> 1" using Node.prems(1) mdeg_ge_child[of t2 e2 xs] t2_def(1) by simp
     then have "rank (rev (Dtree.root t2)) \<le> rank (rev v)"
       using Node.IH t2_def Node.prems(2) by fastforce
     then show ?thesis using Node.prems(2) t2_def(1) by fastforce
   qed(simp)
 qed
 
 lemma subtree_rank_ge_if_mdeg_le1_nocontr:
   assumes "is_subtree (Node r {|(t1,e1)|}) t"
       and "max_deg (Node r {|(t1,e1)|}) \<le> 1"
       and "\<nexists>v2 t2 e2. is_subtree (Node v2 {|(t2,e2)|}) t1 \<and> rank (rev (Dtree.root t2)) < rank (rev v2)"
       and "v \<noteq> r"
       and "v \<in> dverts t"
       and "y \<in> set v"
       and "\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y"
     shows "rank (rev (Dtree.root t1)) \<le> rank (rev v)"
 proof -
   have 0: "is_subtree t1 (Node r {|(t1,e1)|})" using subtree_if_child[of t1 "{|(t1,e1)|}"] by simp
   then have 0: "max_deg t1 \<le> 1" using assms(2) mdeg_ge_sub[OF 0] by simp
   have "v \<in> dverts (Node r {|(t1,e1)|})" using dverts_reach1_in_dverts_r assms(1,5-7) by blast
   then have "v \<in> dverts t1" using assms(4) by simp
   then show ?thesis using rank_ge_if_mdeg_le1_dvert_nocontr 0 assms(3) by blast
 qed
 
 lemma subtree_rank_ge_if_mdeg_le1':
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; max_deg (Node r {|(t1,e1)|}) \<le> 1; v \<noteq> r;
     v \<in> dverts t; y \<in> set v; \<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y; \<not>(\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)\<rbrakk>
     \<Longrightarrow> rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using subtree_y_reach_if_mdeg_le1_notroot_subcontr subtree_rank_ge_if_mdeg_le1_nocontr
   apply(cases "\<exists>v2 t2 e2. is_subtree (Node v2 {|(t2,e2)|}) t1 \<and> rank (rev (Dtree.root t2))<rank (rev v2)")
   by blast+
 
 lemma subtree_rank_ge_if_mdeg_le1:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; max_deg (Node r {|(t1,e1)|}) \<le> 1; v \<noteq> r;
     v \<in> dverts t; \<exists>y \<in> set v. \<not>(\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)\<rbrakk>
     \<Longrightarrow> rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using subtree_y_reach_if_mdeg_le1_notroot_subcontr subtree_rank_ge_if_mdeg_le1_nocontr
   apply(cases "\<exists>v2 t2 e2. is_subtree (Node v2 {|(t2,e2)|}) t1 \<and> rank (rev (Dtree.root t2))<rank (rev v2)")
   by blast+
 
 lemma subtree_rank_ge_if_reach:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) t; v \<noteq> r; v \<in> dverts t;
     \<exists>y \<in> set v. \<not>(\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)\<rbrakk>
     \<Longrightarrow> rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using subtree_rank_ge_if_mdeg_le1 subtree_rank_ge_if_mdeg_gt1_reach
   by (cases "max_deg (Node r {|(t1,e1)|}) \<le> 1") (auto simp del: max_deg.simps)
 
 lemma subtree_rank_ge_if_reach':
   "is_subtree (Node r {|(t1,e1)|}) t \<Longrightarrow> \<forall>v \<in> dverts t.
     (\<exists>y\<in>set v. \<not> (\<exists>x'\<in>set (Dtree.root t1). x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set r. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> v \<noteq> r)
       \<longrightarrow> rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using subtree_rank_ge_if_reach by blast
 
 subsubsection \<open>Normalizing preserves Arc Invariants\<close>
 
 lemma normalize1_mdeg_le: "max_deg (normalize1 t1) \<le> max_deg t1"
 proof(induction t1 rule: normalize1.induct)
   case (1 r t e)
   then show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     then show ?thesis using mdeg_child_sucs_le by fastforce
   next
     case False
     then have "max_deg (normalize1 (Node r {|(t, e)|}))
             = max (max_deg (normalize1 t)) (fcard {|(normalize1 t, e)|})"
       using mdeg_singleton by force
     then show ?thesis using mdeg_singleton[of r t] 1 False by (simp add: fcard_single_1)
   qed
 next
   case (2 xs r)
   then have 0: "\<forall>(t,e) \<in> fset xs. max_deg (normalize1 t) \<le> max_deg t" by fastforce
   have "max_deg (normalize1 (Node r xs)) = max_deg (Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs))"
     using "2.hyps" by simp
   then show ?case using mdeg_img_le'[OF 0] by simp
 qed
 
 lemma normalize1_mdeg_eq:
   "wf_darcs t1
     \<Longrightarrow> max_deg (normalize1 t1) = max_deg t1 \<or> (max_deg (normalize1 t1) = 0 \<and> max_deg t1 = 1)"
 proof(induction t1 rule: normalize1.induct)
   case ind: (1 r t e)
   then have 0: "max_deg (Node r {|(t, e)|}) \<ge> 1"
     using mdeg_ge_fcard[of "{|(t, e)|}"] by (simp add: fcard_single_1)
   then consider "rank (rev (Dtree.root t)) < rank (rev r)"
     | "\<not>rank (rev (Dtree.root t)) < rank (rev r)" "max_deg (normalize1 t) \<le> 1"
     | "\<not>rank (rev (Dtree.root t)) < rank (rev r)" "max_deg (normalize1 t) > 1" by linarith
   then show ?case
   proof(cases)
     case 1
     then show ?thesis
       using mdeg_singleton mdeg_root fcard_single_1
       by (metis max_def nle_le dtree.exhaust_sel leI less_one normalize1.simps(1))
   next
     case 2
     then have "max_deg (normalize1 (Node r {|(t, e)|})) = 1"
       using mdeg_singleton[of r "normalize1 t"] by (auto simp: fcard_single_1)
     moreover have "max_deg (Node r {|(t, e)|}) = 1 "
       using mdeg_singleton[of r t] ind 2
       by (auto simp: fcard_single_1 wf_darcs_iff_darcs')
     ultimately show ?thesis by simp
   next
     case 3
     then show ?thesis
       using mdeg_singleton[of r t] mdeg_singleton[of r "normalize1 t"] ind
       by (auto simp: fcard_single_1)
   qed
 next
   case ind: (2 xs r)
   then consider "max_deg (Node r xs) \<le> 1"
     | "max_deg (Node r xs) > 1" "max_deg (Node r xs) = fcard xs"
     | "max_deg (Node r xs) > 1" "fcard xs < max_deg (Node r xs)"
     using mdeg_ge_fcard[of xs] by fastforce
   then show ?case
   proof(cases)
     case 1
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by fastforce
   next
     case 2
     then have "max_deg (Node r xs) \<le> max_deg (normalize1 (Node r xs))"
       using mdeg_ge_fcard[of "(\<lambda>(t, e). (normalize1 t, e)) |`| xs"] ind
       by (simp add: fcard_normalize_img_if_disjoint wf_darcs_iff_darcs')
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by simp
   next
     case 3
     then obtain t e where t_def: "(t,e) \<in> fset xs" "max_deg (Node r xs) = max_deg t"
       using mdeg_child_if_gt_fcard by fastforce
     have "max_deg (normalize1 t) \<le> max_deg (Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs))"
       using mdeg_ge_child[of "normalize1 t" e "(\<lambda>(t,e). (normalize1 t,e)) |`| xs" r] t_def(1)
       by fastforce
     then have "max_deg (Node r xs) \<le> max_deg (normalize1 (Node r xs))"
       using ind.hyps ind.IH[OF t_def(1) refl] ind.prems 3(1) t_def
       by (fastforce simp: wf_darcs_iff_darcs')
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by simp
   qed
 qed
 
 lemma normalize1_mdeg_eq':
   "wf_dlverts t1
     \<Longrightarrow> max_deg (normalize1 t1) = max_deg t1 \<or> (max_deg (normalize1 t1) = 0 \<and> max_deg t1 = 1)"
 proof(induction t1 rule: normalize1.induct)
   case ind: (1 r t e)
   then have 0: "max_deg (Node r {|(t, e)|}) \<ge> 1"
     using mdeg_ge_fcard[of "{|(t, e)|}"] by (simp add: fcard_single_1)
   then consider "rank (rev (Dtree.root t)) < rank (rev r)"
     | "\<not>rank (rev (Dtree.root t)) < rank (rev r)" "max_deg (normalize1 t) \<le> 1"
     | "\<not>rank (rev (Dtree.root t)) < rank (rev r)" "max_deg (normalize1 t) > 1" by linarith
   then show ?case
   proof(cases)
     case 1
     then show ?thesis
       using mdeg_singleton[of r t] mdeg_root[of "Dtree.root t" "sucs t"]
       by (auto simp: fcard_single_1 simp del: max_deg.simps)
   next
     case 2
     then have "max_deg (normalize1 (Node r {|(t, e)|})) = 1"
       using mdeg_singleton[of r "normalize1 t"] by (auto simp: fcard_single_1)
     moreover have "max_deg (Node r {|(t, e)|}) = 1 "
       using mdeg_singleton[of r t] ind 2 by (auto simp: fcard_single_1)
     ultimately show ?thesis by simp
   next
     case 3
     then show ?thesis
       using mdeg_singleton[of r t] mdeg_singleton[of r "normalize1 t"] ind
       by (auto simp: fcard_single_1)
   qed
 next
   case ind: (2 xs r)
    consider "max_deg (Node r xs) \<le> 1"
     | "max_deg (Node r xs) > 1" "max_deg (Node r xs) = fcard xs"
     | "max_deg (Node r xs) > 1" "fcard xs < max_deg (Node r xs)"
     using mdeg_ge_fcard[of xs] by fastforce
   then show ?case
   proof(cases)
     case 1
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by (auto simp del: max_deg.simps)
   next
     case 2
     have 0: "\<forall>(t, e)\<in>fset xs. dlverts t \<noteq> {}" using dlverts_nempty_if_wf ind.prems by auto
     then have "max_deg (Node r xs) \<le> max_deg (normalize1 (Node r xs))"
       using mdeg_ge_fcard[of "(\<lambda>(t, e). (normalize1 t, e)) |`| xs"] ind 2
       by (simp add: fcard_normalize_img_if_disjoint_lverts)
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by simp
   next
     case 3
     then obtain t e where t_def: "(t,e) \<in> fset xs" "max_deg (Node r xs) = max_deg t"
       using mdeg_child_if_gt_fcard by fastforce
     have "max_deg (normalize1 t) \<le> max_deg (Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs))"
       using mdeg_ge_child[of "normalize1 t" e "(\<lambda>(t,e). (normalize1 t,e)) |`| xs"] t_def(1)
       by (force simp del: max_deg.simps)
     then have "max_deg (Node r xs) \<le> max_deg (normalize1 (Node r xs))"
       using ind 3(1) t_def by (fastforce simp del: max_deg.simps)
     then show ?thesis using normalize1_mdeg_le[of "Node r xs"] by simp
   qed
 qed
 
 lemma normalize1_dom_mdeg_gt1:
   "\<lbrakk>is_subtree (Node r xs) (normalize1 t); t1 \<in> fst ` fset xs; max_deg (Node r xs) > 1\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case (1 r1 t e)
   then interpret R: ranked_dtree_with_orig "Node r1 {|(t,e)|}" by blast
   have sub_t: "is_subtree t (Node r1 {|(t,e)|})" using subtree_if_child[of t "{|(t,e)|}"] by simp
   show ?case
   proof(cases "Node r xs = normalize1 (Node r1 {|(t,e)|})")
     case eq: True
     then have 0: "max_deg (Node r1 {|(t,e)|}) > 1"
       by (metis normalize1_mdeg_le "1.prems"(3) less_le_trans)
     then have max_t: "max_deg t > 1" by (metis dtree.exhaust_sel mdeg_child_sucs_eq_if_gt1)
     then show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have eq: "Node r xs = Node (r1@Dtree.root t) (sucs t)" using eq by simp
       then have "t1 \<in> fst ` fset (sucs t)" using "1.prems"(2) by simp
       then obtain v where "v \<in> set (Dtree.root t)" "v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
         using R.dom_mdeg_gt1[of "Dtree.root t" "sucs t"] sub_t max_t by auto
       then show ?thesis using eq by auto
     next
       case False
       obtain v where v_def: "v \<in> set r1" "v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t)"
         using max_t R.dom_mdeg_gt1[of r1 "{|(t, e)|}"] 0 by auto
       interpret T: ranked_dtree_with_orig t using R.ranked_dtree_orig_rec by simp
       have eq: "Node r xs = Node r1 {|(normalize1 t, e)|}" using False eq by simp
       then have "t1 = normalize1 t" using "1.prems"(2) by simp
       moreover have "Dtree.root t \<noteq> []"
         using empty_notin_wf_dlverts[OF T.wf_lverts] dtree.set_sel(1)[of t] by auto
       ultimately have "hd (Dtree.root t1) = hd (Dtree.root t)" using normalize1_hd_root_eq by blast
       then show ?thesis using v_def eq by auto
     qed
   next
     case uneq: False
     show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have "normalize1 (Node r1 {|(t,e)|}) = Node (r1@Dtree.root t) (sucs t)" by simp
       then obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t)" "is_subtree (Node r xs) t2"
         using uneq "1.prems"(1) by fastforce
       then have "is_subtree t2 t" using subtree_if_suc by blast
       then have "is_subtree (Node r xs) (Node r1 {|(t,e)|})"
         using subtree_trans subtree_if_suc t2_def(2) by auto
       then show ?thesis using R.dom_mdeg_gt1 "1.prems" by blast
     next
       case False
       then have "normalize1 (Node r1 {|(t,e)|}) = Node r1 {|(normalize1 t, e)|}" by simp
       then have "is_subtree (Node r xs) (normalize1 t)" using uneq "1.prems"(1) by auto
       then show ?thesis using "1.IH" False "1.prems"(2,3) R.ranked_dtree_orig_rec by simp
     qed
   qed
 next
   case (2 xs1 r1)
   then interpret R: ranked_dtree_with_orig "Node r1 xs1" by blast
   show ?case
   proof(cases "Node r xs = normalize1 (Node r1 xs1)")
     case True
     then have 0: "max_deg (Node r1 xs1) > 1"
       using normalize1_mdeg_le "2.prems"(3) less_le_trans by (fastforce simp del: max_deg.simps)
     then obtain t where t_def: "t \<in> fst ` fset xs1" "normalize1 t = t1"
       using "2.prems"(2) "2.hyps" True by fastforce
     then have sub_t: "is_subtree t (Node r1 xs1)" using subtree_if_child by fast
     then obtain v where v_def: "v \<in> set r1" "v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t)"
       using R.dom_mdeg_gt1[of r1] t_def(1) 0 by auto
     interpret T: ranked_dtree_with_orig t using R.ranked_dtree_orig_rec t_def(1) by force
     have "Dtree.root t \<noteq> []"
       using empty_notin_wf_dlverts[OF T.wf_lverts] dtree.set_sel(1)[of t] by auto
     then have "hd (Dtree.root t1) = hd (Dtree.root t)" using normalize1_hd_root_eq t_def(2) by blast
     then show ?thesis using v_def "2.hyps" True by auto
   next
     case False
     then show ?thesis using 2 R.ranked_dtree_orig_rec by auto
   qed
 qed
 
 lemma child_contr_if_new_contr:
   assumes "\<not>rank (rev (Dtree.root t1)) < rank (rev r)"
       and "rank (rev (Dtree.root (normalize1 t1))) < rank (rev r)"
     shows "\<exists>t2 e2. sucs t1 = {|(t2,e2)|} \<and> rank (rev (Dtree.root t2)) < rank (rev (Dtree.root t1))"
 proof -
   obtain t2 e2 where t2_def: "sucs t1 = {|(t2,e2)|}"
     using root_normalize1_eq2[of "sucs t1" "Dtree.root t1"] assms by fastforce
   then show ?thesis
     using root_normalize1_eq1[of t2 "Dtree.root t1" e2] assms dtree.collapse[of t1] by fastforce
 qed
 
 lemma sub_contr_if_new_contr:
   assumes "\<not>rank (rev (Dtree.root t1)) < rank (rev r)"
       and "rank (rev (Dtree.root (normalize1 t1))) < rank (rev r)"
     shows "\<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) t1 \<and> rank (rev (Dtree.root t2)) < rank (rev v)"
 proof -
   obtain t2 e2 where t2_def: "sucs t1 = {|(t2,e2)|}" "rank (rev (Dtree.root t2)) < rank (rev (Dtree.root t1))"
     using child_contr_if_new_contr[OF assms] by blast
   then have "is_subtree (Node (Dtree.root t1) {|(t2,e2)|}) t1"
     using is_subtree.simps[of "Node (Dtree.root t1) {|(t2,e2)|}" "Dtree.root t1" "sucs t1"] by fastforce
   then show ?thesis using t2_def(2) by blast
 qed
 
 lemma normalize1_subtree_same_hd:
   "\<lbrakk>is_subtree (Node v {|(t1,e1)|}) (normalize1 t)\<rbrakk>
     \<Longrightarrow> \<exists>t3 e3. (is_subtree (Node v {|(t3,e3)|}) t \<and> hd (Dtree.root t1) = hd (Dtree.root t3))
       \<or> (\<exists>v2. v = v2 @ Dtree.root t3 \<and> sucs t3 = {|(t1,e1)|}
         \<and> is_subtree (Node v2 {|(t3,e3)|}) t \<and> rank (rev (Dtree.root t3)) < rank (rev v2))"
 using wf_lverts wf_arcs proof(induction t rule: normalize1.induct)
   case (1 r t e)
   show ?case
   proof(cases "Node v {|(t1,e1)|} = normalize1 (Node r {|(t,e)|})")
     case eq: True
     then show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
       case True
       then show ?thesis using 1 eq by auto
     next
       case False
       then have eq: "Node v {|(t1,e1)|} = Node r {|(normalize1 t,e)|}" using eq by simp
       then show ?thesis using normalize1_hd_root_eq' "1.prems"(2) by auto
     qed
   next
     case uneq: False
     then show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
       case True
       then obtain t2 e2 where "(t2,e2) \<in> fset (sucs t)" "is_subtree (Node v {|(t1,e1)|}) t2"
         using "1.prems"(1) uneq by auto
       then show ?thesis using is_subtree.simps[of "Node v {|(t1,e1)|}" "Dtree.root t" "sucs t"] by auto
     next
       case False
       then have "is_subtree (Node v {|(t1,e1)|}) (normalize1 t)" using "1.prems"(1) uneq by auto
       then show ?thesis
         using "1.IH" "1.prems"(2,3) False by (auto simp: wf_darcs_iff_darcs')
     qed
   qed
 next
   case (2 xs r)
   then have "\<forall>x. ((\<lambda>(t,e). (normalize1 t,e)) |`| xs) \<noteq> {|x|}"
     using singleton_normalize1 by (simp add: wf_darcs_iff_darcs')
   then have "Node v {|(t1,e1)|} \<noteq> Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs)" by auto
   then obtain t2 e2 where "(t2,e2) \<in> fset xs \<and> is_subtree (Node v {|(t1,e1)|}) (normalize1 t2)"
     using "2.prems"(1) "2.hyps" by auto
   then show ?case using "2.IH" "2.prems"(2,3) by (fastforce simp: wf_darcs_iff_darcs')
 qed
 
 lemma normalize1_dom_sub_contr:
   "\<lbrakk>is_subtree (Node r xs) (normalize1 t); t1 \<in> fst ` fset xs;
     \<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r xs) \<and> rank (rev (Dtree.root t2)) < rank (rev v)\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case (1 r1 t e)
   then interpret R: ranked_dtree_with_orig "Node r1 {|(t,e)|}" by blast
   interpret T: ranked_dtree_with_orig t using R.ranked_dtree_orig_rec by simp
   have sub_t: "is_subtree (Node (Dtree.root t) (sucs t)) (Node r1 {|(t,e)|})"
     using subtree_if_child[of t "{|(t,e)|}"] by simp
   obtain v t2 e2 where v_def:
       "is_subtree (Node v {|(t2,e2)|}) (Node r xs)" "rank (rev (Dtree.root t2)) < rank (rev v)"
     using "1.prems"(3) by blast
   show ?case
   proof(cases "Node r xs = normalize1 (Node r1 {|(t,e)|})")
     case eq: True
     then show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have eq: "Node r xs = Node (r1@Dtree.root t) (sucs t)" using eq by simp
       then consider "Node r xs = Node v {|(t2,e2)|}" "max_deg (Node r xs) \<le> 1"
         | "Node r xs \<noteq> Node v {|(t2,e2)|}" | "max_deg (Node r xs) > 1"
         by linarith
       then show ?thesis
       proof(cases)
         case 1
         then have "max_deg (Node (r1@Dtree.root t) (sucs t)) \<le> 1" using eq by blast
         then have "max_deg t \<le> 1" using mdeg_root[of "Dtree.root t" "sucs t"] by simp
         then have "max_deg (Node r1 {|(t,e)|}) = 1"
           using mdeg_singleton[of r1 t] by (simp add: fcard_single_1)
         then have dom: "dom_children (Node r1 {|(t, e)|}) T" using R.dom_contr True by auto
         have 0: "t1 \<in> fst ` fset (sucs t)" using eq "1.prems"(2) by blast
         then have "Dtree.root t1 \<in> dverts t"
           using dtree.set_sel(1) T.dverts_child_subset dtree.exhaust_sel psubsetD by metis
         then obtain r2 where r2_def:
             "r2 \<in> set r1 \<union> path_lverts t (hd (Dtree.root t1))" "r2 \<rightarrow>\<^bsub>T\<^esub> (hd (Dtree.root t1))"
           using dom unfolding dom_children_def by auto
         have "Dtree.root t1 \<noteq> []"
           using empty_notin_wf_dlverts T.wf_lverts 0 T.dverts_child_subset
           by (metis dtree.exhaust_sel dtree.set_sel(1) psubsetD)
         then have "r2 \<in> set r1 \<union> set (Dtree.root t)"
           using path_lverts_subset_root_if_childhd[OF 0] r2_def(1) by fast
         then show ?thesis using r2_def(2) eq by auto
       next
         case 2
         then obtain t3 e3 where t3_def:
             "(t3,e3) \<in> fset (sucs t)" "is_subtree (Node v {|(t2,e2)|}) t3"
           using eq v_def(1) by auto
         have "is_subtree t3 t" using t3_def(1) subtree_if_suc by fastforce
         then have "is_subtree (Node v {|(t2,e2)|}) (Node (Dtree.root t) (sucs t))"
           using t3_def(2) subtree_trans by auto
         moreover have "t1 \<in> fst ` fset (sucs t)" using eq "1.prems"(2) by blast
         ultimately obtain v where v_def: "v \<in> set (Dtree.root t) \<and> v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
           using R.dom_sub_contr[OF sub_t] v_def(2) eq by blast
         then show ?thesis using eq by auto
       next
         case 3
         then show ?thesis using R.normalize1_dom_mdeg_gt1 "1.prems"(1,2) by blast
       qed
     next
       case False
       then have eq: "Node r xs = Node r1 {|(normalize1 t, e)|}" using eq by simp
       have hd: "hd (Dtree.root (normalize1 t)) = hd (Dtree.root t)"
         using normalize1_hd_root_eq' T.wf_lverts by blast
       have "\<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) t \<and> rank (rev (Dtree.root t2)) < rank (rev v)"
         using contr_before_normalize1 eq v_def sub_contr_if_new_contr False by auto
       then show ?thesis using R.dom_sub_contr[of r1 "{|(t,e)|}"] eq "1.prems"(2) hd by auto
     qed
   next
     case uneq: False
     show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have "normalize1 (Node r1 {|(t,e)|}) = Node (r1@Dtree.root t) (sucs t)" by simp
       then obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t)" "is_subtree (Node r xs) t2"
         using uneq "1.prems"(1) by fastforce
       then have "is_subtree t2 t" using subtree_if_suc by blast
       then have "is_subtree (Node r xs) (Node r1 {|(t,e)|})"
         using subtree_trans subtree_if_child t2_def(2) by auto
       then show ?thesis using R.dom_sub_contr "1.prems"(2,3) by fast
     next
       case False
       then have "normalize1 (Node r1 {|(t,e)|}) = Node r1 {|(normalize1 t, e)|}" by simp
       then have "is_subtree (Node r xs) (normalize1 t)" using uneq "1.prems"(1) by auto
       then show ?thesis using "1.IH" False "1.prems"(2,3) R.ranked_dtree_orig_rec by simp
     qed
   qed
 next
   case (2 xs1 r1)
   then interpret R: ranked_dtree_with_orig "Node r1 xs1" by blast
   show ?case
   proof(cases "Node r xs = normalize1 (Node r1 xs1)")
     case True
     then have eq: "Node r xs = Node r1 ((\<lambda>(t,e). (normalize1 t,e)) |`| xs1)" using "2.hyps" by simp
     obtain v t2 e2 where v_def:
       "is_subtree (Node v {|(t2,e2)|}) (Node r xs)" "rank (rev (Dtree.root t2)) < rank (rev v)"
       using "2.prems"(3) by blast
     obtain t where t_def: "t \<in> fst ` fset xs1" "normalize1 t = t1" using "2.prems"(2) eq by force
     then interpret T: ranked_dtree_with_orig t using R.ranked_dtree_orig_rec by force
     have "\<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r1 xs1)
                 \<and> rank (rev (Dtree.root t2)) < rank (rev v)"
       using True contr_before_normalize1 v_def by presburger
     moreover have "hd (Dtree.root t1) = hd (Dtree.root t)"
       using normalize1_hd_root_eq' T.wf_lverts t_def(2) by blast
     ultimately show ?thesis using R.dom_sub_contr[of r1 xs1] t_def(1) eq by auto
   next
     case False
     then obtain t e where "(t,e) \<in> fset xs1 \<and> is_subtree (Node r xs) (normalize1 t)"
       using "2.prems"(1) "2.hyps" by auto
     then show ?thesis using "2.IH" "2.prems"(2,3) R.ranked_dtree_orig_rec by fast
   qed
 qed
 
 lemma dom_children_combine_aux:
   assumes "dom_children (Node r {|(t1, e1)|}) T"
       and "t2 \<in> fst ` fset (sucs t1)"
       and "x \<in> dverts t2"
     shows "\<exists>v \<in> set (r @ Dtree.root t1) \<union> path_lverts t2 (hd x). v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
   using path_lverts_child_union_root_sub[OF assms(2)] assms dtree.set_sel(2)
   unfolding dom_children_def by fastforce
 
 lemma dom_children_combine:
   "dom_children (Node r {|(t1, e1)|}) T \<Longrightarrow> dom_children (Node (r@Dtree.root t1) (sucs t1)) T"
   using dom_children_combine_aux by (simp add: dom_children_def)
 
 lemma path_lverts_normalize1_sub:
   "\<lbrakk>wf_dlverts t1; x \<in> dverts (normalize1 t1); max_deg (normalize1 t1) \<le> 1\<rbrakk>
     \<Longrightarrow> path_lverts t1 (hd x) \<subseteq> path_lverts (normalize1 t1) (hd x)"
 proof(induction t1 rule: normalize1.induct)
   case (1 r t e)
   then show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     then have eq: "normalize1 (Node r {|(t, e)|}) = Node (r@Dtree.root t) (sucs t)" by simp
     then show ?thesis
     proof(cases "x = r@Dtree.root t")
       case True
       then show ?thesis using 1 by auto
     next
       case False
       then obtain t1 e1 where t1_def: "(t1,e1) \<in> fset (sucs t)" "x \<in> dverts t1"
         using "1.prems"(2) eq by auto
       then have 0: "hd x \<in> dlverts t1"
         using hd_in_lverts_if_wf "1.prems"(1) wf_dlverts_sucs by force
       then have "hd x \<in> dlverts t" using t1_def(1) suc_in_dlverts by fast
       then have 2: "hd x \<notin> set r" using "1.prems"(1) by auto
       have "wf_dlverts t" using "1.prems"(1) by simp
       then have "hd x \<notin> set (Dtree.root t)" using 0 t1_def(1) wf_dlverts.simps[of "Dtree.root t"] by fastforce
       then have hd_nin: "hd x \<notin> set (r @ Dtree.root t)" using 2 by auto
       then obtain t2 e2 where "sucs t = {|(t2,e2)|}"
         using "1.prems"(3) \<open>hd x \<in> dlverts t\<close> \<open>hd x \<notin> set (Dtree.root t)\<close> mdeg_root eq
         by (metis dtree.collapse denormalize.simps(2) denormalize_set_eq_dlverts surj_pair)
       then show ?thesis using eq hd_nin path_lverts_simps1_sucs by fastforce
     qed
   next
     case uneq: False
     then have "normalize1 (Node r {|(t, e)|}) = Node r {|(normalize1 t, e)|}" by simp
     then have "max_deg (normalize1 t) \<le> 1"
       using "1.prems"(3) mdeg_singleton[of r "normalize1 t"] fcard_single_1 max_def by auto
     then show ?thesis using uneq 1 by auto
   qed
 next
   case (2 xs r)
   then have "max_deg (normalize1 (Node r xs)) = max_deg (Node r xs) \<or> max_deg (Node r xs) = 1"
     using normalize1_mdeg_eq' by blast
   then have "max_deg (Node r xs) \<le> 1" using "2.prems"(3) by (auto simp del: max_deg.simps)
   then have "fcard xs = 0"
     using mdeg_ge_fcard[of xs r] fcard_single_1_iff[of xs] "2.hyps" by fastforce
   then show ?case using 2 by simp
 qed
 
 lemma dom_children_normalize1_aux_1:
   assumes "dom_children (Node r {|(t1, e1)|}) T"
       and "sucs t1 = {|(t2,e2)|}"
       and "wf_dlverts t1"
       and "normalize1 t1 = Node (Dtree.root t1 @ Dtree.root t2) (sucs t2)"
       and "max_deg t1 = 1"
       and "x \<in> dverts (normalize1 t1)"
     shows "\<exists>v \<in> set r \<union> path_lverts (normalize1 t1) (hd x). v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
 proof(cases "x = Dtree.root t1 @ Dtree.root t2")
   case True
   then have 0: "hd x = hd (Dtree.root t1)" using assms(3,4) normalize1_hd_root_eq' by fastforce
   then obtain v where v_def: "v \<in> set r \<union> path_lverts t1 (hd x)" "v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
     using assms(1) dtree.set_sel(1) unfolding dom_children_def by auto
   have "Dtree.root t1 \<noteq> []" using assms(3) wf_dlverts.simps[of "Dtree.root t1" "sucs t1"] by simp
   then show ?thesis using v_def 0 path_lverts_empty_if_roothd by auto
 next
   case False
   then obtain t3 e3 where t3_def: "(t3,e3) \<in> fset (sucs t2)" "x \<in> dverts t3"
     using assms(2,4,6) by auto
   then have "x \<in> dverts t2" using dtree.set(1)[of "Dtree.root t2" "sucs t2"] by fastforce
   then have "x \<in> dverts (Node (Dtree.root t1) {|(t2,e2)|})" by auto
   then have "x \<in> dverts t1" using assms(2) dtree.exhaust_sel by metis
   then obtain v where v_def: "v \<in> set r \<union> path_lverts t1 (hd x)" "v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
     using assms(1) dtree.set_sel(1) unfolding dom_children_def by auto
   have "path_lverts t1 (hd x) \<subseteq> path_lverts (Node (Dtree.root t1 @ Dtree.root t2) (sucs t2)) (hd x)"
     using assms(3-6) normalize1_mdeg_le path_lverts_normalize1_sub by metis
   then show ?thesis using v_def assms(4) by auto
 qed
 
 lemma dom_children_normalize1_1:
   "\<lbrakk>dom_children (Node r {|(t1, e1)|}) T; sucs t1 = {|(t2,e2)|}; wf_dlverts t1;
     normalize1 t1 = Node (Dtree.root t1 @ Dtree.root t2) (sucs t2); max_deg t1 = 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r {|(normalize1 t1, e1)|}) T"
   using dom_children_normalize1_aux_1 by (simp add: dom_children_def)
 
 lemma dom_children_normalize1_aux:
   assumes "\<forall>x\<in>dverts t1. \<exists>v \<in> set r0 \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
       and "wf_dlverts t1"
       and "max_deg t1 \<le> 1"
       and "x \<in> dverts (normalize1 t1)"
     shows "\<exists>v \<in> set r0 \<union> path_lverts (normalize1 t1) (hd x). v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
 using assms proof(induction t1 arbitrary: r0 rule: normalize1.induct)
   case (1 r t e)
   have deg1: "max_deg (Node r {|(t, e)|}) = 1"
     using "1.prems"(3) mdeg_ge_fcard[of "{|(t, e)|}"] by (simp add: fcard_single_1)
   then show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     have 0: "dom_children (Node r0 {|(Node r {|(t, e)|}, e)|}) T"
       using "1.prems"(1) unfolding dom_children_def by simp
     show ?thesis using dom_children_normalize1_aux_1[OF 0] "1.prems"(1,2,4) deg1 True by auto
   next
     case ncontr: False
     show ?thesis
     proof(cases "x = r")
       case True
       then show ?thesis using "1.prems"(1,2) by auto
     next
       case False
       have "wf_dlverts (normalize1 t)" using "1.prems"(2) wf_dlverts_normalize1 by auto
       then have "hd x \<in> dlverts (normalize1 t)"
         using hd_in_lverts_if_wf False ncontr "1.prems"(1,4) by fastforce
       then have hd: "hd x \<notin> set r" using "1.prems"(2) ncontr wf_dlverts_normalize1 by fastforce
       then have eq: "path_lverts (Node r {|(t, e)|}) (hd x) = set r \<union> path_lverts t (hd x)" by simp
       then have eq1: "path_lverts (Node r {|(normalize1 t, e)|}) (hd x)
                     = set r \<union> path_lverts (normalize1 t) (hd x)" by auto
       have "\<forall>x\<in>dverts t. path_lverts (Node r {|(t, e)|}) (hd x) \<subseteq> set r \<union> path_lverts t (hd x)"
         using path_lverts_child_union_root_sub by simp
       then have 2: "\<forall>x\<in>dverts t. \<exists>v\<in>set (r0@r) \<union> path_lverts t (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
         using "1.prems"(1) by fastforce
       have "max_deg t \<le> 1" using "1.prems"(3) mdeg_ge_child[of t e "{|(t, e)|}"] by simp
       then show ?thesis using "1.IH"[OF ncontr 2] "1.prems"(2,4) ncontr hd by auto
     qed
   qed
 next
   case (2 xs r)
   then have "fcard xs \<le> 1" using mdeg_ge_fcard[of xs] by simp
   then have "fcard xs = 0" using "2.hyps" fcard_single_1_iff[of xs] by fastforce
   then show ?case using 2 by auto
 qed
 
 lemma dom_children_normalize1:
   "\<lbrakk>dom_children (Node r0 {|(t1,e1)|}) T; wf_dlverts t1; max_deg t1 \<le> 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r0 {|(normalize1 t1,e1)|}) T"
   using dom_children_normalize1_aux by (simp add: dom_children_def)
 
 lemma dom_children_child_self_aux:
   assumes "dom_children t1 T"
       and "sucs t1 = {|(t2, e2)|}"
       and "rank (rev (Dtree.root t2)) < rank (rev (Dtree.root t1))"
       and "t = Node r {|(t1, e1)|}"
       and "x \<in> dverts t1"
     shows "\<exists>v \<in> set r \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
 proof(cases "x = Dtree.root t1")
   case True
   have "is_subtree (Node (Dtree.root t1) {|(t2, e2)|}) (Node r {|(t1, e1)|})"
     using subtree_if_child[of "t1" "{|(t1, e1)|}"] assms(2) dtree.collapse[of t1] by simp
   then show ?thesis using dom_sub_contr[of r "{|(t1, e1)|}"] assms(3,4) True by auto
 next
   case False
   then have "x \<in> (\<Union>y\<in>fset (sucs t1). \<Union> (dverts ` Basic_BNFs.fsts y))"
     using assms(5) dtree.set(1)[of "Dtree.root t1" "sucs t1"] by auto
   then have "x \<in> dverts t2" using assms(2) by auto
   then obtain v where v_def: "v \<in> set (Dtree.root t1) \<union> path_lverts t2 (hd x)" "v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
     using assms(1,2) dtree.set_sel(1) unfolding dom_children_def by auto
   interpret T1: list_dtree t1 using list_dtree_rec assms(4) by simp
   interpret T2: list_dtree t2 using T1.list_dtree_rec_suc assms(2) by simp
   have "hd x \<in> dlverts t2" using \<open>x \<in> dverts t2\<close> by (simp add: hd_in_lverts_if_wf T2.wf_lverts)
   then have "hd x \<notin> set (Dtree.root t1)"
     using T1.wf_lverts wf_dlverts.simps[of "Dtree.root t1" "sucs t1"] assms(2) by fastforce
   then have "path_lverts t1 (hd x) = set (Dtree.root t1) \<union> path_lverts t2 (hd x)"
     using assms(2) by (simp add: path_lverts_simps1_sucs)
   then show ?thesis using v_def by auto
 qed
 
 lemma dom_children_child_self:
   assumes "dom_children t1 T"
       and "sucs t1 = {|(t2, e2)|}"
       and "rank (rev (Dtree.root t2)) < rank (rev (Dtree.root t1))"
       and "t = Node r {|(t1, e1)|}"
     shows "dom_children (Node r {|(t1, e1)|}) T"
   using dom_children_child_self_aux[OF assms] by (simp add: dom_children_def)
 
 lemma normalize1_dom_contr:
   "\<lbrakk>is_subtree (Node r {|(t1,e1)|}) (normalize1 t); rank (rev (Dtree.root t1)) < rank (rev r);
     max_deg (Node r {|(t1,e1)|}) = 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r {|(t1,e1)|}) T"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case (1 r1 t e)
   then interpret R: ranked_dtree_with_orig "Node r1 {|(t,e)|}" by blast
   interpret T: ranked_dtree_with_orig t using R.ranked_dtree_orig_rec by simp
   have sub_t: "is_subtree (Node (Dtree.root t) (sucs t)) (Node r1 {|(t,e)|})"
     using subtree_if_child[of t "{|(t,e)|}"] by simp
   show ?case
   proof(cases "Node r {|(t1,e1)|} = normalize1 (Node r1 {|(t,e)|})")
     case eq: True
     then show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have eq: "Node r {|(t1,e1)|}  = Node (r1@Dtree.root t) (sucs t)" using eq by simp
       then have "max_deg t = 1" using mdeg_root[of "Dtree.root t" "sucs t"] 1 by simp
       then have "max_deg (Node r1 {|(t,e)|}) = 1"
         using mdeg_singleton[of r1 t] by (simp add: fcard_single_1)
       then have "dom_children (Node r1 {|(t, e)|}) T" using R.dom_contr[of r1 t e] True by simp
       then show ?thesis using dom_children_combine eq by simp
     next
       case False
       then have eq: "Node r {|(t1,e1)|} = Node r1 {|(normalize1 t, e)|}" using eq by simp
       then obtain t2 e2 where t2_def:
           "sucs t = {|(t2, e2)|}" "rank (rev (Dtree.root t2)) < rank (rev (Dtree.root t))"
         using child_contr_if_new_contr False "1.prems"(2) by blast
       then have "is_subtree (Node (Dtree.root t) {|(t2, e2)|}) (Node r1 {|(t, e)|})" using sub_t by simp
       have "max_deg t = 1"
         using "1.prems"(3) eq mdeg_singleton mdeg_root t2_def
         by (metis dtree.collapse fcard_single_1 normalize1.simps(1))
       then have "max_deg (Node (Dtree.root t) {|(t2, e2)|}) = 1"
         using t2_def(1) dtree.collapse[of t] by simp
       then have "dom_children (Node (Dtree.root t) (sucs t)) T"
         using R.dom_contr sub_t t2_def "1.prems"(3) by simp
       then have "dom_children t T" using dtree.exhaust_sel by simp
       then have "dom_children (Node r1 {|(t,e)|}) T"
         using R.dom_children_child_self t2_def by simp
       then show ?thesis using dom_children_normalize1 \<open>max_deg t = 1\<close> T.wf_lverts eq by auto
     qed
   next
     case uneq: False
     show ?thesis
     proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
       case True
       then have "normalize1 (Node r1 {|(t,e)|}) = Node (r1@Dtree.root t) (sucs t)" by simp
       then obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t)" "is_subtree (Node r {|(t1,e1)|}) t2"
         using uneq "1.prems"(1) by fastforce
       then have "is_subtree t2 t" using subtree_if_suc by blast
       then have "is_subtree (Node r {|(t1,e1)|}) (Node r1 {|(t,e)|})"
         using subtree_trans subtree_if_child t2_def(2) by auto
       then show ?thesis using R.dom_contr "1.prems"(2,3) by blast
     next
       case False
       then have "normalize1 (Node r1 {|(t,e)|}) = Node r1 {|(normalize1 t, e)|}" by simp
       then have "is_subtree (Node r {|(t1,e1)|}) (normalize1 t)" using uneq "1.prems"(1) by auto
       then show ?thesis using "1.IH" False "1.prems"(2,3) R.ranked_dtree_orig_rec by simp
     qed
   qed
 next
   case (2 xs r1)
   then have eq: "normalize1 (Node r1 xs) = Node r1 ((\<lambda>(t,e). (normalize1 t,e)) |`| xs)"
     using "2.hyps" by simp
   interpret R: ranked_dtree_with_orig "Node r1 xs" using "2.prems"(4) by blast
   have "\<forall>x. ((\<lambda>(t,e). (normalize1 t,e)) |`| xs) \<noteq> {|x|}"
     using singleton_normalize1 "2.hyps" disjoint_darcs_if_wf_xs[OF R.wf_arcs] by auto
   then have "Node r {|(t1,e1)|} \<noteq> Node r1 ((\<lambda>(t,e). (normalize1 t,e)) |`| xs)" by auto
   then obtain t3 e3 where t3_def:
       "(t3,e3) \<in> fset xs" "is_subtree (Node r {|(t1, e1)|}) (normalize1 t3)"
     using "2.prems"(1) eq by auto
   then show ?case using "2.IH" "2.prems"(2,3) R.ranked_dtree_orig_rec by simp
 qed
 
 lemma dom_children_normalize1_img_full:
   assumes "dom_children (Node r xs) T"
       and "\<forall>(t1,e1) \<in> fset xs. wf_dlverts t1"
       and "\<forall>(t1,e1) \<in> fset xs. max_deg t1 \<le> 1"
     shows "dom_children (Node r ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)) T"
 proof -
   have "\<forall>(t1, e1) \<in> fset xs. dom_children (Node r {|(t1, e1)|}) T"
     using dom_children_all_singletons[OF assms(1)] by blast
   then have "\<forall>(t1, e1) \<in> fset xs. dom_children (Node r {|(normalize1 t1, e1)|}) T"
     using dom_children_normalize1 assms(2,3) by fast
   then show ?thesis
     using dom_children_if_all_singletons[of "(\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs"] by fastforce
 qed
 
 lemma children_deg1_normalize1_sub:
   "(\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs
   \<subseteq> children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)"
   using normalize1_mdeg_le order_trans by auto
 
 lemma normalize1_children_deg1_sub_if_wfarcs:
   "\<forall>(t1,e1)\<in>fset xs. wf_darcs t1
     \<Longrightarrow> children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)
       \<subseteq> (\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs"
   using normalize1_mdeg_eq by fastforce
 
 lemma normalize1_children_deg1_eq_if_wfarcs:
   "\<forall>(t1,e1)\<in>fset xs. wf_darcs t1
     \<Longrightarrow> (\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs
       = children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)"
   using children_deg1_normalize1_sub normalize1_children_deg1_sub_if_wfarcs
   by (meson subset_antisym)
 
 lemma normalize1_children_deg1_sub_if_wflverts:
   "\<forall>(t1,e1)\<in>fset xs. wf_dlverts t1
     \<Longrightarrow> children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)
       \<subseteq> (\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs"
   using normalize1_mdeg_eq' by fastforce
 
 lemma normalize1_children_deg1_eq_if_wflverts:
   "\<forall>(t1,e1)\<in>fset xs. wf_dlverts t1
     \<Longrightarrow> (\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs
       = children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)"
   using children_deg1_normalize1_sub normalize1_children_deg1_sub_if_wflverts
   by (meson subset_antisym)
 
 lemma dom_children_normalize1_img:
   assumes "dom_children (Node r (Abs_fset (children_deg1 xs))) T"
       and "\<forall>(t1,e1) \<in> fset xs. wf_dlverts t1"
     shows "dom_children (Node r (Abs_fset (children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs)))) T"
 proof -
   have "\<forall>(t1, e1) \<in> children_deg1 xs. dom_children (Node r {|(t1, e1)|}) T"
     using dom_children_all_singletons[OF assms(1)] children_deg1_fset_id by blast
   then have "\<forall>(t2, e2) \<in> (\<lambda>(t1,e1). (normalize1 t1,e1)) ` children_deg1 xs.
               dom_children (Node r {|(t2, e2)|}) T"
     using dom_children_normalize1 assms(2) by fast
   then have "\<forall>(t2, e2) \<in> children_deg1 ((\<lambda>(t1,e1). (normalize1 t1,e1)) |`| xs).
               dom_children (Node r {|(t2, e2)|}) T"
     using normalize1_children_deg1_eq_if_wflverts[of xs] assms(2) by blast
   then show ?thesis using dom_children_if_all_singletons children_deg1_fset_id
   proof -
     have "\<forall>f as p. \<exists>pa. (dom_children (Node (as::'a list) f) p \<or> pa |\<in>| f) \<and> (\<not> (case pa of (d, b::'b) \<Rightarrow> dom_children (Node as {|(d, b)|}) p) \<or> dom_children (Node as f) p)"
       using dom_children_if_all_singletons by blast
     then obtain pp :: "(('a list, 'b) Dtree.dtree \<times> 'b) fset \<Rightarrow> 'a list \<Rightarrow> ('a, 'b) pre_digraph \<Rightarrow> ('a list, 'b) Dtree.dtree \<times> 'b" where
       f1: "\<And>as f p. (dom_children (Node as f) p \<or> pp f as p |\<in>| f) \<and> (\<not> (case pp f as p of (d, b) \<Rightarrow> dom_children (Node as {|(d, b)|}) p) \<or> dom_children (Node as f) p)"
       by metis
     moreover
     { assume "\<not> (case pp (Abs_fset (children_deg1 ((\<lambda>(d, y). (normalize1 d, y)) |`| xs))) r T of (d, b) \<Rightarrow> dom_children (Node r {|(d, b)|}) T)"
       then have "pp (Abs_fset (children_deg1 ((\<lambda>(d, y). (normalize1 d, y)) |`| xs))) r T \<notin> children_deg1 ((\<lambda>(d, y). (normalize1 d, y)) |`| xs)"
         by (smt (z3) \<open>\<forall>(t2, e2) \<in>children_deg1 ((\<lambda>(t1, e1). (normalize1 t1, e1)) |`| xs). dom_children (Node r {|(t2, e2)|}) T\<close>)
       then have "pp (Abs_fset (children_deg1 ((\<lambda>(d, y). (normalize1 d, y)) |`| xs))) r T |\<notin>| Abs_fset (children_deg1 ((\<lambda>(d, y). (normalize1 d, y)) |`| xs))"
         by (metis (no_types) children_deg1_fset_id)
       then have ?thesis
         using f1 by blast }
     ultimately show ?thesis
       by meson
   qed
 qed
 
 lemma normalize1_dom_wedge:
   "\<lbrakk>is_subtree (Node r xs) (normalize1 t); fcard xs > 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r (Abs_fset (children_deg1 xs))) T"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case (1 r1 t e)
   then interpret R: ranked_dtree_with_orig "Node r1 {|(t,e)|}" by blast
   have sub_t: "is_subtree (Node (Dtree.root t) (sucs t)) (Node r1 {|(t,e)|})"
     using subtree_if_child[of t "{|(t,e)|}"] by simp
   show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r1)")
     case True
     then have eq: "normalize1 (Node r1 {|(t,e)|}) = Node (r1@Dtree.root t) (sucs t)" by simp
     then show ?thesis
     proof(cases "Node r xs = normalize1 (Node r1 {|(t,e)|})")
       case True
       then have "Node r xs = Node (r1@Dtree.root t) (sucs t)" using eq by simp
       then show ?thesis using R.dom_wedge[OF sub_t] "1.prems"(2) unfolding dom_children_def by auto
     next
       case False
       then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset (sucs t)" "is_subtree (Node r xs) t2"
         using "1.prems"(1) eq by auto
       then have "is_subtree (Node r xs) t" using subtree_if_suc subtree_trans by fastforce
       then show ?thesis using R.dom_wedge sub_t "1.prems"(2) by simp
     qed
   next
     case False
     then show ?thesis using 1 R.ranked_dtree_orig_rec by (auto simp: fcard_single_1)
   qed
 next
   case (2 xs1 r1)
   then have eq: "normalize1 (Node r1 xs1) = Node r1 ((\<lambda>(t,e). (normalize1 t,e)) |`| xs1)"
     using "2.hyps" by simp
   interpret R: ranked_dtree_with_orig "Node r1 xs1" using "2.prems"(3) by blast
   have "\<forall>x. ((\<lambda>(t,e). (normalize1 t,e)) |`| xs1) \<noteq> {|x|}"
     using singleton_normalize1 "2.hyps" disjoint_darcs_if_wf_xs[OF R.wf_arcs] by auto
   then show ?case
   proof(cases "Node r xs = normalize1 (Node r1 xs1)")
     case True
     then have "1 < fcard xs1" using eq "2.prems"(2) fcard_image_le less_le_trans by fastforce
     then have "dom_children (Node r1 (Abs_fset (children_deg1 xs1))) T" using R.dom_wedge by simp
     then show ?thesis using dom_children_normalize1_img eq R.wf_lverts True by fastforce
   next
     case False
     then show ?thesis using 2 R.ranked_dtree_orig_rec by fastforce
   qed
 qed
 
 corollary normalize1_dom_wedge':
   "\<forall>r xs. is_subtree (Node r xs) (normalize1 t) \<longrightarrow> fcard xs > 1
     \<longrightarrow> dom_children (Node r (Abs_fset {(t, e). (t, e) \<in> fset xs \<and> max_deg t \<le> Suc 0})) T"
   by (auto simp only: normalize1_dom_wedge One_nat_def[symmetric])
 
 lemma normalize1_verts_conform: "v \<in> dverts (normalize1 t) \<Longrightarrow> seq_conform v"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case ind: (1 r t e)
   then interpret R: ranked_dtree_with_orig "Node r {|(t, e)|}" by blast
   consider "rank (rev (Dtree.root t)) < rank (rev r)" "v = r@Dtree.root t"
     | "rank (rev (Dtree.root t)) < rank (rev r)" "v \<noteq> r@Dtree.root t"
     | "\<not>rank (rev (Dtree.root t)) < rank (rev r)"
     by blast
   then show ?case
   proof(cases)
     case 1
     then show ?thesis using R.contr_seq_conform by auto
   next
     case 2
     then have "v \<in> dverts (Node r {|(t, e)|})" using dverts_suc_subseteq ind.prems by fastforce
     then show ?thesis using R.verts_conform by blast
   next
     case 3
     then show ?thesis using R.verts_conform ind R.ranked_dtree_orig_rec by auto
   qed
 next
   case (2 xs r)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   show ?case using R.verts_conform 2 R.ranked_dtree_orig_rec by auto
 qed
 
 corollary normalize1_verts_distinct: "v \<in> dverts (normalize1 t) \<Longrightarrow> distinct v"
   using distinct_normalize1 verts_distinct by auto
 
 lemma dom_mdeg_le1_aux:
   assumes "max_deg t \<le> 1"
       and "is_subtree (Node v {|(t2, e2)|}) t"
       and "rank (rev (Dtree.root t2)) < rank (rev v)"
       and "t1 \<in> fst ` fset (sucs t)"
       and "x \<in> dverts t1"
     shows "\<exists>r\<in>set (Dtree.root t) \<union> path_lverts t1 (hd x). r \<rightarrow>\<^bsub>T\<^esub> hd x"
 using assms ranked_dtree_with_orig_axioms proof(induction t arbitrary: t1)
   case (Node r xs)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   interpret T1: ranked_dtree_with_orig t1 using Node.prems(4) R.ranked_dtree_orig_rec by force
   have "fcard xs > 0" using Node.prems(4) fcard_seteq by fastforce
   then have "fcard xs = 1" using mdeg_ge_fcard[of xs] Node.prems(1) by simp
   then obtain e1 where e1_def: "xs = {|(t1,e1)|}"
     using Node.prems(4) fcard_single_1_iff[of xs] by auto
   have mdeg1: "max_deg (Node r xs) = 1"
     using Node.prems(1) mdeg_ge_fcard[of xs] \<open>fcard xs = 1\<close> by simp
   show ?case
   proof(cases "Node v {|(t2, e2)|} = Node r xs")
     case True
     then have "dom_children (Node r xs) T"
       using mdeg1 Node.prems(2,3) R.dom_contr_subtree by blast
     then show ?thesis unfolding dom_children_def using e1_def Node.prems(5) by simp
   next
     case False
     then have sub_t1: "is_subtree (Node v {|(t2, e2)|}) t1"
       using Node.prems(2) e1_def is_subtree.simps[of "Node v {|(t2, e2)|}"] by force
     show ?thesis
     proof(cases "x = Dtree.root t1")
       case True
       then show ?thesis using R.dom_sub_contr[OF self_subtree] Node.prems(3) e1_def sub_t1 by auto
     next
       case False
       then obtain t3 where t3_def: "t3 \<in> fst ` fset (sucs t1)" "x \<in> dverts t3"
         using Node.prems(5) dverts_root_or_child[of x "Dtree.root t1" "sucs t1"] by fastforce
       have mdeg_t1: "max_deg t1 \<le> 1" using mdeg_ge_child[of t1 e1 xs] e1_def mdeg1 by simp
       moreover have "fcard (sucs t1) > 0" using t3_def fcard_seteq by fastforce
       ultimately have "fcard (sucs t1) = 1" using mdeg_ge_fcard[of "sucs t1" "Dtree.root t1"] by simp
       then obtain e3 where e3_def: "sucs t1 = {|(t3, e3)|}"
         using t3_def fcard_single_1_iff[of "sucs t1"] by fastforce
       have ind: "\<exists>r\<in>set (Dtree.root t1) \<union> path_lverts t3 (hd x). r \<rightarrow>\<^bsub>T\<^esub> hd x"
         using Node.IH mdeg_t1 e1_def sub_t1 Node.prems(3) t3_def T1.ranked_dtree_with_orig_axioms
         by auto
       have "hd x \<in> dlverts t3" using t3_def hd_in_lverts_if_wf T1.wf_lverts wf_dlverts_suc by blast
       then have "hd x \<notin> set (Dtree.root t1)"
         using t3_def dlverts_notin_root_sucs[OF T1.wf_lverts] by blast
       then have "path_lverts t1 (hd x) = set (Dtree.root t1) \<union> path_lverts t3 (hd x)"
         using path_lverts_simps1_sucs e3_def by fastforce
       then show ?thesis using ind by blast
     qed
   qed
 qed
 
 lemma dom_mdeg_le1:
   assumes "max_deg t \<le> 1"
       and "is_subtree (Node v {|(t2, e2)|}) t"
       and "rank (rev (Dtree.root t2)) < rank (rev v)"
     shows "dom_children t T"
   using dom_mdeg_le1_aux[OF assms] unfolding dom_children_def by blast
 
 lemma dom_children_normalize1_preserv:
   assumes "max_deg (normalize1 t1) \<le> 1" and "dom_children t1 T" and "wf_dlverts t1"
   shows "dom_children (normalize1 t1) T"
 using assms proof(induction t1 rule: normalize1.induct)
   case (1 r t e)
   then show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     then show ?thesis using 1 dom_children_combine by force
   next
     case False
     then have "max_deg (normalize1 t) \<le> 1"
       using "1.prems"(1) mdeg_ge_child[of "normalize1 t" e "{|(normalize1 t,e)|}"] by simp
     then have "max_deg t \<le> 1" using normalize1_mdeg_eq' "1.prems"(3) by fastforce
     then show ?thesis using dom_children_normalize1 False "1.prems"(2,3) by simp
   qed
 next
   case (2 xs r)
   have "max_deg (Node r xs) \<le> 1"
     using normalize1_mdeg_eq'[OF "2.prems"(3)] "2.prems"(1) by fastforce
   then have "fcard xs \<le> 1" using mdeg_ge_fcard[of xs] by simp
   then have "fcard xs = 0" using fcard_single_1_iff[of xs] "2.hyps" by fastforce
   then have "normalize1 (Node r xs) = Node r xs" using "2.hyps" by simp
   then show ?case using "2.prems"(2) by simp
 qed
 
 lemma dom_mdeg_le1_normalize1:
   assumes "max_deg (normalize1 t) \<le> 1" and "normalize1 t \<noteq> t"
   shows "dom_children (normalize1 t) T"
 proof -
   obtain v t2 e2 where "is_subtree (Node v {|(t2, e2)|}) t" "rank (rev (Dtree.root t2)) < rank (rev v)"
     using contr_if_normalize1_uneq assms(2) by blast
   moreover have "max_deg t \<le> 1" using assms(1) normalize1_mdeg_eq wf_arcs by fastforce
   ultimately show ?thesis
     using dom_mdeg_le1 dom_children_normalize1_preserv assms(1) wf_lverts by blast
 qed
 
 lemma normalize_mdeg_eq:
   "wf_darcs t1
     \<Longrightarrow> max_deg (normalize t1) = max_deg t1 \<or> (max_deg (normalize t1) = 0 \<and> max_deg t1 = 1)"
   apply (induction t1 rule: normalize.induct)
   by (smt (verit, ccfv_threshold) normalize1_mdeg_eq wf_darcs_normalize1 normalize.simps)
 
 lemma normalize_mdeg_eq':
   "wf_dlverts t1
     \<Longrightarrow> max_deg (normalize t1) = max_deg t1 \<or> (max_deg (normalize t1) = 0 \<and> max_deg t1 = 1)"
   apply (induction t1 rule: normalize.induct)
   by (smt (verit, ccfv_threshold) normalize1_mdeg_eq' wf_dlverts_normalize1 normalize.simps)
 
 corollary mdeg_le1_normalize:
   "\<lbrakk>max_deg (normalize t1) \<le> 1; wf_dlverts t1\<rbrakk> \<Longrightarrow> max_deg t1 \<le> 1"
   using normalize_mdeg_eq' by fastforce
 
 lemma dom_children_normalize_preserv:
   assumes "max_deg (normalize t1) \<le> 1" and "dom_children t1 T" and "wf_dlverts t1"
   shows "dom_children (normalize t1) T"
 using assms proof(induction t1 rule: normalize.induct)
   case (1 t1)
   then show ?case
   proof(cases "t1 = normalize1 t1")
     case True
     then show ?thesis using "1.prems" dom_children_normalize1_preserv by simp
   next
     case False
     have "max_deg t1 \<le> 1" using mdeg_le1_normalize "1.prems"(1,3) by blast
     then have "max_deg (normalize1 t1) \<le> 1"
       using normalize1_mdeg_eq' "1.prems"(3) by fastforce
     then have "dom_children (normalize1 t1) T"
       using dom_children_normalize1_preserv "1.prems"(2,3) by blast
     then show ?thesis using 1 False by (simp add: Let_def wf_dlverts_normalize1)
   qed
 qed
 
 lemma dom_mdeg_le1_normalize:
   assumes "max_deg (normalize t) \<le> 1" and "normalize t \<noteq> t"
   shows "dom_children (normalize t) T"
 using assms ranked_dtree_with_orig_axioms proof(induction t rule: normalize.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by blast
   show ?case
     using 1 T.dom_mdeg_le1_normalize1 T.wf_lverts wf_dlverts_normalize1
     by (smt (verit) dom_children_normalize_preserv normalize.elims mdeg_le1_normalize)
 qed
 
 lemma normalize1_arc_in_dlverts:
   "\<lbrakk>is_subtree (Node v ys) (normalize1 t); x \<in> set v; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts (Node v ys)"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case ind: (1 r t e)
   then interpret R: ranked_dtree_with_orig "Node r {|(t, e)|}" by blast
   show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     then have eq: "normalize1 (Node r {|(t, e)|}) = Node (r@Dtree.root t) (sucs t)" by simp
     then show ?thesis
     proof(cases "Node v ys = Node (r@Dtree.root t) (sucs t)")
       case True
       then consider "x \<in> set r" | "x \<in> set (Dtree.root t)" using ind.prems(2) by auto
       then show ?thesis
       proof(cases)
         case 1
         then have "y \<in> dlverts (Node r {|(t, e)|})"
           using R.arc_in_dlverts ind.prems(3) by fastforce
         then show ?thesis using eq normalize1_dlverts_eq[of "Node r {|(t, e)|}"] True by simp
       next
         case 2
         then have "y \<in> dlverts t"
           using R.arc_in_dlverts[of "Dtree.root t" "sucs t"] ind.prems(3)
             subtree_if_child[of t "{|(t, e)|}"] by simp
         then show ?thesis using eq normalize1_dlverts_eq[of "Node r {|(t, e)|}"] True by simp
       qed
     next
       case False
       then obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t)" "is_subtree (Node v ys) t2"
         using ind.prems(1) eq by force
       then have "is_subtree (Node v ys) (Node r {|(t, e)|})"
         using subtree_trans[OF t2_def(2)] subtree_if_suc by auto
       then show ?thesis using R.arc_in_dlverts ind.prems(2,3) by blast
     qed
   next
     case nocontr: False
     then show ?thesis
     proof(cases "Node v ys = Node r {|(normalize1 t, e)|}")
       case True
       then have "y \<in> dlverts (Node r {|(t, e)|})"
         using R.arc_in_dlverts ind.prems(2,3) by fastforce
       then show ?thesis using nocontr True by simp
     next
       case False
       then have "is_subtree (Node v ys) (normalize1 t)" using ind.prems(1) nocontr by auto
       then show ?thesis using ind.IH[OF nocontr] ind.prems(2,3) R.ranked_dtree_orig_rec by simp
     qed
   qed
 next
   case (2 xs r)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   have eq: "normalize1 (Node r xs) = Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs)"
     using "2.hyps" by simp
   show ?case
   proof(cases "Node v ys = normalize1 (Node r xs)")
     case True
     then have "y \<in> dlverts (Node r xs)" using R.arc_in_dlverts "2.hyps" "2.prems"(2,3) by simp
     then show ?thesis using True by simp
   next
     case False
     then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset xs" "is_subtree (Node v ys) (normalize1 t2)"
       using "2.hyps" "2.prems"(1) by auto
     then show ?thesis using "2.IH" "2.prems"(2,3) R.ranked_dtree_orig_rec by simp
   qed
 qed
 
 lemma normalize1_arc_in_dlverts':
   "\<forall>r xs. is_subtree (Node r xs) (normalize1 t) \<longrightarrow> (\<forall>x. x \<in> set r
     \<longrightarrow> (\<forall>y. x \<rightarrow>\<^bsub>T\<^esub> y \<longrightarrow> y \<in> set r \<or> (\<exists>x\<in>fset xs. y \<in> dlverts (fst x))))"
   using normalize1_arc_in_dlverts by simp
 
 theorem ranked_dtree_orig_normalize1: "ranked_dtree_with_orig (normalize1 t) rank cost cmp T root"
   by (simp add: ranked_dtree_with_orig_def ranked_dtree_with_orig_axioms_def asi_rank
       normalize1_dom_contr normalize1_dom_mdeg_gt1 normalize1_dom_sub_contr
       normalize1_dom_wedge' directed_tree_axioms normalize1_arc_in_dlverts'
       ranked_dtree_normalize1 normalize1_verts_conform normalize1_verts_distinct)
 
 theorem ranked_dtree_orig_normalize: "ranked_dtree_with_orig (normalize t) rank cost cmp T root"
 using ranked_dtree_with_orig_axioms proof(induction t rule: normalize.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by blast
   show ?case using "1.IH" T.ranked_dtree_orig_normalize1 by(auto simp: Let_def)
 qed
 
 subsubsection \<open>Merging preserves Arc Invariants\<close>
 
 interpretation Comm: comp_fun_commute "merge_f r xs" by (rule merge_commute)
 
 lemma path_lverts_supset_z:
   "\<lbrakk>list_dtree (Node r xs); \<forall>t1 \<in> fst ` fset xs. a \<notin> dlverts t1\<rbrakk>
     \<Longrightarrow> path_lverts_list z a \<subseteq> path_lverts_list (ffold (merge_f r xs) z xs) a"
 proof(induction xs)
   case (insert x xs)
   interpret Comm: comp_fun_commute "merge_f r (finsert x xs)" by (rule merge_commute)
   define f where "f = merge_f r (finsert x xs)"
   define f' where "f' = merge_f r xs"
   let ?merge = "Sorting_Algorithms.merge cmp'"
   have 0: "list_dtree (Node r xs)" using list_dtree_subset insert.prems(1) by blast
   show ?case
   proof(cases "ffold f z (finsert x xs) = ffold f' z xs")
     case True
     then show ?thesis using insert.IH 0 insert.prems(2) f_def f'_def by auto
   next
     case False
     obtain t2 e2 where t2_def[simp]: "x = (t2,e2)" by fastforce
     have 1: "\<forall>v\<in>fst ` set (dtree_to_list (Node r {|(t2, e2)|})). a \<notin> set v"
       using insert.prems(2) dtree_to_list_x_in_dlverts by auto
     have "xs |\<subseteq>| finsert x xs" by blast
     then have f_xs: "ffold f z xs = ffold f' z xs"
       using merge_ffold_supset insert.prems(1) f_def f'_def by presburger
     have "ffold f z (finsert x xs) = f x (ffold f z xs)"
       using Comm.ffold_finsert[OF insert.hyps] f_def by blast
     then have 2: "ffold f z (finsert x xs) = f x (ffold f' z xs)" using f_xs by argo
     then have "f x (ffold f' z xs) \<noteq> ffold f' z xs" using False f_def f'_def by argo
     then have "f (t2,e2) (ffold f' z xs)
               = ?merge (dtree_to_list (Node r {|(t2,e2)|})) (ffold f' z xs)"
       using merge_f_merge_if_not_snd t2_def f_def by blast
     then have "ffold f z (finsert x xs)
               = ?merge (dtree_to_list (Node r {|(t2,e2)|})) (ffold f' z xs)"
       using 2 t2_def by argo
     then have "path_lverts_list (ffold f' z xs) a \<subseteq> path_lverts_list (ffold f z (finsert x xs)) a"
       using path_lverts_list_merge_supset_ys_notin[OF 1] by presburger
     then show ?thesis using insert.IH 0 insert.prems(2) f_def f'_def by auto
   qed
 qed (simp add: ffold.rep_eq)
 
 lemma path_lverts_merge_ffold_sup:
   "\<lbrakk>list_dtree (Node r xs); t1 \<in> fst ` fset xs; a \<in> dlverts t1\<rbrakk>
     \<Longrightarrow> path_lverts t1 a \<subseteq> path_lverts_list (ffold (merge_f r xs) [] xs) a"
 proof(induction xs)
   case (insert x xs)
   interpret Comm: comp_fun_commute "merge_f r (finsert x xs)" by (rule merge_commute)
   define f where "f = merge_f r (finsert x xs)"
   define f' where "f' = merge_f r xs"
   let ?merge = "Sorting_Algorithms.merge cmp'"
   have 0: "list_dtree (Node r xs)" using list_dtree_subset insert.prems(1) by blast
   obtain t2 e2 where t2_def[simp]: "x = (t2,e2)" by fastforce
   have "(t2, e2) \<in> fset (finsert x xs)" by simp
   moreover have "(t2, e2) \<notin> fset xs" using insert.hyps by fastforce
   ultimately have xs_val:
     "(\<forall>(v,e) \<in> set (ffold f' [] xs). set v \<inter> dlverts t2 = {} \<and> v \<noteq> [] \<and> e \<notin> darcs t2 \<union> {e2})"
     using merge_ffold_empty_inter_preserv'[OF insert.prems(1) empty_list_valid_merge] f'_def
     by blast
   have "ffold f [] (finsert x xs) = f x (ffold f [] xs)"
     using Comm.ffold_finsert[OF insert.hyps] f_def by blast
   also have "\<dots> = f x (ffold f' [] xs)"
     using merge_ffold_supset[of xs "finsert x xs" r "[]"] insert.prems(1) f_def f'_def by fastforce
   finally have "ffold f [] (finsert x xs) = ?merge (dtree_to_list (Node r {|x|})) (ffold f' [] xs)"
     using merge_f_merge_if_conds xs_val insert.prems f_def by simp
   then have merge: "ffold f [] (finsert x xs)
               = ?merge (dtree_to_list (Node r {|(t2,e2)|})) (ffold f'[] xs)"
     using t2_def by blast
   show ?case
   proof(cases "t1 = t2")
     case True
     then have "\<forall>v\<in>fst ` set (ffold f' [] xs). a \<notin> set v"
       using insert.prems(3) xs_val by fastforce
     then have "path_lverts_list (dtree_to_list (Node r {|(t2,e2)|})) a
               \<subseteq> path_lverts_list (ffold f [] (finsert x xs)) a"
       using merge path_lverts_list_merge_supset_xs_notin by fastforce
     then show ?thesis using True f_def path_lverts_to_list_eq by force
   next
     case False
     then have "a \<notin> dlverts t2" using insert.prems list_dtree.wf_lverts by fastforce
     then have 1: "\<forall>v\<in>fst ` set (dtree_to_list (Node r {|(t2, e2)|})). a \<notin> set v"
       using dtree_to_list_x_in_dlverts by fast
     have "path_lverts t1 a \<subseteq> path_lverts_list (ffold f' [] xs) a"
       using insert.IH[OF 0] insert.prems(2,3) False f'_def by simp
     then show ?thesis using f_def merge path_lverts_list_merge_supset_ys_notin[OF 1] by auto
   qed
 qed(simp)
 
 lemma path_lverts_merge_sup_aux:
   assumes "list_dtree (Node r xs)" and "t1 \<in> fst ` fset xs" and "a \<in> dlverts t1"
       and "ffold (merge_f r xs) [] xs = (v1, e1) # ys"
   shows "path_lverts t1 a \<subseteq> path_lverts (dtree_from_list v1 ys) a"
 proof -
   have "xs \<noteq> {||}" using assms(2) by auto
   have "path_lverts t1 a \<subseteq> path_lverts_list (ffold (merge_f r xs) [] xs) a"
     using path_lverts_merge_ffold_sup[OF assms(1-3)] .
   then show ?thesis using path_lverts_from_list_eq assms(4) by fastforce
 qed
 
 lemma path_lverts_merge_sup:
   assumes "list_dtree (Node r xs)" and "t1 \<in> fst ` fset xs" and "a \<in> dlverts t1"
   shows "\<exists>t2 e2. merge (Node r xs) = Node r {|(t2,e2)|}
           \<and> path_lverts t1 a \<subseteq> path_lverts t2 a"
 proof -
   have "xs \<noteq> {||}" using assms(2) by auto
   then obtain t2 e2 where t2_def: "merge (Node r xs) = Node r {|(t2,e2)|}"
     using merge_singleton[OF assms(1)] by blast
   obtain y ys where y_def: "ffold (merge_f r xs) [] xs = y # ys"
     using merge_ffold_nempty[OF assms(1) \<open>xs \<noteq> {||}\<close>] list.exhaust_sel by blast
   obtain v1 e1 where "y = (v1,e1)" by fastforce
   then show ?thesis using merge_xs path_lverts_merge_sup_aux[OF assms] t2_def y_def by fastforce
 qed
 
 lemma path_lverts_merge_sup_sucs:
   assumes "list_dtree t0" and "t1 \<in> fst ` fset (sucs t0)" and "a \<in> dlverts t1"
   shows "\<exists>t2 e2. merge t0 = Node (Dtree.root t0) {|(t2,e2)|}
           \<and> path_lverts t1 a \<subseteq> path_lverts t2 a"
   using path_lverts_merge_sup[of "Dtree.root t0" "sucs t0"] assms by simp
 
 lemma merge_dom_children_aux:
   assumes "list_dtree t0"
       and "\<forall>x\<in>dverts t1. \<exists>v \<in> set (Dtree.root t0) \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
       and "t1 \<in> fst ` fset (sucs t0)"
       and "wf_dlverts t1"
       and "x \<in> dverts t1"
     shows "\<exists>!t2 \<in> fst ` fset (sucs (merge t0)).
             \<exists>v \<in> set (Dtree.root (merge t0)) \<union> path_lverts t2 (hd x). v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
 proof -
   have "hd x \<in> dlverts t1" using assms(4,5) by (simp add: hd_in_lverts_if_wf)
   then obtain t2 e2 where t2_def:
       "merge t0 = Node (Dtree.root t0) {|(t2,e2)|}" "path_lverts t1 (hd x) \<subseteq> path_lverts t2 (hd x)"
     using path_lverts_merge_sup_sucs[OF assms(1,3)] by blast
   then show ?thesis using assms(2,5) by force
 qed
 
 lemma merge_dom_children_aux':
   assumes "dom_children t0 T"
       and "\<forall>t1 \<in> fst ` fset (sucs t0). wf_dlverts t1"
       and "t2 \<in> fst ` fset (sucs (merge t0))"
       and "x \<in> dverts t2"
     shows "\<exists>v\<in>set (Dtree.root (merge t0)) \<union> path_lverts t2 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
 proof -
   have disj: "list_dtree t0"
     using assms(3) merge_empty_if_nwf_sucs[of t0] by fastforce
   obtain t1 where t1_def: "t1 \<in> fst ` fset (sucs t0)" "x \<in> dverts t1"
     using verts_child_if_merge_child[OF assms(3,4)] by blast
   then have 0: "\<forall>x\<in>dverts t1. \<exists>v\<in>set (Dtree.root t0) \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
     using assms(1) unfolding dom_children_def by blast
   then have "wf_dlverts t1" using t1_def(1) assms(2) by blast
   then obtain t3 where t3_def: "t3 \<in> fst ` fset (sucs (merge t0))"
       "(\<exists>v\<in>set (Dtree.root (merge t0)) \<union> path_lverts t3 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x)"
     using merge_dom_children_aux[OF disj 0] t1_def by blast
   then have "t3 = t2" using assms(3) merge_single_root1_sucs by fastforce
   then show ?thesis using t3_def(2) by blast
 qed
 
 lemma merge_dom_children_sucs:
   assumes "dom_children t0 T" and "\<forall>t1 \<in> fst ` fset (sucs t0). wf_dlverts t1"
   shows "dom_children (merge t0) T"
   using merge_dom_children_aux'[OF assms] dom_children_def by fast
 
 lemma merge_dom_children:
   "\<lbrakk>dom_children (Node r xs) T; \<forall>t1 \<in> fst ` fset xs. wf_dlverts t1\<rbrakk>
     \<Longrightarrow> dom_children (merge (Node r xs)) T"
   using merge_dom_children_sucs by auto
 
 lemma merge_dom_children_if_ndisjoint:
   "\<not>list_dtree (Node r xs) \<Longrightarrow> dom_children (merge (Node r xs)) T"
   using merge_empty_if_nwf unfolding dom_children_def by simp
 
 lemma merge_subtree_fcard_le1: "is_subtree (Node r xs) (merge t1) \<Longrightarrow> fcard xs \<le> 1"
   using merge_mdeg_le1_sub le_trans mdeg_ge_fcard by fast
 
 lemma merge_dom_mdeg_gt1:
     "\<lbrakk>is_subtree (Node r xs) (merge t2); t1 \<in> fst ` fset xs; max_deg (Node r xs) > 1\<rbrakk>
       \<Longrightarrow> \<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
   using merge_mdeg_le1_sub by fastforce
 
 lemma merge_root_if_contr:
   "\<lbrakk>\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t1 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2));
     is_subtree (Node v {|(t2,e2)|}) (merge t1); rank (rev (Dtree.root t2)) < rank (rev v)\<rbrakk>
     \<Longrightarrow> Node v {|(t2,e2)|} = merge t1"
   using merge_strict_subtree_nocontr_sucs2[of t1 v] strict_subtree_def by fastforce
 
 lemma merge_new_contr_fcard_gt1:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t1 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "Node v {|(t2,e2)|} = (merge t1)"
       and "rank (rev (Dtree.root t2)) < rank (rev v)"
     shows "fcard (sucs t1) > 1"
 proof -
   have t_v: "Dtree.root t1 = v" using assms(2) dtree.sel(1)[of v "{|(t2,e2)|}"] by simp
   have "\<forall>t2 e2. Node v {|(t2,e2)|} \<noteq> t1"
     using assms merge_root_child_eq self_subtree less_le_not_le by metis
   then have "\<forall>x. sucs t1 \<noteq> {|x|}" using t_v dtree.collapse[of t1] by force
   moreover have "sucs t1 \<noteq> {||}" using assms(2) merge_empty_sucs by force
   ultimately show ?thesis using fcard_single_1_iff[of "sucs t1"] fcard_0_eq[of "sucs t1"] by force
 qed
 
 lemma merge_dom_sub_contr_if_nocontr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r xs) (merge t)"
       and "t1 \<in> fst ` fset xs"
       and "\<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r xs)
             \<and> rank (rev (Dtree.root t2)) < rank (rev v)"
     shows "\<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
 proof -
   obtain v t2 e2 where t2_def:
       "is_subtree (Node v {|(t2,e2)|}) (Node r xs)" "rank (rev (Dtree.root t2)) < rank (rev v)"
     using assms(4) by blast
   then have "is_subtree (Node v {|(t2,e2)|}) (merge t)" using assms(2) subtree_trans by blast
   then have eq: "Node v {|(t2,e2)|} = merge t" using merge_root_if_contr assms(1) t2_def(2) by blast
   then have t_v: "Dtree.root t = v" using dtree.sel(1)[of v "{|(t2,e2)|}"] by simp
   have eq2: "Node v {|(t2,e2)|} = Node r xs"
     using eq assms(2) t2_def(1) subtree_antisym[of "Node v {|(t2, e2)|}"] by simp
   have "fcard (sucs t) > 1" using merge_new_contr_fcard_gt1[OF assms(1) eq t2_def(2)] by simp
   then have mdeg: "max_deg t > 1" using mdeg_ge_fcard[of "sucs t" "Dtree.root t"] by simp
   have sub: "is_subtree (Node (Dtree.root t) (sucs t)) t" using self_subtree[of t] by simp
   obtain e1 where e1_def: "(t1, e1)\<in>fset (sucs (merge t))"
     using assms(3) eq eq2 dtree.sel(2)[of r xs] by force
   then obtain t3 where t3_def: "(t3, e1)\<in>fset (sucs t)" "Dtree.root t3 = Dtree.root t1"
     using merge_child_in_orig[OF e1_def] by blast
   then have "\<exists>v\<in>set (Dtree.root t). v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)" using dom_mdeg_gt1 sub mdeg by fastforce
   then show ?thesis using t_v eq2 by blast
 qed
 
 lemma merge_dom_contr_if_nocontr_mdeg_le1:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r {|(t1,e1)|}) (merge t)"
       and "rank (rev (Dtree.root t1)) < rank (rev r)"
       and "\<forall>t \<in> fst ` fset (sucs t). max_deg t \<le> 1"
     shows "dom_children (Node r {|(t1,e1)|}) T"
 proof -
   have eq: "Node r {|(t1,e1)|} = merge t" using merge_root_if_contr[OF assms(1-3)] .
   have 0: "\<forall>t1\<in>fst ` fset (sucs t). wf_dlverts t1" using wf_lverts wf_dlverts_suc by auto
   have "fcard (sucs t) > 1" using merge_new_contr_fcard_gt1[OF assms(1) eq assms(3)] by simp
   then have "dom_children t T" using dom_wedge_full[of "Dtree.root t"] assms(4) self_subtree by force
   then show ?thesis using merge_dom_children_sucs 0 eq by simp
 qed
 
 lemma merge_dom_wedge:
   "\<lbrakk>is_subtree (Node r xs) (merge t1); fcard xs > 1; \<forall>t \<in> fst ` fset xs. max_deg t \<le> 1\<rbrakk>
     \<Longrightarrow> dom_children (Node r xs) T"
   using merge_subtree_fcard_le1 by fastforce
 
 subsubsection \<open>Merge1 preserves Arc Invariants\<close>
 
 lemma merge1_dom_mdeg_gt1:
   assumes "is_subtree (Node r xs) (merge1 t)" and "t1 \<in> fst ` fset xs" and "max_deg (Node r xs) > 1"
   shows "\<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
 proof -
   obtain ys where ys_def: "merge1 (Node r ys) = Node r xs" "is_subtree (Node r ys) t"
     using merge1_subtree_if_mdeg_gt1[OF assms(1,3)] by blast
   then obtain t3 where t3_def: "t3 \<in> fst ` fset ys" "Dtree.root t3 = Dtree.root t1"
     using assms(2) merge1_child_in_orig by fastforce
   have "max_deg (Node r ys) > 1" using merge1_mdeg_le[of "Node r ys"] ys_def(1) assms(3) by simp
   then show ?thesis using dom_mdeg_gt1[OF ys_def(2) t3_def(1)] t3_def by simp
 qed
 
 lemma max_deg1_gt_1_if_new_contr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t0 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r {|(t1,e1)|}) (merge1 t0)"
       and "rank (rev (Dtree.root t1)) < rank (rev r)"
     shows "max_deg t0 > 1"
   using assms merge1_mdeg_gt1_if_uneq by force
 
 lemma merge1_subtree_if_new_contr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t0 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r xs) (merge1 t0)"
       and "is_subtree (Node v {|(t1,e1)|}) (Node r xs)"
       and "rank (rev (Dtree.root t1)) < rank (rev v)"
     shows "\<exists>ys. is_subtree (Node r ys) t0 \<and> merge1 (Node r ys) = Node r xs"
 using assms proof(induction t0)
   case (Node r' ys)
   then consider "fcard ys > 1" "(\<forall>t \<in> fst ` fset ys. max_deg t \<le> 1)"
     | "\<not>(fcard ys > 1 \<and> (\<forall>t \<in> fst ` fset ys. max_deg t \<le> 1))" "Node r xs = merge1 (Node r' ys)"
     | "\<not>(fcard ys > 1 \<and> (\<forall>t \<in> fst ` fset ys. max_deg t \<le> 1))" "Node r xs \<noteq> merge1 (Node r' ys)"
     by blast
   then show ?case
   proof(cases)
     case 1
     then have "is_subtree (Node v {|(t1, e1)|}) (merge (Node r' ys))"
       using subtree_trans[OF Node.prems(3,2)] by force
     then have "Node v {|(t1, e1)|} = merge (Node r' ys)"
       using merge_root_if_contr Node.prems(1,4) by blast
     then have "Node r xs = merge1 (Node r' ys)"
       using Node.prems(2,3) 1 subtree_eq_if_trans_eq1 by fastforce
     then show ?thesis using 1 dtree.sel(1)[of r xs] by auto
   next
     case 2
     then have "r = r'" using dtree.sel(1)[of r xs] by force
     then show ?thesis using 2(2) by auto
   next
     case 3
     then have "merge1 (Node r' ys) = Node r' ((\<lambda>(t,e). (merge1 t,e)) |`| ys)" by auto
     then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset ys" "is_subtree (Node r xs) (merge1 t2)"
       using Node.prems(2) 3(2) by auto
     then have subt2: "is_subtree t2 (Node r' ys)" using subtree_if_child
       by (metis fstI image_eqI)
     then have "\<And>r1 t3 e3. is_subtree (Node r1 {|(t3, e3)|}) t2
                     \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t3))"
       using Node.prems(1) subtree_trans by blast
     then obtain ys' where ys_def: "is_subtree (Node r ys') t2" "merge1 (Node r ys') = Node r xs"
       using Node.IH[OF t2_def(1)] Node.prems(3,4) t2_def(2) by auto
     then show ?thesis using subtree_trans subt2 by blast
   qed
 qed
 
 lemma merge1_dom_sub_contr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r xs) (merge1 t)"
       and "t1 \<in> fst ` fset xs"
       and "\<exists>v t2 e2. is_subtree (Node v {|(t2,e2)|}) (Node r xs)\<and>rank (rev (Dtree.root t2))<rank (rev v)"
     shows "\<exists>v \<in> set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"
 proof -
   obtain ys where ys_def: "is_subtree (Node r ys) t" "merge1 (Node r ys) = Node r xs"
     using merge1_subtree_if_new_contr assms(1,2,4) by blast
   then interpret R: ranked_dtree_with_orig "Node r ys" using ranked_dtree_orig_subtree by blast
   obtain v t2 e2 where v_def:
       "is_subtree (Node v {|(t2,e2)|}) (Node r xs)" "rank (rev (Dtree.root t2)) < rank (rev v)"
     using assms(4) by blast
   then have "is_subtree (Node v {|(t2,e2)|}) (merge1 (Node r ys))" using ys_def by simp
   then have mdeg_gt1: "max_deg (Node r ys) > 1"
     using max_deg1_gt_1_if_new_contr assms(1) v_def(2) subtree_trans ys_def(1) by blast
   obtain t3 where t3_def: "t3 \<in> fst ` fset ys" "Dtree.root t3 = Dtree.root t1"
     using ys_def(2) assms(3) merge1_child_in_orig by fastforce
   then show ?thesis using R.dom_mdeg_gt1[OF self_subtree] mdeg_gt1 by fastforce
 qed
 
 lemma merge1_merge_point_if_new_contr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t0 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "wf_darcs t0"
       and "is_subtree (Node r {|(t1,e1)|}) (merge1 t0)"
       and "rank (rev (Dtree.root t1)) < rank (rev r)"
     shows "\<exists>ys. is_subtree (Node r ys) t0 \<and> fcard ys > 1 \<and> (\<forall>t\<in> fst ` fset ys. max_deg t \<le> 1)
             \<and> merge1 (Node r ys) = Node r {|(t1,e1)|}"
 using assms proof(induction t0)
   case (Node v xs)
   then consider "fcard xs > 1" "(\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1)"
     | "fcard xs \<le> 1" | "fcard xs > 1" "\<not>(\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1)"
     by linarith
   then show ?case
   proof(cases)
     case 1
     then have "is_subtree (Node r {|(t1, e1)|}) (merge (Node v xs))" using Node.prems(3) by simp
     then have "Node r {|(t1, e1)|} = merge (Node v xs)"
       using merge_root_if_contr Node.prems(1,4) by blast
     then show ?thesis using 1 dtree.sel(1)[of r "{|(t1, e1)|}"] by auto
   next
     case 2
     then have "merge1 (Node v xs) = Node v ((\<lambda>(t,e). (merge1 t,e)) |`| xs)" by auto
     then have "xs \<noteq> {||}" using Node.prems(3) by force
     then have "fcard xs = 1" using 2 le_Suc_eq by auto
     then obtain t2 e2 where t2_def: "xs = {|(t2,e2)|}" using fcard_single_1_iff[of xs] by fast
     then have "Node r {|(t1, e1)|} \<noteq> merge1 (Node v {|(t2,e2)|})" using Node.prems(1,4) 2 by force
     then have "is_subtree (Node r {|(t1, e1)|}) (merge1 t2)" using Node.prems(3) t2_def 2 by auto
     moreover have "\<And>r1 t3 e3. is_subtree (Node r1 {|(t3, e3)|}) t2
                     \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t3))"
       using Node.prems(1) t2_def by fastforce
     ultimately show ?thesis using Node.IH[of "(t2,e2)"] Node.prems(2,4) t2_def by fastforce
   next
     case 3
     then have "fcard ((\<lambda>(t,e). (merge1 t,e)) |`| xs) > 1"
       using fcard_merge1_img_if_disjoint disjoint_darcs_if_wf_xs[OF Node.prems(2)] by simp
     then have "Node r {|(t1,e1)|} \<noteq> merge1 (Node v xs)"
       using fcard_single_1_iff[of "(\<lambda>(t,e). (merge1 t,e)) |`| xs"] 3(2) by auto
     moreover have "merge1 (Node v xs) = Node v ((\<lambda>(t,e). (merge1 t,e)) |`| xs)" using 3(2) by auto
     ultimately obtain t2 e2 where t2_def:
         "(t2,e2) \<in> fset xs" "is_subtree (Node r {|(t1, e1)|}) (merge1 t2)"
       using Node.prems(3) by auto
     then have "is_subtree t2 (Node v xs)" using subtree_if_child
       by (metis fst_conv image_eqI)
     then have "\<And>r1 t3 e3. is_subtree (Node r1 {|(t3, e3)|}) t2
                     \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t3))"
       using Node.prems(1) subtree_trans by blast
     then obtain ys where ys_def: "is_subtree (Node r ys) t2" "1 < fcard ys"
         "(\<forall>t\<in>fst ` fset ys. max_deg t \<le> 1)" "merge1 (Node r ys) = Node r {|(t1, e1)|}"
       using Node.IH[OF t2_def(1)] Node.prems(2,4) t2_def by fastforce
     then show ?thesis using t2_def(1) by auto
   qed
 qed
 
 lemma merge1_dom_contr:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r {|(t1,e1)|}) (merge1 t)"
       and "rank (rev (Dtree.root t1)) < rank (rev r)"
       and "max_deg (Node r {|(t1,e1)|}) = 1"
     shows "dom_children (Node r {|(t1,e1)|}) T"
 proof -
   obtain ys where ys_def: "is_subtree (Node r ys) t" "fcard ys > 1"
       "\<forall>t\<in>fst ` fset ys. max_deg t \<le> 1" "merge1 (Node r ys) = Node r {|(t1,e1)|}"
     using merge1_merge_point_if_new_contr wf_arcs assms(1-3) by blast
   have "\<forall>t1\<in>fst ` fset ys. wf_dlverts t1"
     using ys_def(1) list_dtree.wf_lverts list_dtree_sub by fastforce
   then show ?thesis using merge_dom_children_sucs[OF dom_wedge_full] ys_def by fastforce
 qed
 
 lemma merge1_dom_children_merge_sub_aux:
   assumes "merge1 t = t2"
       and "is_subtree (Node r' xs') t"
       and "fcard xs' > 1"
       and "(\<forall>t\<in>fst ` fset xs'. max_deg t \<le> 1)"
       and "max_deg t2 \<le> 1"
       and "x \<in> dverts t2"
       and "x \<noteq> Dtree.root t2"
     shows "\<exists>v \<in> path_lverts t2 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
 using assms ranked_dtree_with_orig_axioms proof(induction t arbitrary: t2)
   case (Node r xs)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   obtain t1 e1 where t1_def: "(t1,e1) \<in> fset (sucs t2)" "x \<in> dverts t1"
     by (metis Node.prems(6,7) fsts.simps dtree.sel dtree.set_cases(1) fst_conv surj_pair)
   then have t2_sucs: "sucs t2 = {|(t1,e1)|}"
     using Node.prems(5) empty_iff_mdeg_0[of "Dtree.root t2" "sucs t2"]
       mdeg_1_singleton[of "Dtree.root t2" "sucs t2"] by auto
   have wf_t2: "wf_dlverts t2" using Node.prems(1) R.wf_dlverts_merge1 by blast
   then have "wf_dlverts t1" using t1_def(1) wf_dlverts_suc by fastforce
   then have "hd x \<in> dlverts t1" using t1_def(2) hd_in_lverts_if_wf by blast
   then have "hd x \<notin> set (Dtree.root t2)" using dlverts_notin_root_sucs[OF wf_t2] t1_def(1) by fastforce
   then have path_t2: "path_lverts t2 (hd x) = set (Dtree.root t2) \<union> path_lverts t1 (hd x)"
     using path_lverts_simps1_sucs t2_sucs by fastforce
   show ?case
   proof(cases "Node r xs = Node r' xs'")
     case True
     then have "merge (Node r' xs') = t2" using Node.prems(1,3,4) by simp
     then have "dom_children t2 T"
       using R.dom_wedge_full[OF Node.prems(2-4)] merge_dom_children R.wf_lverts True by fastforce
     then have "\<exists>v\<in>set (Dtree.root t2) \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
       using t1_def unfolding dom_children_def by auto
     then show ?thesis using path_t2 by blast
   next
     case False
     then have "\<not>(fcard xs > 1 \<and> (\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1))"
       using Node.prems(3,4) child_mdeg_gt1_if_sub_fcard_gt1[OF Node.prems(2)] by force
     then have eq: "merge1 (Node r xs) = Node r ((\<lambda>(t,e). (merge1 t,e)) |`| xs)" by auto
     then obtain t3 e3 where t3_def: "(t3,e3) \<in> fset xs" "is_subtree (Node r' xs') t3"
       using Node.prems(2) False by auto
     have "fcard ((\<lambda>(t,e). (merge1 t,e)) |`| xs) = 1"
       using Node.prems(1) eq t2_sucs fcard_single_1 by fastforce
     then have "fcard xs = 1"
       using fcard_merge1_img_if_disjoint disjoint_darcs_if_wf_xs[OF R.wf_arcs] by simp
     then have "xs = {|(t3,e3)|}" using fcard_single_1_iff[of xs] t3_def(1) by auto
     then have t13: "merge1 t3 = t1" using t2_sucs eq Node.prems(1) by force
     then have mdegt3: "max_deg t1 \<le> 1"
       using Node.prems(5) mdeg_ge_child[of t1 e1 "sucs t2" "Dtree.root t2"] t2_sucs by fastforce
     have mdeg_gt1: "max_deg (Node r xs) > 1"
       using mdeg_ge_fcard[of xs' r'] Node.prems(2,3) mdeg_ge_sub[of "Node r' xs'" "Node r xs"]
       by simp
     show ?thesis
     proof(cases "x = Dtree.root t1")
       case True
       then have "\<exists>v\<in>set r. v \<rightarrow>\<^bsub>T\<^esub> hd x"
         using R.dom_mdeg_gt1[of r xs] t3_def(1) mdeg_gt1 t13 by fastforce
       then show ?thesis using path_t2 Node.prems(1) by auto
     next
       case False
       then have "\<exists>v\<in>path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
         using Node.IH t1_def(2) t3_def t13 assms(3,4) mdegt3 R.ranked_dtree_orig_rec by simp
       then show ?thesis using path_t2 by blast
     qed
   qed
 qed
 
 lemma merge1_dom_children_fcard_gt1_aux:
   assumes "dom_children (Node r (Abs_fset (children_deg1 ys))) T"
       and "is_subtree (Node r ys) t"
       and "merge1 (Node r ys) = Node r xs"
       and "fcard xs > 1"
       and "max_deg t2 \<le> 1"
       and "t2 \<in> fst ` fset xs"
       and "x \<in> dverts t2"
     shows "\<exists>v\<in>set r \<union> path_lverts t2 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
 proof -
   obtain t1 where t1_def: "t1 \<in> fst ` fset ys" "merge1 t1 = t2"
     using merge1_elem_in_img_if_fcard_gt1[OF assms(3,4)] assms(6) by fastforce
   then have x_t: "x \<in> dverts t1" using merge1_dverts_sub assms(7) by blast
   show ?thesis
   proof(cases "max_deg t1 \<le> 1")
     case True
     then have "t1 \<in> fst ` fset (sucs (Node r (Abs_fset (children_deg1 ys))))"
       using t1_def(1) children_deg1_fset_id by force
     then have "\<exists>v\<in>set r \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> hd x"
       using assms(1) x_t unfolding dom_children_def by auto
     then show ?thesis using t1_def(2) merge1_mdeg_gt1_if_uneq[of t1] True by force
   next
     case False
     then obtain r' xs' where r'_def:
         "is_subtree (Node r' xs') t1" "1 < fcard xs'" "(\<forall>t\<in>fst ` fset xs'. max_deg t \<le> 1)"
       using merge1_wedge_if_uneq[of t1] assms(5) t1_def(2) by fastforce
     interpret R: ranked_dtree_with_orig "Node r ys" using ranked_dtree_orig_subtree assms(2) .
     interpret T: ranked_dtree_with_orig t1 using R.ranked_dtree_orig_rec t1_def(1) by force
     have "max_deg (Node r ys) > 1"
       using assms(3,4) merge1_fcard_le[of r ys] mdeg_ge_fcard[of ys] by simp
     show ?thesis
     proof (cases "x = Dtree.root t2")
       case True
       have "max_deg (Node r ys) > 1"
         using assms(3,4) merge1_fcard_le[of r ys] mdeg_ge_fcard[of ys] by simp
       then show ?thesis using dom_mdeg_gt1[OF assms(2) t1_def(1)] True t1_def(2) by auto
     next
       case False
       then show ?thesis
         using T.merge1_dom_children_merge_sub_aux[OF t1_def(2) r'_def assms(5,7)] by blast
     qed
   qed
 qed
 
 lemma merge1_dom_children_fcard_gt1:
   assumes "dom_children (Node r (Abs_fset (children_deg1 ys))) T"
       and "is_subtree (Node r ys) t"
       and "merge1 (Node r ys) = Node r xs"
       and "fcard xs > 1"
     shows "dom_children (Node r (Abs_fset (children_deg1 xs))) T"
   unfolding dom_children_def
   using merge1_dom_children_fcard_gt1_aux[OF assms] children_deg1_fset_id[of xs] by fastforce
 
 lemma merge1_dom_wedge:
   assumes "is_subtree (Node r xs) (merge1 t)" and "fcard xs > 1"
   shows "dom_children (Node r (Abs_fset (children_deg1 xs))) T"
 proof -
   obtain ys where ys_def:
       "merge1 (Node r ys) = Node r xs" "is_subtree (Node r ys) t" "fcard xs \<le> fcard ys"
     using merge1_subtree_if_fcard_gt1[OF assms] by blast
   have "dom_children (Node r (Abs_fset (children_deg1 ys))) T"
     using dom_wedge ys_def(2,3) assms(2) by simp
   then show ?thesis using merge1_dom_children_fcard_gt1 ys_def(2,1) assms(2) by blast
 qed
 
 corollary merge1_dom_wedge':
   "\<forall>r xs. is_subtree (Node r xs) (merge1 t) \<longrightarrow> fcard xs > 1
     \<longrightarrow> dom_children (Node r (Abs_fset {(t, e). (t, e) \<in> fset xs \<and> max_deg t \<le> Suc 0})) T"
   by (auto simp only: merge1_dom_wedge One_nat_def[symmetric])
 
 corollary merge1_verts_conform: "v \<in> dverts (merge1 t) \<Longrightarrow> seq_conform v"
   by (simp add: verts_conform)
 
 corollary merge1_verts_distinct: "\<lbrakk>v \<in> dverts (merge1 t)\<rbrakk> \<Longrightarrow> distinct v"
   using distinct_merge1 verts_distinct by auto
 
 lemma merge1_mdeg_le1_wedge_if_fcard_gt1:
   assumes "max_deg (merge1 t1) \<le> 1"
       and "wf_darcs t1"
       and "is_subtree (Node v ys) t1"
       and "fcard ys > 1"
     shows "(\<forall>t \<in> fst ` fset ys. max_deg t \<le> 1)"
 using assms proof(induction t1 rule: merge1.induct)
   case (1 r xs)
   then show ?case
   proof(cases "fcard xs > 1 \<and> (\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1)")
     case True
     then have "Node v ys = Node r xs"
       using "1.prems"(3,4) mdeg_ge_sub mdeg_ge_fcard[of ys] by fastforce
     then show ?thesis using True by simp
   next
     case False
     then have eq: "merge1 (Node r xs) = Node r ((\<lambda>(t, e). (merge1 t, e)) |`| xs)" by auto
     have "fcard ((\<lambda>(t, e). (merge1 t, e)) |`| xs) = fcard xs"
       using fcard_merge1_img_if_disjoint disjoint_darcs_if_wf_xs[OF "1.prems"(2)] by simp
     then have "fcard xs \<le> 1"
       by (metis "1.prems"(1) False merge1.simps num_leaves_1_if_mdeg_1 num_leaves_ge_card)
     then have "Node v ys \<noteq> Node r xs" using "1.prems"(4) by auto
     then obtain t2 e2 where t2_def: "(t2,e2) \<in> fset xs" "is_subtree (Node v ys) t2"
       using "1.prems"(3) by auto
     then have "max_deg (merge1 t2) \<le> 1"
       using "1.prems"(1) False eq
         mdeg_ge_child[of "merge1 t2" e2 "(\<lambda>(t, e). (merge1 t, e)) |`| xs"]
       by fastforce
     then show ?thesis using "1.IH"[OF False t2_def(1) refl] t2_def "1.prems"(2,4) by fastforce
   qed
 qed
 
 lemma dom_mdeg_le1_merge1_aux:
   assumes "max_deg (merge1 t) \<le> 1"
       and "merge1 t \<noteq> t"
       and "t1 \<in> fst ` fset (sucs (merge1 t))"
       and "x \<in> dverts t1"
     shows "\<exists>r\<in>set (Dtree.root (merge1 t)) \<union> path_lverts t1 (hd x). r \<rightarrow>\<^bsub>T\<^esub> hd x"
 using assms ranked_dtree_with_orig_axioms proof(induction t arbitrary: t1 rule: merge1.induct)
   case (1 r xs)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   show ?case
   proof(cases "fcard xs > 1")
     case True
     then have 0: "(\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1)"
       using merge1_mdeg_le1_wedge_if_fcard_gt1[OF "1.prems"(1) R.wf_arcs] by auto
     then have "dom_children (merge (Node r xs)) T"
       using True merge_dom_children_sucs R.dom_wedge_full R.wf_lverts self_subtree wf_dlverts_suc
       by fast
     then show ?thesis unfolding dom_children_def using "1.prems"(3,4) 0 True by auto
   next
     case False
     then have rec: "\<not>(fcard xs > 1 \<and> (\<forall>t \<in> fst ` fset xs. max_deg t \<le> 1))" by simp
     then have eq: "merge1 (Node r xs) = Node r ((\<lambda>(t,e). (merge1 t,e)) |`| xs)" by auto
     obtain t2 e2 where t2_def: "xs = {|(t2,e2)|}" "merge1 t2 = t1"
       using "1.prems"(3) False singleton_if_fcard_le1_elem[of xs] by fastforce
     show ?thesis
     proof(cases "x = Dtree.root t1")
       case True
       have "max_deg (Node r xs) > 1" using merge1_mdeg_gt1_if_uneq "1.prems"(2) by blast
       then show ?thesis using True R.dom_mdeg_gt1[OF self_subtree] t2_def by auto
     next
       case False
       then obtain t3 where t3_def: "t3 \<in> fst ` fset (sucs (merge1 t2))" "x \<in> dverts t3"
         using "1.prems"(4) t2_def(2) dverts_root_or_suc by fastforce
       have mdeg1: "max_deg (merge1 t2) \<le> 1"
         using "1.prems"(1) mdeg_ge_child[of t1 e2 "(\<lambda>(t,e). (merge1 t,e)) |`| xs"] eq t2_def
         by simp
       then have 0: "\<exists>r\<in>set (Dtree.root (merge1 t2)) \<union> path_lverts t3 (hd x). r \<rightarrow>\<^bsub>T\<^esub> hd x"
         using "1.IH" rec mdeg1 t3_def "1.prems"(2) eq t2_def R.ranked_dtree_orig_rec by auto
       obtain e3 where e3_def: "sucs t1 = {|(t3, e3)|}"
         using t3_def singleton_if_mdeg_le1_elem_suc mdeg1 t2_def(2) by fastforce
       have "wf_dlverts t1" using wf_dlverts_suc "1.prems"(3)  R.wf_dlverts_merge1 by blast
       then have "hd x \<in> dlverts t3"
         using t3_def(2) "1.prems"(4) list_in_verts_iff_lverts hd_in_set[of x] empty_notin_wf_dlverts
         by fast
       then have "hd x \<notin> set (Dtree.root t1)"
         using t3_def(1) dlverts_notin_root_sucs[OF \<open>wf_dlverts t1\<close>] t2_def(2) by blast
       then show ?thesis using 0 path_lverts_simps1_sucs[of "hd x" t1] e3_def t2_def(2) by blast
     qed
   qed
 qed
 
 lemma dom_mdeg_le1_merge1:
   "\<lbrakk>max_deg (merge1 t) \<le> 1; merge1 t \<noteq> t\<rbrakk> \<Longrightarrow> dom_children (merge1 t) T"
   unfolding dom_children_def using dom_mdeg_le1_merge1_aux by blast
 
 lemma merge1_arc_in_dlverts:
   "\<lbrakk>is_subtree (Node r xs) (merge1 t); x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts (Node r xs)"
   using merge1_subtree_dlverts_supset arc_in_dlverts by blast
 
 theorem merge1_ranked_dtree_orig:
   assumes "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
   shows "ranked_dtree_with_orig (merge1 t) rank cost cmp T root"
   using assms merge1_arc_in_dlverts
   unfolding ranked_dtree_with_orig_def ranked_dtree_with_orig_axioms_def
   by(simp add: directed_tree_axioms ranked_dtree_merge1 merge1_verts_distinct merge1_verts_conform
       merge1_dom_mdeg_gt1 merge1_dom_contr merge1_dom_sub_contr merge1_dom_wedge' asi_rank)
 
 theorem merge1_normalize_ranked_dtree_orig:
   "ranked_dtree_with_orig (merge1 (normalize t)) rank cost cmp T root"
   using ranked_dtree_with_orig.merge1_ranked_dtree_orig[OF ranked_dtree_orig_normalize]
   by (simp add: normalize_sorted_ranks)
 
 theorem ikkbz_sub_ranked_dtree_orig: "ranked_dtree_with_orig (ikkbz_sub t) rank cost cmp T root"
 using ranked_dtree_with_orig_axioms proof(induction t rule: ikkbz_sub.induct)
   case (1 t)
   then show ?case
   proof(cases "max_deg t \<le> 1")
     case True
     then show ?thesis using "1.prems" by auto
   next
     case False
     then show ?thesis
       by (metis 1 ranked_dtree_with_orig.merge1_normalize_ranked_dtree_orig ikkbz_sub.simps)
   qed
 qed
 
 subsection \<open>Optimality of IKKBZ-Sub result constrained to Invariants\<close>
 
 lemma dtree_size_skip_decr[termination_simp]: "size (Node r (sucs t1)) < size (Node v {|(t1,e1)|})"
   using dtree_size_eq_root[of "Dtree.root t1" "sucs t1"] by auto
 
 lemma dtree_size_skip_decr1: "size (Node (r @ Dtree.root t1) (sucs t1)) < size (Node r {|(t1,e1)|})"
   using dtree_size_skip_decr by auto
 
 function normalize_full :: "('a list,'b) dtree \<Rightarrow> ('a list,'b) dtree" where
   "normalize_full (Node r {|(t1,e1)|}) = normalize_full (Node (r@Dtree.root t1) (sucs t1))"
 | "\<forall>x. xs \<noteq> {|x|} \<Longrightarrow> normalize_full (Node r xs) = Node r xs"
   using dtree_to_list.cases by blast+
 termination using dtree_size_skip_decr "termination" in_measure wf_measure by metis
 
 subsubsection \<open>Result fulfills the requirements\<close>
 
 lemma ikkbz_sub_eq_if_mdeg_le1: "max_deg t1 \<le> 1 \<Longrightarrow> ikkbz_sub t1 = t1"
   by simp
 
 lemma ikkbz_sub_eq_iff_mdeg_le1: "max_deg t1 \<le> 1 \<longleftrightarrow> ikkbz_sub t1 = t1"
   using ikkbz_sub_mdeg_le1[of t1] by fastforce
 
 lemma dom_mdeg_le1_ikkbz_sub: "ikkbz_sub t \<noteq> t \<Longrightarrow> dom_children (ikkbz_sub t) T"
 using ranked_dtree_with_orig_axioms proof(induction t rule: ikkbz_sub.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by simp
   interpret NT: ranked_dtree_with_orig "normalize t"
     using T.ranked_dtree_orig_normalize by blast
   interpret MT: ranked_dtree_with_orig "merge1 (normalize t)"
     using T.merge1_normalize_ranked_dtree_orig by blast
   show ?case
   proof(cases "max_deg t \<le> 1")
     case True
     then show ?thesis using "1.prems" by auto
   next
     case False
     then show ?thesis
     proof(cases "max_deg (merge1 (normalize t)) \<le> 1")
       case True
       then show ?thesis
         using NT.dom_mdeg_le1_merge1 T.dom_mdeg_le1_normalize T.list_dtree_axioms False
         by force
     next
       case False
       then have "ikkbz_sub (merge1 (normalize t)) \<noteq> (merge1 (normalize t))"
         using ikkbz_sub_mdeg_le1[of "merge1 (normalize t)"] by force
       then show ?thesis using 1 MT.ranked_dtree_with_orig_axioms by auto
     qed
   qed
 qed
 
 lemma combine_denormalize_eq:
   "denormalize (Node r {|(t1,e1)|}) = denormalize (Node (r@Dtree.root t1) (sucs t1))"
   by (induction t1 rule: denormalize.induct) auto
 
 lemma normalize1_denormalize_eq: "wf_dlverts t1 \<Longrightarrow> denormalize (normalize1 t1) = denormalize t1"
 proof(induction t1 rule: normalize1.induct)
   case (1 r t e)
   then show ?case using combine_denormalize_eq[of r t] by simp
 next
   case (2 xs r)
   then show ?case
     using fcard_single_1_iff[of "(\<lambda>(t,e). (normalize1 t,e)) |`| xs"] fcard_single_1_iff[of xs]
     by (auto simp: fcard_normalize_img_if_wf_dlverts)
 qed
 
 lemma normalize1_denormalize_eq': "wf_darcs t1 \<Longrightarrow> denormalize (normalize1 t1) = denormalize t1"
 proof(induction t1 rule: normalize1.induct)
   case (1 r t e)
   then show ?case using combine_denormalize_eq[of r t] by (auto simp: wf_darcs_iff_darcs')
 next
   case (2 xs r)
   then show ?case
     using fcard_single_1_iff[of "(\<lambda>(t,e). (normalize1 t,e)) |`| xs"] fcard_single_1_iff[of xs]
     by (auto simp: fcard_normalize_img_if_disjoint wf_darcs_iff_darcs')
 qed
 
 lemma normalize_denormalize_eq: "wf_dlverts t1 \<Longrightarrow> denormalize (normalize t1) = denormalize t1"
   apply (induction t1 rule: normalize.induct)
   by (smt (verit) normalize1_denormalize_eq normalize.simps wf_dlverts_normalize1)
 
 lemma normalize_denormalize_eq': "wf_darcs t1 \<Longrightarrow> denormalize (normalize t1) = denormalize t1"
   apply (induction t1 rule: normalize.induct)
   by (smt (verit) normalize1_denormalize_eq' normalize.simps wf_darcs_normalize1)
 
 lemma normalize_full_denormalize_eq[simp]: "denormalize (normalize_full t1) = denormalize t1"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   then show ?case using combine_denormalize_eq[of r t] by simp
 qed(simp)
 
 lemma combine_dlverts_eq: "dlverts (Node r {|(t1,e1)|}) = dlverts (Node (r@Dtree.root t1) (sucs t1))"
   using dlverts.simps[of "Dtree.root t1" "sucs t1"] by auto
 
 lemma normalize_full_dlverts_eq[simp]: "dlverts (normalize_full t1) = dlverts t1"
   using combine_dlverts_eq by(induction t1 rule: normalize_full.induct) fastforce+
 
 lemma combine_darcs_sub: "darcs (Node (r@Dtree.root t1) (sucs t1)) \<subseteq> darcs (Node r {|(t1,e1)|})"
   using dtree.set(2)[of "Dtree.root t1" "sucs t1"] by auto
 
 lemma normalize_full_darcs_sub: "darcs (normalize_full t1) \<subseteq> darcs t1"
   using combine_darcs_sub by(induction t1 rule: normalize_full.induct) fastforce+
 
 lemma combine_nempty_if_wf_dlverts: "wf_dlverts (Node r {|(t1,e1)|}) \<Longrightarrow> r @ Dtree.root t1 \<noteq> []"
   by simp
 
 lemma combine_empty_inter_if_wf_dlverts:
   assumes "wf_dlverts (Node r {|(t1,e1)|})"
   shows "\<forall>(x, e1)\<in>fset (sucs t1). set (r @ Dtree.root t1) \<inter> dlverts x = {} \<and> wf_dlverts x"
 proof -
   have "\<forall>(x, e1)\<in>fset (sucs t1). set r \<inter> dlverts x = {}" using suc_in_dlverts assms by fastforce
   then show ?thesis using wf_dlverts.simps[of "Dtree.root t1" "sucs t1"] assms by auto
 qed
 
 lemma combine_disjoint_if_wf_dlverts:
   "wf_dlverts (Node r {|(t1,e1)|}) \<Longrightarrow> disjoint_dlverts (sucs t1)"
   using wf_dlverts.simps[of "Dtree.root t1" "sucs t1"] by simp
 
 lemma combine_wf_dlverts:
   "wf_dlverts (Node r {|(t1,e1)|}) \<Longrightarrow> wf_dlverts (Node (r@Dtree.root t1) (sucs t1))"
   using combine_empty_inter_if_wf_dlverts[of r t1] wf_dlverts.simps[of "Dtree.root t1" "sucs t1"]
   by force
 
 lemma combine_distinct:
   assumes "\<forall>v \<in> dverts (Node r {|(t1,e1)|}). distinct v"
       and "wf_dlverts (Node r {|(t1,e1)|})"
       and "v \<in> dverts (Node (r@Dtree.root t1) (sucs t1))"
     shows "distinct v"
 proof(cases "v = r @ Dtree.root t1")
   case True
   have "(Dtree.root t1) \<in> dverts t1" by (simp add: dtree.set_sel(1))
   moreover from this have "set r \<inter> set (Dtree.root t1) = {}"
     using assms(2) lverts_if_in_verts by fastforce
   ultimately show ?thesis using True assms(1) by simp
 next
   case False
   then show ?thesis using assms(1,3) dverts_suc_subseteq by fastforce
 qed
 
 lemma normalize_full_wfdlverts: "wf_dlverts t1 \<Longrightarrow> wf_dlverts (normalize_full t1)"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t1 e1)
   then show ?case using combine_wf_dlverts[of r t1] by simp
 qed(simp)
 
 corollary normalize_full_wfdverts: "wf_dlverts t1 \<Longrightarrow> wf_dverts (normalize_full t1)"
   using normalize_full_wfdlverts by (simp add: wf_dverts_if_wf_dlverts)
 
 lemma combine_wf_arcs: "wf_darcs (Node r {|(t1,e1)|}) \<Longrightarrow> wf_darcs (Node (r@Dtree.root t1) (sucs t1))"
   using wf_darcs'.simps[of "Dtree.root t1" "sucs t1"] by (simp add: wf_darcs_iff_darcs')
 
 lemma normalize_full_wfdarcs: "wf_darcs t1 \<Longrightarrow> wf_darcs (normalize_full t1)"
   using combine_wf_arcs by(induction t1 rule: normalize_full.induct) fastforce+
 
 lemma normalize_full_dom_preserv: "dom_children t1 T \<Longrightarrow> dom_children (normalize_full t1) T"
   by (induction t1 rule: normalize_full.induct) (auto simp: dom_children_combine)
 
 lemma combine_forward:
   assumes "dom_children (Node r {|(t1,e1)|}) T"
       and "\<forall>v \<in> dverts (Node r {|(t1,e1)|}). forward v"
       and "wf_dlverts (Node r {|(t1,e1)|})"
       and "v \<in> dverts (Node (r@Dtree.root t1) (sucs t1))"
     shows "forward v"
 proof(cases "v = r @ Dtree.root t1")
   case True
   have 0: "(Dtree.root t1) \<in> dverts t1" by (simp add: dtree.set_sel(1))
   then have fwd_t1: "forward (Dtree.root t1)" using assms(2) by simp
   moreover have "set r \<inter> set (Dtree.root t1) = {}" using assms(3) 0 lverts_if_in_verts by fastforce
   moreover have "\<exists>x\<in>set r. \<exists>y\<in>set (Dtree.root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
     using assms(1,3) root_arc_if_dom_wfdlverts by fastforce
   ultimately have "\<exists>x\<in>set r. x \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t1)"  using forward_arc_to_head by blast
   moreover have fwd_r: "forward r" using assms(2) by simp
   ultimately show ?thesis using forward_app fwd_t1 True by simp
 next
   case False
   then show ?thesis using assms(2,4) dverts_suc_subseteq by fastforce
 qed
 
 lemma normalize_full_forward:
   "\<lbrakk>dom_children t1 T; \<forall>v \<in> dverts t1. forward v; wf_dlverts t1\<rbrakk>
     \<Longrightarrow> \<forall>v \<in> dverts (normalize_full t1). forward v"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   have "\<forall>v \<in> dverts (Node (r@Dtree.root t) (sucs t)). forward v"
     using combine_forward[OF "1.prems"(1,2,3)] by blast
   moreover have "dom_children (Node (r@Dtree.root t) (sucs t)) T"
     using dom_children_combine "1.prems"(1) by simp
   ultimately show ?case using "1.IH" "1.prems"(3) combine_wf_dlverts[of r t e] by fastforce
 qed(auto)
 
 lemma normalize_full_max_deg0: "max_deg t1 \<le> 1 \<Longrightarrow> max_deg (normalize_full t1) = 0"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   then show ?case using mdeg_child_sucs_le by (fastforce dest: order_trans)
 next
   case (2 xs r)
   then show ?case using empty_fset_if_mdeg_le1_not_single by auto
 qed
 
 lemma normalize_full_mdeg_eq: "max_deg t1 > 1 \<Longrightarrow> max_deg (normalize_full t1) = max_deg t1"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   then show ?case using mdeg_child_sucs_eq_if_gt1 by force
 qed(auto)
 
 lemma normalize_full_empty_sucs: "max_deg t1 \<le> 1 \<Longrightarrow> \<exists>r. normalize_full t1 = Node r {||}"
 proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   then show ?case using mdeg_child_sucs_le by (fastforce dest: order_trans)
 next
   case (2 xs r)
   then show ?case using empty_fset_if_mdeg_le1_not_single by auto
 qed
 
 lemma normalize_full_forward_singleton:
   "\<lbrakk>max_deg t1 \<le> 1; dom_children t1 T; \<forall>v \<in> dverts t1. forward v; wf_dlverts t1\<rbrakk>
     \<Longrightarrow> \<exists>r. normalize_full t1 = Node r {||} \<and> forward r"
   using normalize_full_empty_sucs normalize_full_forward by fastforce
 
 lemma denormalize_empty_sucs_simp: "denormalize (Node r {||}) = r"
   using denormalize.simps(2) by blast
 
 lemma normalize_full_dverts_eq_denormalize:
   assumes "max_deg t1 \<le> 1"
   shows "dverts (normalize_full t1) = {denormalize t1}"
 proof -
   obtain r where r_def[simp]: "normalize_full t1 = Node r {||}"
     using assms normalize_full_empty_sucs by blast
   then have "denormalize (normalize_full t1) = r" by (simp add: denormalize_empty_sucs_simp)
   then have "r = denormalize t1" using normalize_full_denormalize_eq by blast
   then show ?thesis by simp
 qed
 
 lemma normalize_full_normalize_dverts_eq_denormalize:
   assumes "wf_dlverts t1" and "max_deg t1 \<le> 1"
   shows "dverts (normalize_full (normalize t1)) = {denormalize t1}"
 proof -
   have "max_deg (normalize t1) \<le> 1" using assms normalize_mdeg_eq' by fastforce
   then show ?thesis
     using normalize_full_dverts_eq_denormalize normalize_denormalize_eq assms(1) by simp
 qed
 
 lemma normalize_full_normalize_dverts_eq_denormalize':
   assumes "wf_darcs t1" and "max_deg t1 \<le> 1"
   shows "dverts (normalize_full (normalize t1)) = {denormalize t1}"
 proof -
   have "max_deg (normalize t1) \<le> 1" using assms normalize_mdeg_eq by fastforce
   then show ?thesis
     using normalize_full_dverts_eq_denormalize normalize_denormalize_eq' assms(1) by simp
 qed
 
 lemma denormalize_full_forward:
   "\<lbrakk>max_deg t1 \<le> 1; dom_children t1 T; \<forall>v \<in> dverts t1. forward v; wf_dlverts t1\<rbrakk>
     \<Longrightarrow> forward (denormalize (normalize_full t1))"
   by (metis denormalize_empty_sucs_simp normalize_full_forward_singleton)
 
 lemma denormalize_forward:
   "\<lbrakk>max_deg t1 \<le> 1; dom_children t1 T; \<forall>v \<in> dverts t1. forward v; wf_dlverts t1\<rbrakk>
     \<Longrightarrow> forward (denormalize t1)"
   using denormalize_full_forward by simp
 
 lemma ikkbz_sub_forward_if_uneq: "ikkbz_sub t \<noteq> t \<Longrightarrow> forward (denormalize (ikkbz_sub t))"
   using denormalize_forward ikkbz_sub_mdeg_le1 dom_mdeg_le1_ikkbz_sub ikkbz_sub_wf_dlverts
     ranked_dtree_with_orig.verts_forward ikkbz_sub_ranked_dtree_orig
   by fast
 
 theorem ikkbz_sub_forward:
   "\<lbrakk>max_deg t \<le> 1 \<Longrightarrow> dom_children t T\<rbrakk> \<Longrightarrow> forward (denormalize (ikkbz_sub t))"
   using ikkbz_sub_forward_if_uneq ikkbz_sub_eq_iff_mdeg_le1[of t]
   by (fastforce simp: verts_forward wf_lverts denormalize_forward)
 
 lemma root_arc_singleton:
   assumes "dom_children (Node r {|(t1,e1)|}) T" and "wf_dlverts (Node r {|(t1,e1)|})"
   shows "\<exists>x\<in>set r. \<exists>y\<in>set (Dtree.root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   using root_arc_if_dom_wfdlverts assms by fastforce
 
 lemma before_if_dom_children_wf_conform:
   assumes "dom_children (Node r {|(t1,e1)|}) T"
       and "\<forall>v \<in> dverts (Node r {|(t1,e1)|}). seq_conform v"
       and "wf_dlverts (Node r {|(t1,e1)|})"
     shows "before r (Dtree.root t1)"
 proof -
   have "seq_conform (Dtree.root t1)" using  dtree.set_sel(1) assms(2) by auto
   moreover have "seq_conform r" using assms(2) by auto
   moreover have "set r \<inter> set (Dtree.root t1) = {}"
     using assms(3) dlverts_eq_dverts_union dtree.set_sel(1) by fastforce
   ultimately show ?thesis unfolding before_def using root_arc_singleton assms(1,3) by blast
 qed
 
 lemma root_arc_singleton':
   assumes "Node r {|(t1,e1)|} = t" and "dom_children t T"
   shows "\<exists>x\<in>set r. \<exists>y\<in>set (Dtree.root t1). x \<rightarrow>\<^bsub>T\<^esub> y"
   using assms root_arc_singleton wf_lverts by blast
 
 lemma root_before_if_dom:
   assumes "Node r {|(t1,e1)|} = t" and "dom_children t T"
   shows "before r (Dtree.root t1)"
 proof -
   have "(Dtree.root t1) \<in> dverts t" using dtree.set_sel(1) assms(1) by fastforce
   then have "seq_conform (Dtree.root t1)" using verts_conform by simp
   moreover have "seq_conform r" using verts_conform assms(1) by auto
   ultimately show ?thesis
     using before_def child_disjoint_root root_arc_singleton' assms by fastforce
 qed
 
 lemma combine_conform:
   "\<lbrakk>dom_children (Node r {|(t1,e1)|}) T; \<forall>v \<in> dverts (Node r {|(t1,e1)|}). seq_conform v;
     wf_dlverts (Node r {|(t1,e1)|}); v \<in> dverts (Node (r@Dtree.root t1) (sucs t1))\<rbrakk>
       \<Longrightarrow> seq_conform v"
   apply(cases "v = r@Dtree.root t1")
    using before_if_dom_children_wf_conform seq_conform_if_before apply fastforce
   using dverts_suc_subseteq by fastforce
 
 lemma denormalize_full_set_eq_dlverts:
   "max_deg t1 \<le> 1 \<Longrightarrow> set (denormalize (normalize_full t1)) = dlverts t1"
   using denormalize_set_eq_dlverts by auto
 
 lemma denormalize_full_set_eq_dverts_union:
   "max_deg t1 \<le> 1 \<Longrightarrow> set (denormalize (normalize_full t1)) = \<Union>(set ` dverts t1)"
   using denormalize_full_set_eq_dlverts dlverts_eq_dverts_union by fastforce
 
 corollary hd_eq_denormalize_full:
   "wf_dlverts t1 \<Longrightarrow> hd (denormalize (normalize_full t1)) = hd (Dtree.root t1)"
   using denormalize_hd_root_wf by auto
 
 corollary denormalize_full_nempty_if_wf:
   "wf_dlverts t1 \<Longrightarrow> denormalize (normalize_full t1) \<noteq> []"
   using denormalize_nempty_if_wf by auto
 
 lemma take1_eq_denormalize_full:
   "wf_dlverts t1 \<Longrightarrow> take 1 (denormalize (normalize_full t1)) = [hd (Dtree.root t1)]"
   using hd_eq_denormalize_full take1_eq_hd denormalize_full_nempty_if_wf by fast
 
 lemma P_denormalize_full:
   assumes "wf_dlverts t1"
       and "\<forall>v \<in> dverts t1. distinct v"
       and "hd (Dtree.root t1) = root"
       and "max_deg t1 \<le> 1"
     shows "unique_set_r root (dverts t1) (denormalize (normalize_full t1))"
   using assms unique_set_r_def denormalize_full_set_eq_dverts_union
     denormalize_distinct normalize_full_wfdlverts take1_eq_denormalize_full
   by fastforce
 
 lemma P_denormalize:
   fixes t1 :: "('a list,'b) dtree"
   assumes "wf_dlverts t1"
       and "\<forall>v \<in> dverts t1. distinct v"
       and "hd (Dtree.root t1) = root"
       and "max_deg t1 \<le> 1"
     shows "unique_set_r root (dverts t1) (denormalize t1)"
   using assms P_denormalize_full by auto
 
 lemma denormalize_full_fwd:
   assumes "wf_dlverts t1"
       and "max_deg t1 \<le> 1"
       and "\<forall>xs \<in> (dverts t1). seq_conform xs"
       and "dom_children t1 T"
     shows "forward (denormalize (normalize_full t1))"
   using assms denormalize_forward forward_arcs_alt seq_conform_def by auto
 
 lemma normalize_full_verts_sublist:
   "v \<in> dverts t1 \<Longrightarrow> \<exists>v2 \<in> dverts (normalize_full t1). sublist v v2"
 proof(induction t1 arbitrary: v rule: normalize_full.induct)
   case ind: (1 r t e)
   then consider "v = r \<or> v = Dtree.root t" | "\<exists>t1 \<in> fst ` fset (sucs t). v \<in> dverts t1"
     using dverts_root_or_suc by fastforce
   then show ?case
   proof(cases)
     case 1
     have "\<exists>a\<in>dverts (normalize_full (Node (r @ Dtree.root t) (sucs t))). sublist (r@Dtree.root t) a"
       using ind.IH by simp
     moreover have "sublist v (r@Dtree.root t)" using 1 by blast
     ultimately show ?thesis using sublist_order.dual_order.trans by auto
   next
     case 2
     then show ?thesis using ind.IH[of v] by fastforce
   qed
 next
   case (2 xs r)
   then show ?case by fastforce
 qed
 
 lemma normalize_full_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t1\<rbrakk> \<Longrightarrow> \<exists>v2 \<in> dverts (normalize_full t1). sublist xs v2"
   using normalize_full_verts_sublist sublist_order.dual_order.trans by fast
 
 lemma denormalize_full_sublist_preserv:
   assumes "sublist xs v" and "v \<in> dverts t1" and "max_deg t1 \<le> 1"
   shows "sublist xs (denormalize (normalize_full t1))"
 proof -
   obtain r where r_def[simp]: "normalize_full t1 = Node r {||}"
     using assms(3) normalize_full_empty_sucs by blast
   have "sublist xs r" using normalize_full_sublist_preserv[OF assms(1,2)] by simp
   then show ?thesis by (simp add: denormalize_empty_sucs_simp)
 qed
 
 corollary denormalize_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts (t1::('a list,'b) dtree); max_deg t1 \<le> 1\<rbrakk>
     \<Longrightarrow> sublist xs (denormalize t1)"
   using denormalize_full_sublist_preserv by simp
 
 lemma Q_denormalize_full:
   assumes "wf_dlverts t1"
       and "\<forall>v \<in> dverts t1. distinct v"
       and "hd (Dtree.root t1) = root"
       and "max_deg t1 \<le> 1"
       and "\<forall>xs \<in> (dverts t1). seq_conform xs"
       and "dom_children t1 T"
     shows "fwd_sub root (dverts t1) (denormalize (normalize_full t1))"
   using P_denormalize_full[OF assms(1-4)] assms(1,4-6) denormalize_full_sublist_preserv
   by (auto dest: denormalize_full_fwd simp: fwd_sub_def)
 
 corollary Q_denormalize:
   assumes "wf_dlverts t1"
       and "\<forall>v \<in> dverts t1. distinct v"
       and "hd (Dtree.root t1) = root"
       and "max_deg t1 \<le> 1"
       and "\<forall>xs \<in> (dverts t1). seq_conform xs"
       and "dom_children t1 T"
     shows "fwd_sub root (dverts t1) (denormalize t1)"
   using Q_denormalize_full assms by simp
 
 corollary Q_denormalize_t:
   assumes "hd (Dtree.root t) = root"
       and "max_deg t \<le> 1"
       and "dom_children t T"
     shows "fwd_sub root (dverts t) (denormalize t)"
   using Q_denormalize wf_lverts assms verts_conform verts_distinct by blast
 
 lemma P_denormalize_ikkbz_sub:
   assumes "hd (Dtree.root t) = root"
   shows "unique_set_r root (dverts t) (denormalize (ikkbz_sub t))"
 proof -
   interpret T: ranked_dtree_with_orig "ikkbz_sub t" using ikkbz_sub_ranked_dtree_orig by auto
   have "\<forall>v\<in>dverts (ikkbz_sub t). distinct v" using T.verts_distinct by simp
   then show ?thesis
     using P_denormalize T.wf_lverts ikkbz_sub_mdeg_le1 assms ikkbz_sub_hd_root
     unfolding unique_set_r_def denormalize_ikkbz_eq_dlverts dlverts_eq_dverts_union
     by blast
 qed
 
 lemma merge1_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t\<rbrakk> \<Longrightarrow> \<exists>v2 \<in> dverts (merge1 t). sublist xs v2"
   using sublist_order.dual_order.trans by auto
 
 lemma normalize1_verts_sublist: "v \<in> dverts t1 \<Longrightarrow> \<exists>v2 \<in> dverts (normalize1 t1). sublist v v2"
 proof(induction t1 arbitrary: v rule: normalize1.induct)
   case ind: (1 r t e)
   show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     consider "v = r \<or> v = Dtree.root t" | "\<exists>t1 \<in> fst ` fset (sucs t). v \<in> dverts t1"
       using dverts_root_or_suc using ind.prems by fastforce
     then show ?thesis
     proof(cases)
       case 1
       then show ?thesis using True by auto
     next
       case 2
       then show ?thesis using True by fastforce
     qed
   next
     case False
     then show ?thesis using ind by auto
   qed
 next
   case (2 xs r)
   then show ?case by fastforce
 qed
 
 lemma normalize1_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t1\<rbrakk> \<Longrightarrow> \<exists>v2 \<in> dverts (normalize1 t1). sublist xs v2"
   using normalize1_verts_sublist sublist_order.dual_order.trans by fast
 
 lemma normalize_verts_sublist: "v \<in> dverts t1 \<Longrightarrow> \<exists>v2 \<in> dverts (normalize t1). sublist v v2"
 proof(induction t1 arbitrary: v rule: normalize.induct)
   case (1 t1)
   then show ?case
   proof(cases "t1 = normalize1 t1")
     case True
     then show ?thesis using "1.prems" by auto
   next
     case False
     then have eq: "normalize (normalize1 t1) = normalize t1" by (auto simp: Let_def)
     then obtain v2 where v2_def: "v2 \<in> dverts (normalize1 t1)" "sublist v v2"
       using normalize1_verts_sublist "1.prems" by blast
     then show ?thesis
       using "1.IH"[OF refl False v2_def(1)] eq sublist_order.dual_order.trans by auto
   qed
 qed
 
 lemma normalize_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t1\<rbrakk> \<Longrightarrow> \<exists>v2 \<in> dverts (normalize t1). sublist xs v2"
   using normalize_verts_sublist sublist_order.dual_order.trans by fast
 
 lemma ikkbz_sub_verts_sublist: "v \<in> dverts t \<Longrightarrow> \<exists>v2 \<in> dverts (ikkbz_sub t). sublist v v2"
 using ranked_dtree_with_orig_axioms proof(induction t arbitrary: v rule: ikkbz_sub.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by simp
   interpret NT: ranked_dtree_with_orig "normalize t"
     using T.ranked_dtree_orig_normalize by blast
   show ?case
   proof(cases "max_deg t \<le> 1")
     case True
     then show ?thesis using "1.prems"(1) by auto
   next
     case False
     then have 0: "\<not> (max_deg t \<le> 1 \<or> \<not> list_dtree t)" using T.list_dtree_axioms by auto
     obtain v1 where v1_def: "v1 \<in> dverts (normalize t)" "sublist v v1"
       using normalize_verts_sublist "1.prems"(1) by blast
     then have "v1 \<in> dverts (merge1 (normalize t))" using NT.merge1_dverts_eq by blast
     then obtain v2 where v2_def: "v2 \<in> dverts (ikkbz_sub t)" "sublist v1 v2"
       using 1 0 T.merge1_normalize_ranked_dtree_orig by force
     then show ?thesis using v1_def(2) sublist_order.dual_order.trans by blast
   qed
 qed
 
 lemma ikkbz_sub_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t\<rbrakk> \<Longrightarrow> \<exists>v2 \<in> dverts (ikkbz_sub t). sublist xs v2"
   using ikkbz_sub_verts_sublist sublist_order.dual_order.trans by fast
 
 lemma denormalize_ikkbz_sub_verts_sublist:
   "\<forall>xs \<in> (dverts t). sublist xs (denormalize (ikkbz_sub t))"
   using ikkbz_sub_verts_sublist denormalize_sublist_preserv ikkbz_sub_mdeg_le1 by blast
 
 lemma denormalize_ikkbz_sub_sublist_preserv:
   "\<lbrakk>sublist xs v; v \<in> dverts t\<rbrakk> \<Longrightarrow> sublist xs (denormalize (ikkbz_sub t))"
   using denormalize_ikkbz_sub_verts_sublist sublist_order.dual_order.trans by blast
 
 lemma Q_denormalize_ikkbz_sub:
   "\<lbrakk>hd (Dtree.root t) = root; max_deg t \<le> 1 \<Longrightarrow> dom_children t T\<rbrakk>
     \<Longrightarrow> fwd_sub root (dverts t) (denormalize (ikkbz_sub t))"
   using P_denormalize_ikkbz_sub ikkbz_sub_forward denormalize_ikkbz_sub_verts_sublist fwd_sub_def
   by blast
 
 subsubsection \<open>Minimal Cost of the result\<close>
 
 lemma normalize1_dverts_app_before_contr:
   "\<lbrakk>v \<in> dverts (normalize1 t); v \<notin> dverts t\<rbrakk>
     \<Longrightarrow> \<exists>v1\<in>dverts t. \<exists>v2\<in>dverts t. v1 @ v2 = v \<and> before v1 v2 \<and> rank (rev v2) < rank (rev v1)"
   by (fastforce dest: normalize1_dverts_contr_subtree
       simp: single_subtree_root_dverts single_subtree_child_root_dverts contr_before)
 
 lemma normalize1_dverts_app_bfr_cntr_rnks:
   assumes "v \<in> dverts (normalize1 t)" and "v \<notin> dverts t"
   shows "\<exists>U\<in>dverts t. \<exists>V\<in>dverts t. U @ V = v \<and> before U V \<and> rank (rev V) < rank (rev U)
       \<and> (\<forall>xs \<in> dverts t. (\<exists>y\<in>set xs. \<not> (\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<noteq> U)
         \<longrightarrow> rank (rev V) \<le> rank (rev xs))"
   using normalize1_dverts_contr_subtree[OF assms] subtree_rank_ge_if_reach'
   by (fastforce simp: single_subtree_root_dverts single_subtree_child_root_dverts contr_before)
 
 lemma normalize1_dverts_app_bfr_cntr_rnks':
   assumes "v \<in> dverts (normalize1 t)" and "v \<notin> dverts t"
   shows "\<exists>U\<in>dverts t. \<exists>V\<in>dverts t. U @ V = v \<and> before U V \<and> rank (rev V) \<le> rank (rev U)
       \<and> (\<forall>xs \<in> dverts t. (\<exists>y\<in>set xs. \<not> (\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<noteq> U)
         \<longrightarrow> rank (rev V) \<le> rank (rev xs))"
   using normalize1_dverts_contr_subtree[OF assms] subtree_rank_ge_if_reach'
   by (fastforce simp: single_subtree_root_dverts single_subtree_child_root_dverts contr_before)
 
 lemma normalize1_dverts_split:
   "dverts (normalize1 t1)
   = {v \<in> dverts (normalize1 t1). v \<notin> dverts t1} \<union> {v \<in> dverts (normalize1 t1). v \<in> dverts t1}"
   by blast
 
 lemma normalize1_dlverts_split:
   "dlverts (normalize1 t1)
   = \<Union>(set ` {v \<in> dverts (normalize1 t1). v \<notin> dverts t1})
     \<union> \<Union>(set ` {v \<in> dverts (normalize1 t1). v \<in> dverts t1})"
   using dlverts_eq_dverts_union by fastforce
 
 lemma normalize1_dsjnt_in_dverts:
   assumes "wf_dlverts t1"
       and "v \<in> dverts t1"
       and "set v \<inter> \<Union>(set ` {v \<in> dverts (normalize1 t1). v \<notin> dverts t1}) = {}"
     shows "v \<in> dverts (normalize1 t1)"
 proof -
   have "set v \<subseteq> dlverts (normalize1 t1)" using assms(2) lverts_if_in_verts by fastforce
   then have sub: "set v \<subseteq> \<Union>(set ` {v \<in> dverts (normalize1 t1). v \<in> dverts t1})"
     using normalize1_dlverts_split assms(3) by auto
   have "v \<noteq> []" using assms(1,2) empty_notin_wf_dlverts by auto
   then obtain x where x_def: "x \<in> set v" by fastforce
   then show ?thesis using dverts_same_if_set_wf[OF assms(1,2)] x_def sub by blast
 qed
 
 lemma normalize1_dsjnt_subset_split1:
   fixes t1
   defines "X \<equiv> {v \<in> dverts (normalize1 t1). v \<notin> dverts t1}"
   assumes "wf_dlverts t1"
   shows "{x. x\<in>dverts t1 \<and> set x \<inter> \<Union>(set ` X) = {}} \<subseteq> {v \<in> dverts (normalize1 t1). v \<in> dverts t1}"
   using assms normalize1_dsjnt_in_dverts by blast
 
 lemma normalize1_dsjnt_subset_split2:
   fixes t1
   defines "X \<equiv> {v \<in> dverts (normalize1 t1). v \<notin> dverts t1}"
   assumes "wf_dlverts t1"
   shows "{v \<in> dverts (normalize1 t1). v \<in> dverts t1} \<subseteq> {x. x\<in>dverts t1 \<and> set x \<inter> \<Union>(set ` X) = {}}"
   using dverts_same_if_set_wf[OF wf_dlverts_normalize1] assms by blast
 
 lemma normalize1_dsjnt_subset_eq_split:
   fixes t1
   defines "X \<equiv> {v \<in> dverts (normalize1 t1). v \<notin> dverts t1}"
   assumes "wf_dlverts t1"
   shows "{v \<in> dverts (normalize1 t1). v \<in> dverts t1} = {x. x\<in>dverts t1 \<and> set x \<inter> \<Union>(set ` X) = {}}"
   using normalize1_dsjnt_subset_split1 normalize1_dsjnt_subset_split2 assms
   by blast
 
 lemma normalize1_dverts_split2:
   fixes t1
   defines "X \<equiv> {v \<in> dverts (normalize1 t1). v \<notin> dverts t1}"
   assumes "wf_dlverts t1"
   shows "X \<union> {x. x \<in> dverts t1 \<and> set x \<inter> \<Union>(set ` X) = {}} = dverts (normalize1 t1)"
   unfolding assms(1) using normalize1_dsjnt_subset_eq_split[OF assms(2)] by blast
 
 lemma set_subset_if_normalize1_vert: "v1 \<in> dverts (normalize1 t1) \<Longrightarrow> set v1 \<subseteq> dlverts t1"
   using lverts_if_in_verts by fastforce
 
 lemma normalize1_new_verts_not_reach1:
   assumes "v1 \<in> dverts (normalize1 t)" and "v1 \<notin> dverts t"
       and "v2 \<in> dverts (normalize1 t)" and "v2 \<notin> dverts t"
       and "v1 \<noteq> v2"
   shows "\<not>(\<exists>x\<in>set v1. \<exists>y\<in>set v2. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
 using assms ranked_dtree_with_orig_axioms proof(induction t rule: normalize1.induct)
   case (1 r t e)
   then interpret R: ranked_dtree_with_orig "Node r {|(t, e)|}" by blast
   show ?case
   proof(cases "rank (rev (Dtree.root t)) < rank (rev r)")
     case True
     then have eq: "normalize1 (Node r {|(t, e)|}) = Node (r@Dtree.root t) (sucs t)" by simp
     have "v1 = r @ Dtree.root t"
       using "1.prems"(1,2) dverts_suc_subseteq unfolding eq by fastforce
     moreover have "v2 = r @ Dtree.root t"
       using "1.prems"(3,4) dverts_suc_subseteq unfolding eq by fastforce
     ultimately show ?thesis using "1.prems"(5) by simp
   next
     case False
     then show ?thesis using 1 R.ranked_dtree_orig_rec by simp
   qed
 next
   case (2 xs r)
   then interpret R: ranked_dtree_with_orig "Node r xs" by blast
   have eq: "normalize1 (Node r xs) = Node r ((\<lambda>(t,e). (normalize1 t,e)) |`| xs)"
     using "2.hyps" by simp
   obtain t1 e1 where t1_def: "(t1,e1) \<in> fset xs" "v1 \<in> dverts (normalize1 t1)"
     using "2.hyps" "2.prems"(1,2) by auto
   obtain t2 e2 where t2_def: "(t2,e2) \<in> fset xs" "v2 \<in> dverts (normalize1 t2)"
     using "2.hyps" "2.prems"(3,4) by auto
   show ?case
   proof(cases "t1 = t2")
     case True
     have "v1 \<notin> dverts t1 \<and> v2 \<notin> dverts t2"
       using "2.hyps" "2.prems"(2,4) t1_def(1) t2_def(1) by simp
     then show ?thesis using "2.IH" t1_def t2_def True "2.prems"(5) R.ranked_dtree_orig_rec by simp
   next
     case False
     have sub: "is_subtree t1 (Node r xs)" using t1_def(1) subtree_if_child[of t1 xs r] by force
     have "set v1 \<subseteq> dlverts t1" using set_subset_if_normalize1_vert t1_def(2) by simp
     then have reach_t1: "\<forall>x \<in> set v1. \<forall>y. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y \<longrightarrow> y \<in> dlverts t1"
       using R.dlverts_reach1_in_dlverts sub by blast
     have "dlverts t1 \<inter> dlverts t2 = {}"
       using R.wf_lverts t2_def(1) t1_def(1) wf_dlverts.simps[of r] False by fast
     then have "set v2 \<inter> dlverts t1 = {}" using set_subset_if_normalize1_vert t2_def(2) by auto
     then show ?thesis using reach_t1 by blast
   qed
 qed
 
 lemma normalize1_dverts_split_optimal:
   defines "X \<equiv> {v \<in> dverts (normalize1 t). v \<notin> dverts t}"
   assumes "\<exists>x. fwd_sub root (dverts t) x"
   shows "\<exists>zs. fwd_sub root (X \<union> {x. x \<in> dverts t \<and> set x \<inter> \<Union>(set ` X) = {}}) zs
           \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 proof -
   let ?Y = "dverts t"
   have dsjt: "\<forall>xs \<in> ?Y. \<forall>ys \<in> ?Y. xs = ys \<or> set xs \<inter> set ys = {}"
     using dverts_same_if_set_wf[OF wf_lverts] by blast
   have fwd: "\<forall>xs \<in> ?Y. forward xs" by (simp add: verts_forward)
   have nempty: "[] \<notin> ?Y" by (simp add: empty_notin_wf_dlverts wf_lverts)
   have fin: "finite ?Y" by (simp add: finite_dverts)
   have "\<forall>ys \<in> X. \<exists>U \<in> ?Y. \<exists>V \<in> ?Y. U@V = ys \<and> before U V \<and> rank (rev V) \<le> rank (rev U)
         \<and> (\<forall>xs \<in> ?Y. (\<exists>y\<in>set xs. \<not>(\<exists>x'\<in>set V. x' \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> (\<exists>x\<in>set U. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y) \<and> xs \<noteq> U)
           \<longrightarrow> rank (rev V) \<le> rank (rev xs))"
     unfolding X_def using normalize1_dverts_app_bfr_cntr_rnks' by blast
   moreover have "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> set xs \<inter> set ys = {}"
     unfolding X_def using dverts_same_if_set_wf[OF wf_dlverts_normalize1] wf_lverts by blast
   moreover have "\<forall>xs \<in> X. \<forall>ys \<in> X. xs = ys \<or> \<not>(\<exists>x\<in>set xs. \<exists>y\<in>set ys. x \<rightarrow>\<^sup>+\<^bsub>T\<^esub> y)"
     unfolding X_def using normalize1_new_verts_not_reach1 by blast
   moreover have "finite X" by (simp add: X_def finite_dverts)
   ultimately show ?thesis
     using combine_union_sets_optimal_cost[OF asi_rank dsjt fwd nempty fin assms(2)] by simp
 qed
 
 corollary normalize1_dverts_optimal:
   assumes "\<exists>x. fwd_sub root (dverts t) x"
   shows "\<exists>zs. fwd_sub root (dverts (normalize1 t)) zs
         \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
   using normalize1_dverts_split_optimal assms normalize1_dverts_split2[OF wf_lverts] by simp
 
 lemma normalize_dverts_optimal:
   assumes "\<exists>x. fwd_sub root (dverts t) x"
   shows "\<exists>zs. fwd_sub root (dverts (normalize t)) zs
         \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 using assms ranked_dtree_with_orig_axioms proof(induction t rule: normalize.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by blast
   obtain zs where zs_def:
       "fwd_sub root (dverts (normalize1 t)) zs"
       "\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as)"
     using "1.prems" T.normalize1_dverts_optimal by auto
   show ?case
   proof(cases "t = normalize1 t")
     case True
     then show ?thesis using zs_def by auto
   next
     case False
     then have eq: "normalize (normalize1 t) = normalize t" by (auto simp: Let_def)
     have "\<exists>zs. fwd_sub root (dverts (normalize (normalize1 t))) zs
           \<and> (\<forall>as. fwd_sub root (dverts (normalize1 t)) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
       using "1.IH" False zs_def(1) T.ranked_dtree_orig_normalize1 by blast
     then show ?thesis using zs_def eq by force
   qed
 qed
 
 lemma merge1_dverts_optimal:
   assumes "\<exists>x. fwd_sub root (dverts t) x"
   shows "\<exists>zs. fwd_sub root (dverts (merge1 t)) zs
         \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
   using assms forward_UV_lists_argmin_ex by simp
 
 theorem ikkbz_sub_dverts_optimal:
   assumes "\<exists>x. fwd_sub root (dverts t) x"
   shows "\<exists>zs. fwd_sub root (dverts (ikkbz_sub t)) zs
         \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 using assms ranked_dtree_with_orig_axioms proof(induction t rule: ikkbz_sub.induct)
   case (1 t)
   then interpret T: ranked_dtree_with_orig t by simp
   interpret NT: ranked_dtree_with_orig "normalize t"
     using T.ranked_dtree_orig_normalize by blast
   show ?case
   proof(cases "max_deg t \<le> 1")
     case True
     then show ?thesis using "1.prems"(1) forward_UV_lists_argmin_ex by auto
   next
     case False
     then have 0: "\<not> (max_deg t \<le> 1 \<or> \<not> list_dtree t)" using T.list_dtree_axioms by auto
     obtain zs where zs_def: "fwd_sub root (dverts (merge1 (normalize t))) zs"
         "\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as)"
       using "1.prems" T.normalize_dverts_optimal NT.merge1_dverts_eq by auto
     have "\<exists>zs. fwd_sub root (dverts (ikkbz_sub (merge1 (normalize t)))) zs
           \<and> (\<forall>as. fwd_sub root (dverts (merge1 (normalize t))) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
       using "1.IH" 0 zs_def(1) T.merge1_normalize_ranked_dtree_orig by blast
     then show ?thesis using zs_def 0 by force
   qed
 qed
 
 lemma ikkbz_sub_dverts_optimal':
   assumes "hd (Dtree.root t) = root" and "max_deg t \<le> 1 \<Longrightarrow> dom_children t T"
   shows "\<exists>zs. fwd_sub root (dverts (ikkbz_sub t)) zs
         \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
   using ikkbz_sub_dverts_optimal Q_denormalize_ikkbz_sub assms by blast
 
 lemma combine_strict_subtree_orig:
   assumes "strict_subtree (Node r1 {|(t2,e2)|}) (Node (r@Dtree.root t1) (sucs t1))"
     shows "is_subtree (Node r1 {|(t2,e2)|}) (Node r {|(t1,e1)|})"
 proof -
   obtain t3 where t3_def: "t3 \<in> fst ` fset (sucs t1)" "is_subtree (Node r1 {|(t2,e2)|}) t3"
     using assms unfolding strict_subtree_def by force
   then show ?thesis using subtree_trans subtree_if_suc[OF t3_def(1)] by auto
 qed
 
 lemma combine_subtree_orig_uneq:
   assumes "is_subtree (Node r1 {|(t2,e2)|}) (Node (r@Dtree.root t1) (sucs t1))"
   shows "Node r1 {|(t2,e2)|} \<noteq> Node r {|(t1,e1)|}"
 proof -
   have "size (Node r1 {|(t2,e2)|}) \<le> size (Node (r@Dtree.root t1) (sucs t1))"
     using assms(1) subtree_size_le by blast
   also have "size (Node (r@Dtree.root t1) (sucs t1)) < size (Node r {|(t1,e1)|})"
     using dtree_size_skip_decr1 by fast
   finally show ?thesis by blast
 qed
 
 lemma combine_strict_subtree_ranks_le:
   assumes "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) (Node r {|(t1,e1)|})
               \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "strict_subtree (Node r1 {|(t2,e2)|}) (Node (r@Dtree.root t1) (sucs t1))"
     shows "rank (rev r1) \<le> rank (rev (Dtree.root t2))"
   using combine_strict_subtree_orig assms unfolding strict_subtree_def
   by (fast intro!: combine_subtree_orig_uneq )
 
 lemma subtree_child_uneq:
   "\<lbrakk>is_subtree t1 t2; t2 \<in> fst ` fset xs\<rbrakk> \<Longrightarrow> t1 \<noteq> Node r xs"
   using child_uneq subtree_antisym subtree_if_child by fast
 
 lemma subtree_singleton_child_uneq:
   "is_subtree t1 t2 \<Longrightarrow> t1 \<noteq> Node r {|(t2,e2)|}"
   using subtree_child_uneq[of t1] by simp
 
 lemma child_subtree_ranks_le_if_strict_subtree:
   assumes "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) (Node r {|(t1,e1)|})
               \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "is_subtree (Node r1 {|(t2,e2)|}) t1"
     shows "rank (rev r1) \<le> rank (rev (Dtree.root t2))"
   using assms subtree_trans subtree_singleton_child_uneq unfolding strict_subtree_def by fastforce
 
 lemma verts_ge_child_if_sorted:
   assumes "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) (Node r {|(t1,e1)|})
               \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "max_deg (Node r {|(t1,e1)|}) \<le> 1"
       and "v \<in> dverts t1"
     shows "rank (rev (Dtree.root t1)) \<le> rank (rev v)"
 proof -
   have "\<And>r1 t2 e2. is_subtree (Node r1 {|(t2,e2)|}) t1 \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
     using child_subtree_ranks_le_if_strict_subtree[OF assms(1)] by simp
   moreover have "max_deg t1 \<le> 1" using mdeg_ge_child[of t1 e1 "{|(t1,e1)|}"] assms(2) by simp
   ultimately show ?thesis using rank_ge_if_mdeg_le1_dvert_nocontr assms(3) by fastforce
 qed
 
 lemma verts_ge_child_if_sorted':
   assumes "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) (Node r {|(t1,e1)|})
               \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "max_deg (Node r {|(t1,e1)|}) \<le> 1"
       and "v \<in> dverts (Node r {|(t1,e1)|})"
       and "v \<noteq> r"
     shows "rank (rev (Dtree.root t1)) \<le> rank (rev v)"
   using verts_ge_child_if_sorted[OF assms(1,2)] assms(3,4) by simp
 
 lemma not_combined_sub_dverts_combine:
   "{r@Dtree.root t1} \<union> {x. x \<in> dverts (Node r {|(t1,e1)|}) \<and> x \<noteq> r \<and> x \<noteq> Dtree.root t1}
         \<subseteq> dverts (Node (r @ Dtree.root t1) (sucs t1))"
   using dverts_suc_subseteq dverts_root_or_suc by fastforce
 
 lemma dverts_combine_orig_not_combined:
   assumes "wf_dlverts (Node r {|(t1,e1)|})" and "x \<in> dverts (Node (r @ Dtree.root t1) (sucs t1))" and "x \<noteq> r@Dtree.root t1"
   shows "x \<in> dverts (Node r {|(t1,e1)|}) \<and> x \<noteq> r \<and> x \<noteq> Dtree.root t1"
 proof -
   obtain t2 where t2_def: "t2 \<in> fst ` fset (sucs t1)" "x \<in> dverts t2" using assms(2,3) by fastforce
   have "set r \<inter> dlverts t2 = {}" using assms(1) suc_in_dlverts'[OF t2_def(1)] by auto
   then have "x \<noteq> r" using assms(1) t2_def(2) nempty_inter_notin_dverts by auto
   have "Dtree.root t1 \<noteq> []"
     using assms(1) empty_notin_wf_dlverts single_subtree_child_root_dverts[OF self_subtree, of t1]
     by force
   moreover have "set (Dtree.root t1) \<inter> dlverts t2 = {}"
     using assms(1) t2_def(1) notin_dlverts_suc_if_wf_in_root by fastforce
   ultimately have "x \<noteq> Dtree.root t1" using nempty_inter_notin_dverts t2_def(2) by blast
   then show ?thesis using \<open>x \<noteq> r\<close> t2_def dverts_suc_subseteq by auto
 qed
 
 lemma dverts_combine_sub_not_combined:
   "wf_dlverts (Node r {|(t1,e1)|}) \<Longrightarrow> dverts (Node (r @ Dtree.root t1) (sucs t1))
   \<subseteq> {r@Dtree.root t1} \<union> {x. x \<in> dverts (Node r {|(t1,e1)|}) \<and> x \<noteq> r \<and> x \<noteq> Dtree.root t1}"
   using dverts_combine_orig_not_combined by fast
 
 lemma dverts_combine_eq_not_combined:
   "wf_dlverts (Node r {|(t1,e1)|}) \<Longrightarrow> dverts (Node (r @ Dtree.root t1) (sucs t1))
   = {r@Dtree.root t1} \<union> {x. x \<in> dverts (Node r {|(t1,e1)|}) \<and> x \<noteq> r \<and> x \<noteq> Dtree.root t1}"
   using dverts_combine_sub_not_combined not_combined_sub_dverts_combine by fast
 
 lemma normalize_full_dverts_optimal_if_sorted:
   assumes "asi rank root cost"
       and "wf_dlverts t1"
       and "\<forall>xs \<in> (dverts t1). distinct xs"
       and "\<forall>xs \<in> (dverts t1). seq_conform xs"
       and "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) t1
             \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       and "max_deg t1 \<le> 1"
       and "hd (Dtree.root t1) = root"
       and "dom_children t1 T"
     shows "\<exists>zs. fwd_sub root (dverts (normalize_full t1)) zs
           \<and> (\<forall>as. fwd_sub root (dverts t1) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 using assms proof(induction t1 rule: normalize_full.induct)
   case (1 r t e)
   let ?Y = "dverts (Node r {|(t,e)|})"
   have dsjt: "\<forall>xs \<in> ?Y. \<forall>ys \<in> ?Y. xs = ys \<or> set xs \<inter> set ys = {}"
     using dverts_same_if_set_wf[OF "1.prems"(2)] by blast
   have fwd: "\<forall>xs \<in> ?Y. forward xs" using "1.prems"(4) seq_conform_alt by blast
   have nempty: "[] \<notin> ?Y" using empty_notin_wf_dlverts "1.prems"(2) by blast
   have fin: "finite ?Y" by (simp add: finite_dverts)
   have U: "r \<in> dverts (Node r {|(t, e)|})" by simp
   have V: "Dtree.root t \<in> dverts (Node r {|(t, e)|})"
     using single_subtree_child_root_dverts self_subtree by fast
   have ge: "\<forall>xs\<in>dverts (Node r {|(t, e)|}). xs \<noteq> r \<longrightarrow> rank (rev (Dtree.root t)) \<le> rank (rev xs)"
     using verts_ge_child_if_sorted'[OF "1.prems"(5,6)] by fast
   moreover have bfr: "before r (Dtree.root t)"
     using before_if_dom_children_wf_conform[OF "1.prems"(8,4,2)].
   moreover have Ex: "\<exists>x. fwd_sub root ?Y x" using Q_denormalize_full "1.prems"(1-8) by blast
   ultimately obtain zs where zs_def:
       "fwd_sub root ({r@Dtree.root t} \<union> {x. x \<in> ?Y \<and> x \<noteq> r \<and> x \<noteq> Dtree.root t}) zs"
       "(\<forall>as. fwd_sub root ?Y as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using app_UV_set_optimal_cost[OF "1.prems"(1) dsjt fwd nempty fin U V] by blast
   have wf: "wf_dlverts (Node (r @ Dtree.root t) (sucs t))" using "1.prems"(2) combine_wf_dlverts by fast
   moreover have dst: "\<forall>v\<in>dverts (Node (r @ Dtree.root t) (sucs t)). distinct v"
     using "1.prems"(2,3) combine_distinct by fast
   moreover have seq: "\<forall>v\<in>dverts (Node (r @ Dtree.root t) (sucs t)). seq_conform v"
       using "1.prems"(2,4,8) combine_conform by blast
   moreover have rnk: "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) (Node (r @ Dtree.root t) (sucs t))
                   \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
       using combine_strict_subtree_ranks_le[OF "1.prems"(5)] by simp
   moreover have mdeg: "max_deg (Node (r @ Dtree.root t) (sucs t)) \<le> 1"
     using "1.prems"(6) mdeg_child_sucs_le
     by (fastforce dest: order_trans simp del: max_deg.simps)
   moreover have hd: "hd (Dtree.root (Node (r @ Dtree.root t) (sucs t))) = root"
       using "1.prems"(2,7) by simp
   moreover have dom: "dom_children (Node (r @ Dtree.root t) (sucs t)) T"
       using "1.prems"(8) dom_children_combine by auto
     ultimately obtain xs where xs_def:
       "fwd_sub root (dverts (normalize_full (Node (r @ Dtree.root t) (sucs t)))) xs"
       "(\<forall>as. fwd_sub root (dverts (Node (r @ Dtree.root t) (sucs t))) as
           \<longrightarrow> cost (rev xs) \<le> cost (rev as))"
     using "1.IH" "1.prems"(1) by blast
   then show ?case using dverts_combine_eq_not_combined[OF "1.prems"(2)] zs_def by force
 next
   case (2 xs r)
   have Ex: "\<exists>x. fwd_sub root (dverts (Node r xs)) x"
     using Q_denormalize_full "2.prems"(1-8) by blast
   then show ?case using "2.hyps"(1) forward_UV_lists_argmin_ex by simp
 qed
 
 corollary normalize_full_dverts_optimal_if_sorted':
   assumes "max_deg t \<le> 1"
       and "hd (Dtree.root t) = root"
       and "dom_children t T"
       and "\<And>r1 t2 e2. strict_subtree (Node r1 {|(t2,e2)|}) t
             \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
     shows "\<exists>zs. fwd_sub root (dverts (normalize_full t)) zs
           \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
   using normalize_full_dverts_optimal_if_sorted asi_rank wf_lverts assms
   by (blast intro: verts_distinct verts_conform)
 
 lemma normalize_full_normalize_dverts_optimal:
   assumes "max_deg t \<le> 1"
       and "hd (Dtree.root t) = root"
       and "dom_children t T"
     shows "\<exists>zs. fwd_sub root (dverts (normalize_full (normalize t))) zs
           \<and> (\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
 proof -
   interpret NT: ranked_dtree_with_orig "normalize t"
     using ranked_dtree_orig_normalize by auto
   have mdeg: "max_deg (normalize t) \<le> 1" using assms(1) normalize_mdeg_eq wf_arcs by fastforce
   moreover from this have dom: "dom_children (normalize t) T"
     using assms(3) dom_mdeg_le1_normalize by fastforce
   moreover have hd: "hd (Dtree.root (normalize t)) = root"
     using assms(2) normalize_hd_root_eq' wf_lverts by blast
   moreover have "\<And>r1 t2 e2. \<lbrakk>is_subtree (Node r1 {|(t2,e2)|}) (normalize t)\<rbrakk>
           \<Longrightarrow> rank (rev r1) \<le> rank (rev (Dtree.root t2))"
     by (simp add: normalize_sorted_ranks)
   ultimately obtain xs where xs_def: "fwd_sub root (dverts (normalize_full (normalize t))) xs"
       "(\<forall>as. fwd_sub root (dverts (normalize t)) as \<longrightarrow> cost (rev xs) \<le> cost (rev as))"
     using NT.normalize_full_dverts_optimal_if_sorted' strict_subtree_def by blast
   obtain zs where zs_def: "fwd_sub root (dverts (normalize t)) zs"
       "(\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using normalize_dverts_optimal Q_denormalize_t assms by blast
   then show ?thesis using xs_def by force
 qed
 
 lemma single_set_distinct_sublist: "\<lbrakk>set ys = set x; distinct ys; sublist x ys\<rbrakk> \<Longrightarrow> x = ys"
   unfolding sublist_def
   by (metis DiffD2 append.assoc append.left_neutral append.right_neutral list.set_intros(1)
       append_Cons distinct_set_diff neq_Nil_conv distinct_app_trans_l)
 
 lemma denormalize_optimal_if_mdeg_le1:
   assumes "max_deg t \<le> 1" and "hd (Dtree.root t) = root" and "dom_children t T"
   shows "\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev (denormalize t)) \<le> cost (rev as)"
 proof -
   obtain zs where zs_def: "fwd_sub root (dverts (normalize_full (normalize t))) zs"
       "(\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as))"
     using normalize_full_normalize_dverts_optimal assms by blast
   have "dverts (normalize_full (normalize t)) = {denormalize t}"
     using normalize_full_normalize_dverts_eq_denormalize wf_lverts assms(1) by blast
   then show ?thesis
     using zs_def single_set_distinct_sublist by (auto simp: fwd_sub_def unique_set_r_def)
 qed
 
 theorem denormalize_ikkbz_sub_optimal:
   assumes "hd (Dtree.root t) = root" and "max_deg t \<le> 1 \<Longrightarrow> dom_children t T"
   shows "(\<forall>as. fwd_sub root (dverts t) as
           \<longrightarrow> cost (rev (denormalize (ikkbz_sub t))) \<le> cost (rev as))"
 proof -
   obtain zs where zs_def: "fwd_sub root (dverts (ikkbz_sub t)) zs"
       "\<forall>as. fwd_sub root (dverts t) as \<longrightarrow> cost (rev zs) \<le> cost (rev as)"
     using ikkbz_sub_dverts_optimal' assms by blast
   interpret T: ranked_dtree_with_orig "ikkbz_sub t" using ikkbz_sub_ranked_dtree_orig by simp
   have "max_deg (ikkbz_sub t) \<le> 1" using ikkbz_sub_mdeg_le1 by auto
   have "hd (Dtree.root (ikkbz_sub t)) = root" using assms(1) ikkbz_sub_hd_root by auto
   moreover have "dom_children (ikkbz_sub t) T"
     using assms(2) dom_mdeg_le1_ikkbz_sub ikkbz_sub_eq_iff_mdeg_le1 by auto
   ultimately have "\<forall>as. fwd_sub root (dverts (ikkbz_sub t)) as
               \<longrightarrow> cost (rev (denormalize (ikkbz_sub t))) \<le> cost (rev as)"
     using T.denormalize_optimal_if_mdeg_le1[OF ikkbz_sub_mdeg_le1] by blast
   then show ?thesis using zs_def order_trans by blast
 qed
 
 end
 
 subsection \<open>Arc Invariants hold for Conversion to Dtree\<close>
 
 context precedence_graph
 begin
 
 interpretation t: ranked_dtree to_list_dtree by (rule to_list_dtree_ranked_dtree)
 
 lemma subtree_to_list_dtree_tree_dom:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; t \<in> fst ` fset xs\<rbrakk> \<Longrightarrow> r \<rightarrow>\<^bsub>to_list_tree\<^esub> Dtree.root t"
   unfolding to_list_dtree_def
   using finite_directed_tree.subtree_child_dom to_list_tree_finite_directed_tree by fastforce
 
 lemma subtree_to_list_dtree_dom:
   assumes "is_subtree (Node r xs) to_list_dtree" and "t \<in> fst ` fset xs"
   shows "hd r \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t)"
 proof -
   interpret T: directed_tree to_list_tree "[root]" by (rule to_list_tree_directed_tree)
   have 0: "r \<rightarrow>\<^bsub>to_list_tree\<^esub> Dtree.root t" using subtree_to_list_dtree_tree_dom assms by blast
   then obtain x where x_def: "r = [x] \<and> x \<in> verts T" using to_list_tree_single by force
   obtain y where "Dtree.root t = [y]" using 0 to_list_tree_single T.adj_in_verts(2) by blast
   then show ?thesis using 0 to_list_tree_def x_def(1) in_arcs_imp_in_arcs_ends by force
 qed
 
 lemma to_list_dtree_nempty_root: "is_subtree (Node r xs) to_list_dtree \<Longrightarrow> r \<noteq> []"
   using list_dtree.list_dtree_sub list_dtree.wf_lverts to_list_dtree_list_dtree by force
 
 lemma dom_children_aux:
   assumes "is_subtree (Node r xs) to_list_dtree"
       and "max_deg t1 \<le> 1"
       and "(t1,e1) \<in> fset xs"
       and "x \<in> dlverts t1"
     shows "\<exists>v \<in> set r \<union> path_lverts t1 x. v \<rightarrow>\<^bsub>T\<^esub> x"
 proof(cases "x \<in> set (Dtree.root t1)")
   case True
   have "Dtree.root t1 \<in> dverts to_list_dtree"
     using assms(1,3) dverts_subtree_subset dtree.set_sel(1) by fastforce
   then have "Dtree.root t1 = [x]" using to_list_dtree_single True by fastforce
   then have 0: "hd r \<rightarrow>\<^bsub>T\<^esub> x" using subtree_to_list_dtree_dom assms(1,3) by fastforce
   have "r \<in> dverts to_list_dtree" using assms(1) dverts_subtree_subset by force
   then have "r = [hd r]" using to_list_dtree_single True by fastforce
   then have "hd r \<in> set r" using hd_in_set[of r] by blast
   then show ?thesis using 0 by blast
 next
   case False
   obtain t2 where t2_def: "is_subtree t2 t1" "x \<in> set (Dtree.root t2)"
     using assms(4) subtree_root_if_dlverts by fastforce
   then obtain r1 xs1 where r1_def: "is_subtree (Node r1 xs1) t1" "t2 \<in> fst ` fset xs1"
     using subtree_child_if_strict_subtree t2_def False unfolding strict_subtree_def by blast
   have "is_subtree (Node r1 xs1) (Node r xs)" using r1_def(1) assms(3) by auto
   then have sub_r1: "is_subtree (Node r1 xs1) to_list_dtree" using assms(1) subtree_trans by blast
   have sub_t1_r: "is_subtree t1 (Node r xs)"
     using subtree_if_child[of t1 xs] assms(3) by force
   then have "is_subtree t2 to_list_dtree" using assms(1) subtree_trans t2_def(1) by blast
   then have "Dtree.root t2 \<in> dverts to_list_dtree"
     using assms(1) dverts_subtree_subset dtree.set_sel(1) by fastforce
   then have "Dtree.root t2 = [x]" using to_list_dtree_single t2_def(2) by force
   then have 0: "hd r1 \<rightarrow>\<^bsub>T\<^esub> x" using subtree_to_list_dtree_dom[OF sub_r1] r1_def(2) by fastforce
   have sub_t1_to: "is_subtree t1 to_list_dtree" using sub_t1_r assms(1) subtree_trans by blast
   then have "wf_dlverts t1" using t.wf_lverts list_dtree_def t.list_dtree_sub by blast
   moreover have "max_deg t1 \<le> 1" using assms(2) sub_t1_r le_trans mdeg_ge_sub by blast
   ultimately have "set r1 \<subseteq> path_lverts t1 x"
     using subtree_path_lverts_sub r1_def t2_def(2) by fast
   then show ?thesis
     using 0 sub_r1 dverts_subtree_subset hd_in_set[of r1] to_list_dtree_single by force
 qed
 
 lemma hd_dverts_in_dlverts:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; (t1,e1) \<in> fset xs; x \<in> dverts t1\<rbrakk> \<Longrightarrow> hd x \<in> dlverts t1"
   using list_dtree.list_dtree_rec list_dtree.wf_lverts hd_in_lverts_if_wf t.list_dtree_sub
   by fastforce
 
 lemma dom_children_aux2:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; max_deg t1 \<le> 1; (t1,e1) \<in> fset xs; x \<in> dverts t1\<rbrakk>
     \<Longrightarrow> \<exists>v \<in> set r \<union> path_lverts t1 (hd x). v \<rightarrow>\<^bsub>T\<^esub> (hd x)"
   using dom_children_aux hd_dverts_in_dlverts by blast
 
 lemma dom_children_full:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; \<forall>t \<in> fst ` fset xs. max_deg t \<le> 1\<rbrakk>
      \<Longrightarrow> dom_children (Node r xs) T"
   unfolding dom_children_def using dom_children_aux2 by auto
 
 lemma dom_children':
   assumes "is_subtree (Node r xs) to_list_dtree"
   shows "dom_children (Node r (Abs_fset (children_deg1 xs))) T"
   unfolding dom_children_def dtree.sel children_deg1_fset_id
   using dom_children_aux2[OF assms(1)] by fastforce
 
 lemma dom_children_maxdeg_1:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; max_deg (Node r xs) \<le> 1\<rbrakk>
      \<Longrightarrow> dom_children (Node r xs) T"
 proof (elim dom_children_full)
   show "max_deg (Node r xs) \<le> 1 \<Longrightarrow> \<forall>t\<in>fst ` fset xs. max_deg t \<le> 1"
     using mdeg_ge_child by fastforce
 qed
 
 lemma dom_child_subtree:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; t \<in> fst ` fset xs\<rbrakk> \<Longrightarrow> \<exists>v\<in>set r. v \<rightarrow>\<^bsub>T\<^esub> hd (Dtree.root t)"
   using subtree_to_list_dtree_dom hd_in_set to_list_dtree_nempty_root by blast
 
 lemma dom_children_maxdeg_1_self:
   "max_deg to_list_dtree \<le> 1 \<Longrightarrow> dom_children to_list_dtree T"
   using dom_children_maxdeg_1[of "Dtree.root to_list_dtree" "sucs to_list_dtree"] self_subtree by auto
 
 lemma seq_conform_list_tree: "\<forall>v\<in>verts to_list_tree. seq_conform v"
   by (simp add: to_list_tree_def seq_conform_single)
 
 lemma conform_list_dtree: "\<forall>v\<in>dverts to_list_dtree. seq_conform v"
   using seq_conform_list_tree dverts_eq_verts_to_list_tree by blast
 
 lemma to_list_dtree_vert_single: "\<lbrakk>v \<in> dverts to_list_dtree; x \<in> set v\<rbrakk> \<Longrightarrow> v = [x] \<and> x \<in> verts T"
   using to_list_dtree_single by fastforce
 
 lemma to_list_dtree_vert_single_sub:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; x \<in> set r\<rbrakk> \<Longrightarrow> r = [x] \<and> x \<in> verts T"
   using to_list_dtree_vert_single dverts_subtree_subset by fastforce
 
 lemma to_list_dtree_child_if_to_list_tree_arc:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; r \<rightarrow>\<^bsub>to_list_tree\<^esub> v\<rbrakk> \<Longrightarrow> \<exists>ys. (Node v ys) \<in> fst ` fset xs"
   using finite_directed_tree.child_if_dominated_to_dtree'[OF to_list_tree_finite_directed_tree]
   unfolding to_list_dtree_def by simp
 
 lemma to_list_dtree_child_if_arc:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk>
     \<Longrightarrow> \<exists>ys. Node [y] ys \<in> fst ` fset xs"
   using to_list_dtree_child_if_to_list_tree_arc to_list_tree_dom_iff to_list_dtree_vert_single_sub
   by auto
 
 lemma to_list_dtree_dverts_if_arc:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> [y] \<in> dverts (Node r xs)"
   using to_list_dtree_child_if_arc[of r xs x y] by fastforce
 
 lemma to_list_dtree_dlverts_if_arc:
   "\<lbrakk>is_subtree (Node r xs) to_list_dtree; x \<in> set r; x \<rightarrow>\<^bsub>T\<^esub> y\<rbrakk> \<Longrightarrow> y \<in> dlverts (Node r xs)"
   using to_list_dtree_child_if_arc[of r xs x y] by fastforce
 
 theorem to_list_dtree_ranked_orig: "ranked_dtree_with_orig to_list_dtree rank cost cmp T root"
   using dom_children' to_list_dtree_dlverts_if_arc asi_rank apply(unfold_locales)
   by (auto simp: dom_children_maxdeg_1 dom_child_subtree distinct_to_list_dtree conform_list_dtree)
 
 interpretation t: ranked_dtree_with_orig to_list_dtree by (rule to_list_dtree_ranked_orig)
 
 lemma forward_ikkbz_sub: "forward ikkbz_sub"
   using ikkbz_sub_def dom_children_maxdeg_1_self t.ikkbz_sub_forward by simp
 
 subsection \<open>Optimality of IKKBZ-Sub\<close>
 
 lemma ikkbz_sub_optimal_Q:
   "(\<forall>as. fwd_sub root (verts to_list_tree) as \<longrightarrow> cost (rev ikkbz_sub) \<le> cost (rev as))"
   using t.denormalize_ikkbz_sub_optimal to_list_dtree_hd_root_eq_root dom_children_maxdeg_1_self
   unfolding dverts_eq_verts_to_list_tree ikkbz_sub_def by blast
 
 lemma to_list_tree_sublist_if_set_eq:
   assumes "set ys = \<Union>(set ` verts to_list_tree)" and "xs \<in> verts to_list_tree"
   shows "sublist xs ys"
 proof -
   obtain x where x_def: "xs = [x]" "x \<in> verts T" using to_list_tree_single assms(2) by blast
   then have "x \<in> set ys" using assms(1) to_list_tree_def by simp
   then show ?thesis using x_def(1) split_list[of x ys] sublist_Cons sublist_append_leftI by fast
 qed
 
 lemma hd_eq_tk1_if_set_eq_verts: "set xs = verts T \<Longrightarrow> hd xs = root \<longleftrightarrow> take 1 xs = [root]"
   using hd_eq_take1 take1_eq_hd[of xs] non_empty by fastforce
 
 lemma ikkbz_sub_optimal:
   "\<lbrakk>set xs = verts T; distinct xs; forward xs; hd xs = root\<rbrakk>
     \<Longrightarrow> cost (rev ikkbz_sub) \<le> cost (rev xs)"
   using ikkbz_sub_optimal_Q to_list_tree_sublist_if_set_eq
   by (simp add: hd_eq_tk1_if_set_eq_verts to_list_tree_union_verts_eq fwd_sub_def unique_set_r_def)
 
 end
 
 subsection \<open>Optimality of IKKBZ\<close>
 
 context ikkbz_query_graph
 begin
 
 text \<open>
 Optimality only with respect to valid solutions (i.e. contain every relation exactly once).
 Furthermore, only join trees without cross products are considered.
 \<close>
 
 lemma ikkbz_sub_optimal_cost_r:
   "\<lbrakk>set xs = verts G; distinct xs; no_cross_products (create_ldeep xs); hd xs = r; r \<in> verts G\<rbrakk>
     \<Longrightarrow> cost_r r (rev (ikkbz_sub r)) \<le> cost_r r (rev xs)"
   using precedence_graph.ikkbz_sub_optimal verts_dir_tree_r_eq
   by (fast intro: forward_if_ldeep_no_cross precedence_graph_r)
 
 lemma ikkbz_sub_no_cross: "r \<in> verts G \<Longrightarrow> no_cross_products (create_ldeep (ikkbz_sub r))"
   using precedence_graph.forward_ikkbz_sub ikkbz_sub_verts_eq
   by (fastforce intro: no_cross_ldeep_if_forward' precedence_graph_r)
 
 lemma ikkbz_sub_cost_r_eq_cost:
   "r \<in> verts G \<Longrightarrow> cost_r r (rev (ikkbz_sub r)) = cost_l (ikkbz_sub r)"
   using ikkbz_sub_verts_eq ikkbz_sub_distinct ikkbz_sub_no_cross ikkbz_sub_hd_eq_root
   by (fastforce dest: cost_correct')
 
 corollary ikkbz_sub_optimal:
   "\<lbrakk>set xs = verts G; distinct xs; no_cross_products (create_ldeep xs); hd xs = r; r \<in> verts G\<rbrakk>
     \<Longrightarrow> cost_l (ikkbz_sub r) \<le> cost_l xs"
   using ikkbz_sub_optimal_cost_r cost_correct' ikkbz_sub_cost_r_eq_cost by fastforce
 
 lemma ikkbz_no_cross: "no_cross_products (create_ldeep ikkbz)"
   using ikkbz_eq_ikkbz_sub ikkbz_sub_no_cross by force
 
 lemma hd_in_verts_if_set_eq: "set xs = verts G \<Longrightarrow> hd xs \<in> verts G"
   using verts_nempty set_empty2[of xs] by force
 
 lemma ikkbz_optimal:
   "\<lbrakk>set xs = verts G; distinct xs; no_cross_products (create_ldeep xs)\<rbrakk>
     \<Longrightarrow> cost_l ikkbz \<le> cost_l xs"
   using ikkbz_min_ikkbz_sub ikkbz_sub_optimal by (fastforce intro: hd_in_verts_if_set_eq)
 
 theorem ikkbz_optimal_tree:
   "\<lbrakk>valid_tree t; no_cross_products t; left_deep t\<rbrakk> \<Longrightarrow> cost (create_ldeep ikkbz) \<le> cost t"
   using ikkbz_optimal inorder_eq_set by (fastforce simp: distinct_relations_def valid_tree_def)
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
--- a/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
+++ b/thys/Relational_Disjoint_Set_Forests/Disjoint_Set_Forests.thy
@@ -1,2264 +1,2246 @@
 (* Title:      Disjoint-Set Forests
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory Disjoint_Set_Forests
 
 imports
   "HOL-Hoare.Hoare_Logic"
   Stone_Kleene_Relation_Algebras.Kleene_Relation_Algebras
 begin
 
 no_notation
   minus (infixl "-" 65) and
   trancl ("(_\<^sup>+)" [1000] 999)
 
 context p_algebra
 begin
 
 abbreviation minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "-" 65)
   where "x - y \<equiv> x \<sqinter> -y"
 
 end
 
 text \<open>
 An arc in a Stone relation algebra corresponds to an atom in a relation algebra and represents a single edge in a graph.
 A point represents a set of nodes.
 A rectangle represents the Cartesian product of two sets of nodes \<^cite>\<open>"BerghammerStruth2010"\<close>.
 \<close>
 
 context times_top
 begin
 
 abbreviation rectangle :: "'a \<Rightarrow> bool"
   where "rectangle x \<equiv> x * top * x = x"
 
 end
 
 context stone_relation_algebra
 begin
 
 lemma arc_rectangle:
   "arc x \<Longrightarrow> rectangle x"
   using arc_top_arc by blast
 
 section \<open>Relation-Algebraic Semantics of Associative Array Access\<close>
 
 text \<open>
 The following two operations model updating array $x$ at index $y$ to value $z$, 
 and reading the content of array $x$ at index $y$, respectively.
 The read operation uses double brackets to avoid ambiguity with list syntax.
 The remainder of this section shows basic properties of these operations.
 \<close>
 
 abbreviation rel_update :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(_[_\<longmapsto>_])" [70, 65, 65] 61)
   where "x[y\<longmapsto>z] \<equiv> (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> x)"
 
 abbreviation rel_access :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(2_[[_]])" [70, 65] 65)
   where "x[[y]] \<equiv> x\<^sup>T * y"
 
 lemma update_univalent:
   assumes "univalent x"
     and "vector y"
     and "injective z"
   shows "univalent (x[y\<longmapsto>z])"
 proof -
   have 1: "univalent (y \<sqinter> z\<^sup>T)"
     using assms(3) inf_commute univalent_inf_closed by force
   have "(y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) = (y\<^sup>T \<sqinter> z) * (-y \<sqinter> x)"
     by (simp add: conv_dist_inf)
   also have "... = z * (y \<sqinter> -y \<sqinter> x)"
     by (metis assms(2) covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
   finally have 2: "(y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) = bot"
     by simp
   have 3: "vector (-y)"
     using assms(2) vector_complement_closed by simp
   have "(-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) = (-y\<^sup>T \<sqinter> x\<^sup>T) * (y \<sqinter> z\<^sup>T)"
     by (simp add: conv_complement conv_dist_inf)
   also have "... = x\<^sup>T * (-y \<sqinter> y \<sqinter> z\<^sup>T)"
     using 3 by (metis (mono_tags, opaque_lifting) conv_complement covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
   finally have 4: "(-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) = bot"
     by simp
   have 5: "univalent (-y \<sqinter> x)"
     using assms(1) inf_commute univalent_inf_closed by fastforce
   have "(x[y\<longmapsto>z])\<^sup>T * (x[y\<longmapsto>z]) = (y \<sqinter> z\<^sup>T)\<^sup>T * (x[y\<longmapsto>z]) \<squnion> (-y \<sqinter> x)\<^sup>T * (x[y\<longmapsto>z])"
     by (simp add: conv_dist_sup mult_right_dist_sup)
   also have "... = (y \<sqinter> z\<^sup>T)\<^sup>T * (y \<sqinter> z\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T)\<^sup>T * (-y \<sqinter> x) \<squnion> (-y \<sqinter> x)\<^sup>T * (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> x)\<^sup>T * (-y \<sqinter> x)"
     by (simp add: mult_left_dist_sup sup_assoc)
   finally show ?thesis
     using 1 2 4 5 by simp
 qed
 
 lemma update_total:
   assumes "total x"
     and "vector y"
     and "regular y"
     and "surjective z"
   shows "total (x[y\<longmapsto>z])"
 proof -
   have "(x[y\<longmapsto>z]) * top = x*top[y\<longmapsto>top*z]"
     by (simp add: assms(2) semiring.distrib_right vector_complement_closed vector_inf_comp conv_dist_comp)
   also have "... = top[y\<longmapsto>top]"
     using assms(1) assms(4) by simp
   also have "... = top"
     using assms(3) regular_complement_top by auto
   finally show ?thesis
     by simp
 qed
 
 lemma update_mapping:
   assumes "mapping x"
     and "vector y"
     and "regular y"
     and "bijective z"
   shows "mapping (x[y\<longmapsto>z])"
   using assms update_univalent update_total by simp
 
 lemma read_injective:
   assumes "injective y"
     and "univalent x"
   shows "injective (x[[y]])"
   using assms injective_mult_closed univalent_conv_injective by blast
 
 lemma read_surjective:
   assumes "surjective y"
     and "total x"
   shows "surjective (x[[y]])"
   using assms surjective_mult_closed total_conv_surjective by blast
 
 lemma read_bijective:
   assumes "bijective y"
     and "mapping x"
   shows "bijective (x[[y]])"
   by (simp add: assms read_injective read_surjective)
 
 lemma read_point:
   assumes "point p"
     and "mapping x"
   shows "point (x[[p]])"
   using assms comp_associative read_injective read_surjective by auto
 
 lemma update_postcondition:
   assumes "point x" "point y"
   shows "x \<sqinter> p = x * y\<^sup>T \<longleftrightarrow> p[[x]] = y"
   apply (rule iffI)
   subgoal by (metis assms comp_associative conv_dist_comp conv_involutive covector_inf_comp_3 equivalence_top_closed vector_covector)
   subgoal
     apply (rule order.antisym)
     subgoal by (metis assms conv_dist_comp conv_involutive inf.boundedI inf.cobounded1 vector_covector vector_restrict_comp_conv)
     subgoal by (smt assms comp_associative conv_dist_comp conv_involutive covector_restrict_comp_conv dense_conv_closed equivalence_top_closed inf.boundedI shunt_mapping vector_covector preorder_idempotent)
     done
   done
 
 text \<open>Back and von Wright's array independence requirements \<^cite>\<open>"BackWright1998"\<close>, 
   later also lens laws \<^cite>\<open>"FosterGreenwaldMoorePierceSchmitt2007"\<close>\<close>
 
 lemma put_get_sub:
   assumes "vector y" "surjective u" "vector z" "u \<le> y"
   shows "(x[y\<longmapsto>z])[[u]] = z"
 proof -
   have "(x[y\<longmapsto>z])[[u]] = (y\<^sup>T \<sqinter> z) * u \<squnion> (-y\<^sup>T \<sqinter> x\<^sup>T) * u"
     by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
   also have "... = z * u"
   proof -
     have "(-y\<^sup>T \<sqinter> x\<^sup>T) * u \<le> (-y\<^sup>T \<sqinter> x\<^sup>T) * y"
       by (simp add: assms(4) mult_right_isotone)
     also have "... = bot"
       by (metis assms(1) covector_inf_comp_3 inf_commute conv_complement mult_right_zero p_inf vector_complement_closed)
     finally have "(-y\<^sup>T \<sqinter> x\<^sup>T) * u = bot"
       by (simp add: bot_unique)
     thus ?thesis
       using assms(1,4) covector_inf_comp_3 inf.absorb_iff1 inf_commute by auto
   qed
   also have "... = z"
     by (metis assms(2,3) mult_assoc)
   finally show ?thesis
     .
 qed
 
 lemma put_get:
   assumes "vector y" "surjective y" "vector z"
   shows "(x[y\<longmapsto>z])[[y]] = z"
   by (simp add: assms put_get_sub)
 
 lemma put_put:
   "(x[y\<longmapsto>z])[y\<longmapsto>w] = x[y\<longmapsto>w]"
   by (metis inf_absorb2 inf_commute inf_le1 inf_sup_distrib1 maddux_3_13 sup_inf_absorb)
 
 lemma get_put:
   assumes "point y"
   shows "x[y\<longmapsto>x[[y]]] = x"
 proof -
   have "x[y\<longmapsto>x[[y]]] = (y \<sqinter> y\<^sup>T * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... = (y \<sqinter> x) \<squnion> (-y \<sqinter> x)"
   proof -
     have "y \<sqinter> y\<^sup>T * x = y \<sqinter> x"
     proof (rule order.antisym)
       have "y \<sqinter> y\<^sup>T * x = (y \<sqinter> y\<^sup>T) * x"
         by (simp add: assms vector_inf_comp)
       also have "(y \<sqinter> y\<^sup>T) * x = y * y\<^sup>T * x"
         by (simp add: assms vector_covector)
       also have "... \<le> x"
         using assms comp_isotone by fastforce
       finally show "y \<sqinter> y\<^sup>T * x \<le> y \<sqinter> x"
         by simp
       have "y \<sqinter> x \<le> y\<^sup>T * x"
         by (simp add: assms vector_restrict_comp_conv)
       thus "y \<sqinter> x \<le> y \<sqinter> y\<^sup>T * x"
         by simp
     qed
     thus ?thesis
       by simp
   qed
   also have "... = x"
   proof -
     have "regular y"
       using assms bijective_regular by blast
     thus ?thesis
       by (metis inf.sup_monoid.add_commute maddux_3_11_pp)
   qed
   finally show ?thesis
     .
 qed
 
 lemma update_inf:
   "u \<le> y \<Longrightarrow> (x[y\<longmapsto>z]) \<sqinter> u = z\<^sup>T \<sqinter> u"
   by (smt comp_inf.mult_right_dist_sup comp_inf.semiring.mult_zero_right inf.left_commute inf.sup_monoid.add_assoc inf_absorb2 p_inf sup_bot_right inf.sup_monoid.add_commute)
 
 lemma update_inf_same:
   "(x[y\<longmapsto>z]) \<sqinter> y = z\<^sup>T \<sqinter> y"
   by (simp add: update_inf)
 
 lemma update_inf_different:
   "u \<le> -y \<Longrightarrow> (x[y\<longmapsto>z]) \<sqinter> u = x \<sqinter> u"
   by (smt inf.right_idem inf.sup_monoid.add_commute inf.sup_relative_same_increasing inf_import_p maddux_3_13 sup.cobounded2 update_inf_same)
 
 end
 
 section \<open>Relation-Algebraic Semantics of Disjoint-Set Forests\<close>
 
 text \<open>
 A disjoint-set forest represents a partition of a set into equivalence classes.
 We take the represented equivalence relation as the semantics of a forest.
 It is obtained by operation \<open>fc\<close> below.
 Additionally, operation \<open>wcc\<close> giving the weakly connected components of a graph will be used for the semantics of the union of two disjoint sets.
 Finally, operation \<open>root\<close> yields the root of a component tree, that is, the representative of a set containing a given element.
 This section defines these operations and derives their properties.
 \<close>
 
 context stone_kleene_relation_algebra
 begin
 
 lemma omit_redundant_points:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star>"
 proof (rule order.antisym)
   let ?p = "p \<sqinter> 1"
   have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ?p \<le> ?p * top * ?p"
     by (metis comp_associative mult_left_isotone mult_right_isotone top.extremum)
   also have "... \<le> ?p"
     by (simp add: assms injective_codomain vector_inf_one_comp)
   finally have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ?p * x \<le> ?p * x"
     using mult_left_isotone by blast
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * (p \<sqinter> x) \<le> ?p * x"
     by (simp add: assms comp_associative vector_inf_one_comp)
   also have 1: "... \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     using mult_right_isotone star.circ_reflexive by fastforce
   finally have "?p * x * (-p \<sqinter> x)\<^sup>\<star> * (p \<sqinter> x) \<squnion> ?p * x * (-p \<sqinter> x)\<^sup>\<star> * (-p \<sqinter> x) \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: mult_right_isotone star.circ_plus_same star.left_plus_below_circ mult_assoc)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * ((p \<squnion> -p) \<sqinter> x) \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_inf.mult_right_dist_sup mult_left_dist_sup)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (metis assms bijective_regular inf.absorb2 inf.cobounded1 inf.sup_monoid.add_commute shunting_p)
   hence "?p * x * (-p \<sqinter> x)\<^sup>\<star> * x \<squnion> ?p * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     using 1 by simp
   hence "?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>) * x \<le> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup)
   also have "... \<le> ?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>)"
     by (simp add: comp_associative mult_right_isotone)
   finally have "?p * x\<^sup>\<star> \<le> ?p * (1 \<squnion> x * (-p \<sqinter> x)\<^sup>\<star>)"
     using star_right_induct by (meson dual_order.trans le_supI mult_left_sub_dist_sup_left mult_sub_right_one)
   also have "... = ?p \<squnion> ?p * x * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: comp_associative semiring.distrib_left)
   finally show "p \<sqinter> x\<^sup>\<star> \<le> ?p \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star>"
     by (simp add: assms vector_inf_one_comp)
   show "?p \<squnion> (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<le> p \<sqinter> x\<^sup>\<star>"
     by (metis assms comp_isotone inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute le_supI star.circ_increasing star.circ_transitive_equal star_isotone star_left_unfold_equal sup.cobounded1 vector_export_comp)
 qed
 
 text \<open>Weakly connected components\<close>
 
 abbreviation "wcc x \<equiv> (x \<squnion> x\<^sup>T)\<^sup>\<star>"
 
 lemma wcc_equivalence:
   "equivalence (wcc x)"
   apply (intro conjI)
   subgoal by (simp add: star.circ_reflexive)
   subgoal by (simp add: star.circ_transitive_equal)
   subgoal by (simp add: conv_dist_sup conv_star_commute sup_commute)
   done
 
 lemma wcc_increasing:
   "x \<le> wcc x"
   by (simp add: star.circ_sub_dist_1)
 
 lemma wcc_isotone:
   "x \<le> y \<Longrightarrow> wcc x \<le> wcc y"
   using conv_isotone star_isotone sup_mono by blast
 
 lemma wcc_idempotent:
   "wcc (wcc x) = wcc x"
   using star_involutive wcc_equivalence by auto
 
 lemma wcc_below_wcc:
   "x \<le> wcc y \<Longrightarrow> wcc x \<le> wcc y"
   using wcc_idempotent wcc_isotone by fastforce
 
 lemma wcc_galois:
   "x \<le> wcc y \<longleftrightarrow> wcc x \<le> wcc y"
   using order_trans star.circ_sub_dist_1 wcc_below_wcc by blast
 
 lemma wcc_bot:
   "wcc bot = 1"
   by (simp add: star.circ_zero)
 
 lemma wcc_one:
   "wcc 1 = 1"
   by (simp add: star_one)
 
 lemma wcc_top:
   "wcc top = top"
   by (simp add: star.circ_top)
 
 lemma wcc_with_loops:
   "wcc x = wcc (x \<squnion> 1)"
   by (metis conv_dist_sup star_decompose_1 star_sup_one sup_commute symmetric_one_closed)
 
 lemma wcc_without_loops:
   "wcc x = wcc (x - 1)"
   by (metis conv_star_commute star_sum reachable_without_loops)
 
 lemma forest_components_wcc:
   "injective x \<Longrightarrow> wcc x = forest_components x"
   by (simp add: cancel_separate_1)
 
 lemma wcc_sup_wcc:
   "wcc (x \<squnion> y) = wcc (x \<squnion> wcc y)"
   by (smt (verit, ccfv_SIG) le_sup_iff order.antisym sup_right_divisibility wcc_below_wcc wcc_increasing)
 
 text \<open>Components of a forest, which is represented using edges directed towards the roots\<close>
 
 abbreviation "fc x \<equiv> x\<^sup>\<star> * x\<^sup>T\<^sup>\<star>"
 
 lemma fc_equivalence:
   "univalent x \<Longrightarrow> equivalence (fc x)"
   apply (intro conjI)
   subgoal by (simp add: reflexive_mult_closed star.circ_reflexive)
   subgoal by (metis cancel_separate_1 order.eq_iff star.circ_transitive_equal)
   subgoal by (simp add: conv_dist_comp conv_star_commute)
   done
 
 lemma fc_increasing:
   "x \<le> fc x"
   by (metis le_supE mult_left_isotone star.circ_back_loop_fixpoint star.circ_increasing)
 
 lemma fc_isotone:
   "x \<le> y \<Longrightarrow> fc x \<le> fc y"
   by (simp add: comp_isotone conv_isotone star_isotone)
 
 lemma fc_idempotent:
   "univalent x \<Longrightarrow> fc (fc x) = fc x"
   by (metis fc_equivalence cancel_separate_1 star.circ_transitive_equal star_involutive)
 
 lemma fc_star:
   "univalent x \<Longrightarrow> (fc x)\<^sup>\<star> = fc x"
   using fc_equivalence fc_idempotent star.circ_transitive_equal by simp
 
 lemma fc_plus:
   "univalent x \<Longrightarrow> (fc x)\<^sup>+ = fc x"
   by (metis fc_star star.circ_decompose_9)
 
 lemma fc_bot:
   "fc bot = 1"
   by (simp add: star.circ_zero)
 
 lemma fc_one:
   "fc 1 = 1"
   by (simp add: star_one)
 
 lemma fc_top:
   "fc top = top"
   by (simp add: star.circ_top)
 
 lemma fc_wcc:
   "univalent x \<Longrightarrow> wcc x = fc x"
   by (simp add: fc_star star_decompose_1)
 
 lemma fc_via_root:
   assumes "total (p\<^sup>\<star> * (p \<sqinter> 1))"
   shows "fc p = p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
 proof (rule order.antisym)
   have "1 \<le> p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (smt assms comp_associative conv_dist_comp conv_star_commute coreflexive_idempotent coreflexive_symmetric inf.cobounded2 total_var)
   hence "fc p \<le> p\<^sup>\<star> * p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * p\<^sup>T\<^sup>\<star>"
     by (metis comp_right_one mult_left_isotone mult_right_isotone mult_assoc)
   thus "fc p \<le> p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (simp add: star.circ_transitive_equal mult_assoc)
   show "p\<^sup>\<star> * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<le> fc p"
     by (metis comp_isotone inf.cobounded2 mult_1_right order.refl)
 qed
 
 lemma update_acyclic_1:
   assumes "acyclic (p - 1)"
     and "point y"
     and "vector w"
     and "w \<le> p\<^sup>\<star> * y"
   shows "acyclic ((p[w\<longmapsto>y]) - 1)"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   have "w * y\<^sup>T \<le> p\<^sup>\<star>"
     using assms(2,4) shunt_bijective by blast
   hence "w * y\<^sup>T \<le> (p - 1)\<^sup>\<star>"
     using reachable_without_loops by auto
   hence "w * y\<^sup>T - 1 \<le> (p - 1)\<^sup>\<star> - 1"
     by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute)
   also have "... \<le> (p - 1)\<^sup>+"
     by (simp add: star_plus_without_loops)
   finally have 1: "w \<sqinter> y\<^sup>T \<sqinter> -1 \<le> (p - 1)\<^sup>+"
     using assms(2,3) vector_covector by auto
   have "?p - 1 = (w \<sqinter> y\<^sup>T \<sqinter> -1) \<squnion> (-w \<sqinter> p \<sqinter> -1)"
     by (simp add: inf_sup_distrib2)
   also have "... \<le> (p - 1)\<^sup>+ \<squnion> (-w \<sqinter> p \<sqinter> -1)"
     using 1 sup_left_isotone by blast
   also have "... \<le> (p - 1)\<^sup>+ \<squnion> (p - 1)"
     using comp_inf.mult_semi_associative sup_right_isotone by auto
   also have "... = (p - 1)\<^sup>+"
     by (metis star.circ_back_loop_fixpoint sup.right_idem)
   finally have "(?p - 1)\<^sup>+ \<le> (p - 1)\<^sup>+"
     by (metis comp_associative comp_isotone star.circ_transitive_equal star.left_plus_circ star_isotone)
   also have "... \<le> -1"
     using assms(1) by blast
   finally show ?thesis
     by simp
 qed
 
 lemma update_acyclic_2:
   assumes "acyclic (p - 1)"
     and "point y"
     and "point x"
     and "y \<le> p\<^sup>T\<^sup>\<star> * x"
     and "univalent p"
     and "p\<^sup>T * y \<le> y"
   shows "acyclic ((p[p\<^sup>T\<^sup>\<star>*x\<longmapsto>y]) - 1)"
 proof -
   have "p\<^sup>T * p\<^sup>\<star> * y = p\<^sup>T * p * p\<^sup>\<star> * y \<squnion> p\<^sup>T * y"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
   also have "... \<le> p\<^sup>\<star> * y"
     by (metis assms(5,6) comp_right_one le_supI le_supI2 mult_left_isotone star.circ_loop_fixpoint star.circ_transitive_equal)
   finally have "p\<^sup>T\<^sup>\<star> * x \<le> p\<^sup>\<star> * y"
     by (simp add: assms(2-4) bijective_reverse conv_star_commute comp_associative star_left_induct)
   thus ?thesis
     by (simp add: assms(1-3) vector_mult_closed update_acyclic_1)
 qed
 
 lemma update_acyclic_3:
   assumes "acyclic (p - 1)"
     and "point y"
     and "point w"
     and "y \<le> p\<^sup>T\<^sup>\<star> * w"
   shows "acyclic ((p[w\<longmapsto>y]) - 1)"
   by (simp add: assms bijective_reverse conv_star_commute update_acyclic_1)
 
 lemma rectangle_star_rectangle:
   "rectangle a \<Longrightarrow> a * x\<^sup>\<star> * a \<le> a"
   by (metis mult_left_isotone mult_right_isotone top.extremum)
 
 lemma arc_star_arc:
   "arc a \<Longrightarrow> a * x\<^sup>\<star> * a \<le> a"
   using arc_top_arc rectangle_star_rectangle by blast
 
 lemma star_rectangle_decompose:
   assumes "rectangle a"
   shows "(a \<squnion> x)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
 proof (rule order.antisym)
   have 1: "1 \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (simp add: star.circ_reflexive sup.coboundedI1)
   have "(a \<squnion> x) * (x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>) = a * x\<^sup>\<star> \<squnion> a * x\<^sup>\<star> * a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute)
   also have "... = a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1)
   also have "... = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   also have "... \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     using star.left_plus_below_circ sup_left_isotone by auto
   finally show "(a \<squnion> x)\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     using 1 by (metis comp_right_one le_supI star_left_induct)
 next
   show "x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star> \<le> (a \<squnion> x)\<^sup>\<star>"
     by (metis comp_isotone le_supE le_supI star.circ_increasing star.circ_transitive_equal star_isotone sup_ge2)
 qed
 
 lemma star_arc_decompose:
   "arc a \<Longrightarrow> (a \<squnion> x)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
   using arc_top_arc star_rectangle_decompose by blast
 
 lemma plus_rectangle_decompose:
   assumes "rectangle a"
   shows "(a \<squnion> x)\<^sup>+ = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
 proof -
   have "(a \<squnion> x)\<^sup>+ = (a \<squnion> x) * (x\<^sup>\<star> \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>)"
     by (simp add: assms star_rectangle_decompose)
   also have "... = a * x\<^sup>\<star> \<squnion> a * x\<^sup>\<star> * a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     by (metis comp_associative semiring.combine_common_factor semiring.distrib_left sup_commute)
   also have "... = a * x\<^sup>\<star> \<squnion> x\<^sup>+ \<squnion> x\<^sup>+ * a * x\<^sup>\<star>"
     using assms rectangle_star_rectangle by (simp add: mult_left_isotone sup_absorb1)
   also have "... = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
     by (metis comp_associative star.circ_loop_fixpoint sup_assoc sup_commute)
   finally show ?thesis
     by simp
 qed
 
 lemma plus_arc_decompose:
   "arc a \<Longrightarrow> (a \<squnion> x)\<^sup>+ = x\<^sup>+ \<squnion> x\<^sup>\<star> * a * x\<^sup>\<star>"
   using arc_top_arc plus_rectangle_decompose by blast
 
 lemma update_acyclic_4:
   assumes "acyclic (p - 1)"
     and "point y"
     and "point w"
     and "y \<sqinter> p\<^sup>\<star> * w = bot"
   shows "acyclic ((p[w\<longmapsto>y]) - 1)"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   have "y\<^sup>T * p\<^sup>\<star> * w \<le> -1"
     using assms(4) comp_associative pseudo_complement schroeder_3_p by auto
   hence 1: "p\<^sup>\<star> * w * y\<^sup>T * p\<^sup>\<star> \<le> -1"
     by (metis comp_associative comp_commute_below_diversity star.circ_transitive_equal)
   have "?p - 1 \<le> (w \<sqinter> y\<^sup>T) \<squnion> (p - 1)"
     by (metis comp_inf.mult_right_dist_sup dual_order.trans inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc le_supI sup.cobounded1 sup_ge2)
   also have "... = w * y\<^sup>T \<squnion> (p - 1)"
     using assms(2,3) by (simp add: vector_covector)
   finally have "(?p - 1)\<^sup>+ \<le> (w * y\<^sup>T \<squnion> (p - 1))\<^sup>+"
     by (simp add: comp_isotone star_isotone)
   also have "... = (p - 1)\<^sup>+ \<squnion> (p - 1)\<^sup>\<star> * w * y\<^sup>T * (p - 1)\<^sup>\<star>"
     using assms(2,3) plus_arc_decompose points_arc by (simp add: comp_associative)
   also have "... \<le> (p - 1)\<^sup>+ \<squnion> p\<^sup>\<star> * w * y\<^sup>T * p\<^sup>\<star>"
     using reachable_without_loops by auto
   also have "... \<le> -1"
     using 1 assms(1) by simp
   finally show ?thesis
     by simp
 qed
 
 lemma update_acyclic_5:
   assumes "acyclic (p - 1)"
     and "point w"
   shows "acyclic ((p[w\<longmapsto>w]) - 1)"
 proof -
   let ?p = "p[w\<longmapsto>w]"
   have "?p - 1 \<le> (w \<sqinter> w\<^sup>T \<sqinter> -1) \<squnion> (p - 1)"
     by (metis comp_inf.mult_right_dist_sup inf.cobounded2 inf.sup_monoid.add_assoc sup_right_isotone)
   also have "... = p - 1"
     using assms(2) by (metis comp_inf.covector_complement_closed equivalence_top_closed inf_top.right_neutral maddux_3_13 pseudo_complement regular_closed_top regular_one_closed vector_covector vector_top_closed)
   finally show ?thesis
     using assms(1) acyclic_down_closed by blast
 qed
 
 text \<open>Root of the tree containing point $x$ in the disjoint-set forest $p$\<close>
 
 abbreviation "roots p \<equiv> (p \<sqinter> 1) * top"
 abbreviation "root p x \<equiv> p\<^sup>T\<^sup>\<star> * x \<sqinter> roots p"
 
 lemma root_var:
   "root p x = (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
   by (simp add: coreflexive_comp_top_inf inf_commute mult_assoc)
 
 lemma root_successor_loop:
   "univalent p \<Longrightarrow> root p x = p[[root p x]]"
   by (metis root_var injective_codomain comp_associative conv_dist_inf coreflexive_symmetric equivalence_one_closed inf.cobounded2 univalent_conv_injective)
 
 lemma root_transitive_successor_loop:
   "univalent p \<Longrightarrow> root p x = p\<^sup>T\<^sup>\<star> * (root p x)"
   by (metis mult_1_right star_one star_simulation_right_equal root_successor_loop)
 
 lemma roots_successor_loop:
   "univalent p \<Longrightarrow> p[[roots p]] = roots p"
   by (metis conv_involutive inf_commute injective_codomain one_inf_conv mult_assoc)
 
 lemma roots_transitive_successor_loop:
   "univalent p \<Longrightarrow> p\<^sup>T\<^sup>\<star> * (roots p) = roots p"
   by (metis comp_associative star.circ_left_top star_simulation_right_equal roots_successor_loop)
 
 text \<open>The root of a tree of a node belongs to the same component as the node.\<close>
 
 lemma root_same_component:
   "injective x \<Longrightarrow> root p x * x\<^sup>T \<le> fc p"
   by (metis comp_associative coreflexive_comp_top_inf eq_refl inf.sup_left_divisibility inf.sup_monoid.add_commute mult_isotone star.circ_circ_mult star.circ_right_top star.circ_transitive_equal star_one star_outer_increasing test_preserves_equation top_greatest)
 
 lemma root_vector:
   "vector x \<Longrightarrow> vector (root p x)"
   by (simp add: vector_mult_closed root_var)
 
 lemma root_vector_inf:
   "vector x \<Longrightarrow> root p x * x\<^sup>T = root p x \<sqinter> x\<^sup>T"
   by (simp add: vector_covector root_vector)
 
 lemma root_same_component_vector:
   "injective x \<Longrightarrow> vector x \<Longrightarrow> root p x \<sqinter> x\<^sup>T \<le> fc p"
   using root_same_component root_vector_inf by fastforce
 
 lemma univalent_root_successors:
   assumes "univalent p"
   shows "(p \<sqinter> 1) * p\<^sup>\<star> = p \<sqinter> 1"
 proof (rule order.antisym)
   have "(p \<sqinter> 1) * p \<le> p \<sqinter> 1"
     by (smt assms(1) comp_inf.mult_semi_associative conv_dist_comp conv_dist_inf conv_order equivalence_one_closed inf.absorb1 inf.sup_monoid.add_assoc injective_codomain)
   thus "(p \<sqinter> 1) * p\<^sup>\<star> \<le> p \<sqinter> 1"
     using star_right_induct_mult by blast
   show "p \<sqinter> 1 \<le> (p \<sqinter> 1) * p\<^sup>\<star>"
     by (metis coreflexive_idempotent inf_le1 inf_le2 mult_right_isotone order_trans star.circ_increasing)
 qed
 
 lemma same_component_same_root_sub:
   assumes "univalent p"
     and "bijective y"
     and "x * y\<^sup>T \<le> fc p"
   shows "root p x \<le> root p y"
 proof -
   have "root p x * y\<^sup>T \<le> (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star>"
     by (smt assms(1,3) mult_isotone mult_assoc root_var fc_plus fc_star order.eq_iff univalent_root_successors)
   thus ?thesis
     by (simp add: assms(2) shunt_bijective root_var)
 qed
 
 lemma same_component_same_root:
   assumes "univalent p"
     and "bijective x"
     and "bijective y"
     and "x * y\<^sup>T \<le> fc p"
   shows "root p x = root p y"
 proof (rule order.antisym)
   show "root p x \<le> root p y"
     using assms(1,3,4) same_component_same_root_sub by blast
   have "y * x\<^sup>T \<le> fc p"
     using assms(1,4) fc_equivalence conv_dist_comp conv_isotone by fastforce
   thus "root p y \<le> root p x"
     using assms(1,2) same_component_same_root_sub by blast
 qed
 
 lemma same_roots_sub:
   assumes "univalent q"
     and "p \<sqinter> 1 \<le> q \<sqinter> 1"
     and "fc p \<le> fc q"
   shows "p\<^sup>\<star> * (p \<sqinter> 1) \<le> q\<^sup>\<star> * (q \<sqinter> 1)"
 proof -
   have "p\<^sup>\<star> * (p \<sqinter> 1) \<le> p\<^sup>\<star> * (q \<sqinter> 1)"
     using assms(2) mult_right_isotone by auto
   also have "... \<le> fc p * (q \<sqinter> 1)"
     using mult_left_isotone mult_right_isotone star.circ_reflexive by fastforce
   also have "... \<le> fc q * (q \<sqinter> 1)"
     by (simp add: assms(3) mult_left_isotone)
   also have "... = q\<^sup>\<star> * (q \<sqinter> 1)"
     by (metis assms(1) conv_dist_comp conv_dist_inf conv_star_commute inf_commute one_inf_conv symmetric_one_closed mult_assoc univalent_root_successors)
   finally show ?thesis
     .
 qed
 
 lemma same_roots:
   assumes "univalent p"
     and "univalent q"
     and "p \<sqinter> 1 = q \<sqinter> 1"
     and "fc p = fc q"
   shows "p\<^sup>\<star> * (p \<sqinter> 1) = q\<^sup>\<star> * (q \<sqinter> 1)"
   by (smt assms conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf_commute one_inf_conv symmetric_one_closed root_var univalent_root_successors)
 
 lemma same_root:
   assumes "univalent p"
     and "univalent q"
     and "p \<sqinter> 1 = q \<sqinter> 1"
     and "fc p = fc q"
   shows "root p x = root q x"
   by (metis assms mult_assoc root_var univalent_root_successors)
 
 lemma loop_root:
   assumes "injective x"
     and "x = p[[x]]"
   shows "x = root p x"
 proof (rule order.antisym)
   have "x \<le> p * x"
     by (metis assms comp_associative comp_right_one conv_order equivalence_one_closed ex231c inf.orderE inf.sup_monoid.add_commute mult_left_isotone mult_right_isotone one_inf_conv)
   hence "x = (p \<sqinter> 1) * x"
     by (simp add: assms(1) inf_absorb2 injective_comp_right_dist_inf)
   thus "x \<le> root p x"
     by (metis assms(2) coreflexive_comp_top_inf inf.boundedI inf.cobounded1 inf.cobounded2 mult_isotone star.circ_increasing)
 next
   show "root p x \<le> x"
     using assms(2) le_infI1 star_left_induct_mult by auto
 qed
 
 lemma one_loop:
   assumes "acyclic (p - 1)"
     and "univalent p"
   shows "(p \<sqinter> 1) * (p\<^sup>T - 1)\<^sup>+ * (p \<sqinter> 1) = bot"
 proof -
   have "p\<^sup>T\<^sup>+ \<sqinter> (p \<sqinter> 1) * top * (p \<sqinter> 1) = (p \<sqinter> 1) * p\<^sup>T\<^sup>+ * (p \<sqinter> 1)"
     by (simp add: test_comp_test_top)
   also have "... \<le> p\<^sup>T\<^sup>\<star> * (p \<sqinter> 1)"
     by (simp add: inf.coboundedI2 mult_left_isotone star.circ_mult_upper_bound star.circ_reflexive star.left_plus_below_circ)
   also have "... = p \<sqinter> 1"
     by (metis assms(2) conv_dist_comp conv_dist_inf conv_star_commute inf_commute one_inf_conv symmetric_one_closed univalent_root_successors)
   also have "... \<le> 1"
     by simp
   finally have "(p \<sqinter> 1) * top * (p \<sqinter> 1) \<le> -(p\<^sup>T\<^sup>+ - 1)"
     using p_antitone p_antitone_iff p_shunting_swap by blast
   hence "(p \<sqinter> 1)\<^sup>T * (p\<^sup>T\<^sup>+ - 1) * (p \<sqinter> 1)\<^sup>T \<le> bot"
     using triple_schroeder_p p_top by blast
   hence "(p \<sqinter> 1) * (p\<^sup>T\<^sup>+ - 1) * (p \<sqinter> 1) = bot"
     by (simp add: coreflexive_symmetric le_bot)
   thus ?thesis
     by (smt assms(1) conv_complement conv_dist_comp conv_dist_inf conv_star_commute inf_absorb1 star.circ_plus_same symmetric_one_closed reachable_without_loops star_plus_without_loops)
 qed
 
 lemma root_root:
   "root p x = root p (root p x)"
   by (smt comp_associative comp_inf.mult_right_sub_dist_sup_right dual_order.eq_iff inf.cobounded1 inf.cobounded2 inf.orderE mult_right_isotone star.circ_loop_fixpoint star.circ_transitive_equal root_var)
 
 lemma loop_root_2:
   assumes "acyclic (p - 1)"
     and "univalent p"
     and "injective x"
     and "x \<le> p\<^sup>T\<^sup>+ * x"
   shows "x = root p x"
 proof (rule order.antisym)
   have 1: "x = x - (-1 * x)"
     by (metis assms(3) comp_injective_below_complement inf.orderE mult_1_left regular_one_closed)
   have "x \<le> (p\<^sup>T - 1)\<^sup>+ * x \<squnion> (p \<sqinter> 1) * x"
     by (metis assms(4) inf_commute mult_right_dist_sup one_inf_conv plus_reachable_without_loops)
   also have "... \<le> -1 * x \<squnion> (p \<sqinter> 1) * x"
     by (metis assms(1) conv_complement conv_dist_inf conv_isotone conv_plus_commute mult_left_isotone semiring.add_right_mono symmetric_one_closed)
   also have "... \<le> -1 * x \<squnion> root p x"
     using comp_isotone inf.coboundedI2 star.circ_reflexive sup_right_isotone by auto
   finally have "x \<le> (-1 * x \<squnion> root p x) - (-1 * x)"
     using 1 inf.boundedI inf.order_iff by blast
   also have "... \<le> root p x"
     using inf.sup_left_divisibility by auto
   finally show 2: "x \<le> root p x"
     .
   have "root p x = (p \<sqinter> 1) * x \<squnion> (p \<sqinter> 1) * (p\<^sup>T - 1)\<^sup>+ * x"
     by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute reachable_without_loops root_var)
   also have "... \<le> x \<squnion> (p \<sqinter> 1) * (p\<^sup>T - 1)\<^sup>+ * root p x"
     using 2 by (metis coreflexive_comp_top_inf inf.cobounded2 mult_right_isotone semiring.add_mono)
   also have "... = x"
     by (metis assms(1,2) one_loop root_var mult_assoc semiring.mult_not_zero sup_bot_right)
   finally show "root p x \<le> x"
     .
 qed
 
 lemma path_compression_invariant_simplify:
   assumes "point w"
       and "p\<^sup>T\<^sup>+ * w \<le> -w"
       and "w \<noteq> y"
     shows "p[[w]] \<noteq> w"
 proof
   assume "p[[w]] = w"
   hence "w \<le> p\<^sup>T\<^sup>+ * w"
     by (metis comp_isotone eq_refl star.circ_mult_increasing)
   also have "... \<le> -w"
     by (simp add: assms(2))
   finally have "w = bot"
     using inf.orderE by fastforce
   thus False
     using assms(1,3) le_bot by force
 qed
 
 end
 
 context stone_relation_algebra_tarski
 begin
 
 text \<open>lemma \<open>distinct_points\<close> has been moved to theory \<open>Relation_Algebras\<close> in entry \<open>Stone_Relation_Algebras\<close>\<close>
 
 text \<open>Back and von Wright's array independence requirements \<^cite>\<open>"BackWright1998"\<close>\<close>
 
 lemma put_get_different_vector:
   assumes "vector y" "w \<le> -y"
   shows "(x[y\<longmapsto>z])[[w]] = x[[w]]"
 proof -
   have "(x[y\<longmapsto>z])[[w]] = (y\<^sup>T \<sqinter> z) * w \<squnion> (-y\<^sup>T \<sqinter> x\<^sup>T) * w"
     by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
   also have "... = z * (w \<sqinter> y) \<squnion> x\<^sup>T * (w - y)"
     by (metis assms(1) conv_complement covector_inf_comp_3 inf_commute vector_complement_closed)
   also have "... = z * (w \<sqinter> y) \<squnion> x\<^sup>T * w"
     by (simp add: assms(2) inf.absorb1)
   also have "... = z * bot \<squnion> x\<^sup>T * w"
     by (metis assms(2) comp_inf.semiring.mult_zero_right inf.absorb1 inf.sup_monoid.add_assoc p_inf)
   also have "... = x\<^sup>T * w"
     by simp
   finally show ?thesis
     .
 qed
 
 lemma put_get_different:
   assumes "point y" "point w" "w \<noteq> y"
   shows "(x[y\<longmapsto>z])[[w]] = x[[w]]"
 proof -
   have "w \<sqinter> y = bot"
     using assms distinct_points by simp
   hence "w \<le> -y"
     using pseudo_complement by simp
   thus ?thesis
     by (simp add: assms(1) assms(2) put_get_different_vector)
 qed
 
 lemma put_put_different_vector:
   assumes "vector y" "vector v" "v \<sqinter> y = bot"
   shows "(x[y\<longmapsto>z])[v\<longmapsto>w] = (x[v\<longmapsto>w])[y\<longmapsto>z]"
 proof -
   have "(x[y\<longmapsto>z])[v\<longmapsto>w] = (v \<sqinter> w\<^sup>T) \<squnion> (-v \<sqinter> y \<sqinter> z\<^sup>T) \<squnion> (-v \<sqinter> -y \<sqinter> x)"
     by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc)
   also have "... = (v \<sqinter> w\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T) \<squnion> (-v \<sqinter> -y \<sqinter> x)"
     by (metis assms(3) inf_commute inf_import_p p_inf selection_closed_id)
   also have "... = (y \<sqinter> z\<^sup>T) \<squnion> (v \<sqinter> w\<^sup>T) \<squnion> (-y \<sqinter> -v \<sqinter> x)"
     by (simp add: inf_commute sup_commute)
   also have "... = (y \<sqinter> z\<^sup>T) \<squnion> (-y \<sqinter> v \<sqinter> w\<^sup>T) \<squnion> (-y \<sqinter> -v \<sqinter> x)"
     using assms distinct_points pseudo_complement inf.absorb2 by simp
   also have "... = (x[v\<longmapsto>w])[y\<longmapsto>z]"
     by (simp add: comp_inf.semiring.distrib_left inf_assoc sup_assoc)
   finally show ?thesis
     .
 qed
 
 lemma put_put_different:
   assumes "point y" "point v" "v \<noteq> y"
   shows "(x[y\<longmapsto>z])[v\<longmapsto>w] = (x[v\<longmapsto>w])[y\<longmapsto>z]"
   using assms distinct_points put_put_different_vector by blast
 
 end
 
 section \<open>Verifying Operations on Disjoint-Set Forests\<close>
 
 text \<open>
 In this section we verify the make-set, find-set and union-sets operations of disjoint-set forests.
 We start by introducing syntax for updating arrays in programs.
 Updating the value at a given array index means updating the whole array.
 \<close>
 
 syntax
   "_rel_update" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b com" ("(2_[_] :=/ _)" [70, 65, 65] 61)
 
 translations
   "x[y] := z" => "(x := (y \<sqinter> z\<^sup>T) \<squnion> (CONST uminus y \<sqinter> x))"
 
 text \<open>
 The finiteness requirement in the following class is used for proving that the operations terminate.
 \<close>
 
 class finite_regular_p_algebra = p_algebra +
   assumes finite_regular: "finite { x . regular x }"
 begin
 
 abbreviation card_down_regular :: "'a \<Rightarrow> nat" ("_\<down>" [100] 100)
   where "x\<down> \<equiv> card { z . regular z \<and> z \<le> x }"
 
 end
 
 class stone_kleene_relation_algebra_tarski_finite_regular = stone_kleene_relation_algebra_tarski + finite_regular_p_algebra
 begin
 
 subsection \<open>Make-Set\<close>
 
 text \<open>
 We prove two correctness results about make-set.
 The first shows that the forest changes only to the extent of making one node the root of a tree.
 The second result adds that only singleton sets are created.
 \<close>
 
 definition "make_set_postcondition p x p0 \<equiv> x \<sqinter> p = x * x\<^sup>T \<and> -x \<sqinter> p = -x \<sqinter> p0"
 
 theorem make_set:
   "VARS p
   [ point x \<and> p0 = p ]
   p[x] := x
   [ make_set_postcondition p x p0 ]"
   apply vcg_tc_simp
   by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym])
 
 theorem make_set_2:
   "VARS p
   [ point x \<and> p0 = p \<and> p \<le> 1 ]
   p[x] := x
   [ make_set_postcondition p x p0 \<and> p \<le> 1 ]"
 proof vcg_tc
   fix p
   assume 1: "point x \<and> p0 = p \<and> p \<le> 1"
   show "make_set_postcondition (p[x\<longmapsto>x]) x p0 \<and> p[x\<longmapsto>x] \<le> 1"
   proof (rule conjI)
     show "make_set_postcondition (p[x\<longmapsto>x]) x p0"
       using 1 by (simp add: make_set_postcondition_def inf_sup_distrib1 inf_assoc[THEN sym] vector_covector[THEN sym])
     show "p[x\<longmapsto>x] \<le> 1"
       using 1 by (metis coreflexive_sup_closed dual_order.trans inf.cobounded2 vector_covector)
   qed
 qed
 
 text \<open>
 The above total-correctness proof allows us to extract a function, which can be used in other implementations below.
 This is a technique of \<^cite>\<open>"Guttmann2018c"\<close>.
 \<close>
 
 lemma make_set_exists:
   "point x \<Longrightarrow> \<exists>p' . make_set_postcondition p' x p"
   using tc_extract_function make_set by blast
 
 definition "make_set p x \<equiv> (SOME p' . make_set_postcondition p' x p)"
 
 lemma make_set_function:
   assumes "point x"
     and "p' = make_set p x"
   shows "make_set_postcondition p' x p"
 proof -
   let ?P = "\<lambda>p' . make_set_postcondition p' x p"
   have "?P (SOME z . ?P z)"
     using assms(1) make_set_exists by (meson someI)
   thus ?thesis
     using assms(2) make_set_def by auto
 qed
 
 end
 
 subsection \<open>Find-Set\<close>
 
 text \<open>
 Disjoint-set forests are represented by their parent mapping.
 It is a forest except each root of a component tree points to itself.
 
 We prove that find-set returns the root of the component tree of the given node.
 \<close>
 
 context pd_kleene_allegory
 begin
 
 abbreviation "disjoint_set_forest p \<equiv> mapping p \<and> acyclic (p - 1)"
 
 end
 
 context stone_kleene_relation_algebra_tarski
 begin
 
 text \<open>
 If two nodes are mutually reachable from each other in a disjoint-set forest, they must be equal.
 \<close>
 
 lemma forest_mutually_reachable:
   assumes "acyclic (p - 1)" "point x" "point y" "x \<le> p\<^sup>\<star> * y" "y \<le> p\<^sup>\<star> * x"
   shows "x = y"
 proof (rule ccontr)
   assume 1: "x \<noteq> y"
   hence 2: "x \<le> -y"
     by (meson assms(2,3) bijective_regular dual_order.eq_iff point_in_vector_or_complement point_in_vector_or_complement_2)
   have "x \<le> (p - 1)\<^sup>\<star> * y"
     using assms(4) reachable_without_loops by auto
   also have "... = (p - 1)\<^sup>+ * y \<squnion> y"
     by (simp add: star.circ_loop_fixpoint mult_assoc)
   finally have 3: "x \<le> (p - 1)\<^sup>+ * y"
     using 2 by (metis half_shunting inf.orderE)
   have 4: "y \<le> -x"
     using 1 by (meson assms(2,3) bijective_regular dual_order.eq_iff point_in_vector_or_complement point_in_vector_or_complement_2)
   have "y \<le> (p - 1)\<^sup>\<star> * x"
     using assms(5) reachable_without_loops by auto
   also have "... = (p - 1)\<^sup>+ * x \<squnion> x"
     by (simp add: star.circ_loop_fixpoint mult_assoc)
   finally have "y \<le> (p - 1)\<^sup>+ * x"
     using 4 by (metis half_shunting inf.orderE)
   also have "... \<le> (p - 1)\<^sup>+ * (p - 1)\<^sup>+ * y"
     using 3 by (simp add: comp_associative mult_right_isotone)
   also have "... \<le> (p - 1)\<^sup>+ * y"
     by (simp add: mult_left_isotone plus_transitive)
   finally have "y * y\<^sup>T \<le> (p - 1)\<^sup>+"
     using assms(3) shunt_bijective by blast
   also have "... \<le> -1"
     by (simp add: assms(1))
   finally have "y = bot"
     using inf.absorb_iff1 schroeder_4_p by auto
   thus False
     using 1 assms(3) bot_least top_unique by auto
 qed
 
 lemma forest_mutually_reachable_2:
   assumes "acyclic (p - 1)" "point x" "point y" "x \<le> p\<^sup>T\<^sup>\<star> * y" "y \<le> p\<^sup>T\<^sup>\<star> * x"
   shows "x = y"
 proof -
   have 1: "x \<le> p\<^sup>\<star> * y"
     by (simp add: assms(2,3,5) bijective_reverse conv_star_commute)
   have "y \<le> p\<^sup>\<star> * x"
     by (simp add: assms(2-4) bijective_reverse conv_star_commute)
   thus ?thesis
     using 1 assms(1-3) forest_mutually_reachable by blast
 qed
 
 end
 
 context stone_kleene_relation_algebra_tarski_finite_regular
 begin
 
 definition "find_set_precondition p x \<equiv> disjoint_set_forest p \<and> point x"
 definition "find_set_invariant p x y \<equiv> find_set_precondition p x \<and> point y \<and> y \<le> p\<^sup>T\<^sup>\<star> * x"
 definition "find_set_postcondition p x y \<equiv> point y \<and> y = root p x"
 
 lemma find_set_1:
   "find_set_precondition p x \<Longrightarrow> find_set_invariant p x x"
   apply (unfold find_set_invariant_def)
   using mult_left_isotone star.circ_reflexive find_set_precondition_def by fastforce
 
 lemma find_set_2:
   "find_set_invariant p x y \<and> y \<noteq> p[[y]] \<Longrightarrow> find_set_invariant p x (p[[y]]) \<and> (p\<^sup>T\<^sup>\<star> * (p[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
 proof -
   let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
   let ?t = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * (p[[y]]) }"
   assume 1: "find_set_invariant p x y \<and> y \<noteq> p[[y]]"
   have 2: "point (p[[y]])"
     using 1 read_point find_set_invariant_def find_set_precondition_def by simp
   show "find_set_invariant p x (p[[y]]) \<and> card ?t < card ?s"
   proof (unfold find_set_invariant_def, intro conjI)
     show "find_set_precondition p x"
       using 1 find_set_invariant_def by simp
     show "vector (p[[y]])"
       using 2 by simp
     show "injective (p[[y]])"
       using 2 by simp
     show "surjective (p[[y]])"
       using 2 by simp
     show "p[[y]] \<le> p\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis (opaque_lifting) find_set_invariant_def comp_associative comp_isotone star.circ_increasing star.circ_transitive_equal)
     show "card ?t < card ?s"
     proof -
       have "p[[y]] = (p\<^sup>T \<sqinter> 1) * y \<squnion> (p\<^sup>T - 1) * y"
         by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
       also have "... \<le> ((p[[y]]) \<sqinter> y) \<squnion> (p\<^sup>T - 1) * y"
         by (metis comp_left_subdist_inf mult_1_left semiring.add_right_mono)
       also have "... = (p\<^sup>T - 1) * y"
         using 1 2 find_set_invariant_def distinct_points by auto
       finally have 3: "(p\<^sup>T - 1)\<^sup>\<star> * (p[[y]]) \<le> (p\<^sup>T - 1)\<^sup>+ * y"
         by (simp add: mult_right_isotone star_simulation_right_equal mult_assoc)
       have "p\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
         by (metis mult_left_isotone star.right_plus_below_circ mult_assoc)
       hence 4: "?t \<subseteq> ?s"
         using order_trans by auto
       have 5: "y \<in> ?s"
         using 1 find_set_invariant_def bijective_regular mult_left_isotone star.circ_reflexive by fastforce
       have 6: "\<not> y \<in> ?t"
       proof
         assume "y \<in> ?t"
         hence "y \<le> (p\<^sup>T - 1)\<^sup>+ * y"
           using 3 by (metis reachable_without_loops mem_Collect_eq order_trans)
         hence "y * y\<^sup>T \<le> (p\<^sup>T - 1)\<^sup>+"
           using 1 find_set_invariant_def shunt_bijective by simp
         also have "... \<le> -1"
           using 1 by (metis (mono_tags, lifting) find_set_invariant_def find_set_precondition_def conv_dist_comp conv_dist_inf conv_isotone conv_star_commute equivalence_one_closed star.circ_plus_same symmetric_complement_closed)
         finally have "y \<le> -y"
           using schroeder_4_p by auto
         thus False
           using 1 by (metis find_set_invariant_def comp_inf.coreflexive_idempotent conv_complement covector_vector_comp inf.absorb1 inf.sup_monoid.add_commute pseudo_complement surjective_conv_total top.extremum vector_top_closed regular_closed_top)
       qed
       show "card ?t < card ?s"
         apply (rule psubset_card_mono)
         subgoal using finite_regular by simp
         subgoal using 4 5 6 by auto
         done
     qed
   qed
 qed
 
 lemma find_set_3:
   "find_set_invariant p x y \<and> y = p[[y]] \<Longrightarrow> find_set_postcondition p x y"
 proof -
   assume 1: "find_set_invariant p x y \<and> y = p[[y]]"
   show "find_set_postcondition p x y"
   proof (unfold find_set_postcondition_def, rule conjI)
     show "point y"
       using 1 find_set_invariant_def by simp
     show "y = root p x"
     proof (rule order.antisym)
       have "y * y\<^sup>T \<le> p"
         using 1 by (metis find_set_invariant_def find_set_precondition_def shunt_bijective shunt_mapping top_right_mult_increasing)
       hence "y * y\<^sup>T \<le> p \<sqinter> 1"
         using 1 find_set_invariant_def le_infI by blast
       hence "y \<le> roots p"
         using 1 by (metis find_set_invariant_def order_lesseq_imp shunt_bijective top_right_mult_increasing mult_assoc)
       thus "y \<le> root p x"
         using 1 find_set_invariant_def by simp
     next
       have 2: "x \<le> p\<^sup>\<star> * y"
         using 1 find_set_invariant_def find_set_precondition_def bijective_reverse conv_star_commute by auto
       have "p\<^sup>T * p\<^sup>\<star> * y = p\<^sup>T * p * p\<^sup>\<star> * y \<squnion> (p[[y]])"
         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
       also have "... \<le> p\<^sup>\<star> * y \<squnion> y"
         using 1 by (metis find_set_invariant_def find_set_precondition_def comp_isotone mult_left_sub_dist_sup semiring.add_right_mono star.circ_back_loop_fixpoint star.circ_circ_mult star.circ_top star.circ_transitive_equal star_involutive star_one)
       also have "... = p\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 3: "p\<^sup>T\<^sup>\<star> * x \<le> p\<^sup>\<star> * y"
         using 2 by (simp add: comp_associative star_left_induct)
       have "p * y \<sqinter> roots p = (p \<sqinter> 1) * p * y"
         using comp_associative coreflexive_comp_top_inf inf_commute by auto
       also have "... \<le> p\<^sup>T * p * y"
         by (metis inf.cobounded2 inf.sup_monoid.add_commute mult_left_isotone one_inf_conv)
       also have "... \<le> y"
         using 1 find_set_invariant_def find_set_precondition_def mult_left_isotone by fastforce
       finally have 4: "p * y \<le> y \<squnion> -roots p"
         using 1 by (metis find_set_invariant_def shunting_p bijective_regular)
       have "p * -roots p \<le> -roots p"
         using 1 by (metis find_set_invariant_def find_set_precondition_def conv_complement_sub_leq conv_involutive roots_successor_loop)
       hence "p * y \<squnion> p * -roots p \<le> y \<squnion> -roots p"
         using 4 dual_order.trans le_supI sup_ge2 by blast
       hence "p * (y \<squnion> -roots p) \<le> y \<squnion> -roots p"
         by (simp add: mult_left_dist_sup)
       hence "p\<^sup>\<star> * y \<le> y \<squnion> -roots p"
         by (simp add: star_left_induct)
       hence "p\<^sup>T\<^sup>\<star> * x \<le> y \<squnion> -roots p"
         using 3 dual_order.trans by blast
       thus "root p x \<le> y"
         using 1 by (metis find_set_invariant_def shunting_p bijective_regular)
     qed
   qed
 qed
 
 theorem find_set:
   "VARS y
   [ find_set_precondition p x ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO y := p[[y]]
      OD
   [ find_set_postcondition p x y ]"
   apply vcg_tc_simp
     apply (fact find_set_1)
    apply (fact find_set_2)
   by (fact find_set_3)
 
 lemma find_set_exists:
   "find_set_precondition p x \<Longrightarrow> \<exists>y . find_set_postcondition p x y"
   using tc_extract_function find_set by blast
 
 text \<open>
 The root of a component tree is a point, that is, represents a singleton set of nodes.
 This could be proved from the definitions using Kleene-relation algebraic calculations.
 But they can be avoided because the property directly follows from the postcondition of the previous correctness proof.
 The corresponding algorithm shows how to obtain the root.
 We therefore have an essentially constructive proof of the following result.
 \<close>
 
 lemma root_point:
   "disjoint_set_forest p \<Longrightarrow> point x \<Longrightarrow> point (root p x)"
   using find_set_exists find_set_precondition_def find_set_postcondition_def by simp
 
 definition "find_set p x \<equiv> (SOME y . find_set_postcondition p x y)"
 
 lemma find_set_function:
   assumes "find_set_precondition p x"
     and "y = find_set p x"
   shows "find_set_postcondition p x y"
   by (metis assms find_set_def find_set_exists someI)
 
 subsection \<open>Path Compression\<close>
 
 text \<open>
 The path-compression technique is frequently implemented in recursive implementations of find-set 
 modifying the tree on the way out from recursive calls. Here we implement it using a second while-loop, 
 which iterates over the same path to the root and changes edges to point to the root of the component, 
 which is known after the while-loop in find-set completes. We prove that path compression preserves 
 the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the 
 component trees. Additionally we prove the exact effect of path compression.
 \<close>
 
 definition "path_compression_precondition p x y \<equiv> disjoint_set_forest p \<and> point x \<and> point y \<and> y = root p x"
 definition "path_compression_invariant p x y p0 w \<equiv>
   path_compression_precondition p x y \<and> point w \<and>
   p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   root p w = y \<and> p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w\<longmapsto>y] = p \<and>
   disjoint_set_forest p0 \<and> w \<le> p0\<^sup>T\<^sup>\<star> * x"
 definition "path_compression_postcondition p x y p0 \<equiv>
-  path_compression_precondition p x y \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
+  disjoint_set_forest p \<and> y = root p x \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y] = p"
 
 text \<open>
 We first consider a variant that achieves the effect as a single update.
 The parents of all nodes reachable from x are simultaneously updated to the root of the component of x.
 \<close>
 
 lemma path_compression_exact:
   assumes "path_compression_precondition p0 x y"
     and "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y] = p"
   shows "p \<sqinter> 1 = p0 \<sqinter> 1" "fc p = fc p0"
 proof -
   have a1: "disjoint_set_forest p0" and a2: "point x" and a3: "point y" and a4: "y = root p0 x"
     using path_compression_precondition_def assms(1) by auto
   have 1: "regular (p0\<^sup>T\<^sup>\<star> * x)"
     using a1 a2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   have "p \<sqinter> 1 = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<sqinter> 1)"
     using assms(2) inf_sup_distrib2 by auto
   also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<sqinter> 1)"
   proof -
     have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 = p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1"
     proof (rule order.antisym)
       have "(p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * x \<sqinter> 1 \<le> p0"
         by (smt coreflexive_comp_top_inf_one inf.absorb_iff2 inf.cobounded2 inf.sup_monoid.add_assoc root_var)
       hence "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 \<le> p0"
         by (metis inf_le1 a4 conv_dist_inf coreflexive_symmetric inf.absorb2 inf.cobounded2 inf.sup_monoid.add_assoc root_var symmetric_one_closed)
       thus "p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1 \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1"
         by (meson inf.le_sup_iff order.refl)
       have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1 \<le> y"
         by (metis a4 coreflexive_comp_top_inf_one inf.cobounded1 inf_assoc inf_le2)
       thus "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<sqinter> 1 \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T \<sqinter> 1"
         by (smt conv_dist_inf coreflexive_symmetric inf.absorb_iff2 inf.cobounded2 inf.sup_monoid.add_assoc)
     qed
     thus ?thesis
       by simp
   qed
   also have "... = p0 \<sqinter> 1"
     using 1 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show "p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   show "fc p = fc p0"
   proof (rule order.antisym)
     have 2: "univalent (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])"
       by (simp add: a1 a2 a3 update_univalent mult_assoc)
     have 3: "-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using fc_increasing inf.order_trans sup.cobounded2 by blast
     have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<le> (p0\<^sup>T\<^sup>\<star> \<sqinter> p0 * x\<^sup>T) * (x \<sqinter> p0\<^sup>\<star> * p0)"
       by (metis conv_involutive conv_star_commute dedekind)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 * x\<^sup>T * p0\<^sup>\<star> * p0"
       by (metis comp_associative inf.boundedI inf.cobounded2 inf_le1 mult_isotone)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> top * x\<^sup>T * p0\<^sup>\<star>"
       using comp_associative comp_inf.mult_right_isotone mult_isotone star.right_plus_below_circ by auto
     also have "... = p0\<^sup>T\<^sup>\<star> * x * x\<^sup>T * p0\<^sup>\<star>"
       by (metis a2 symmetric_top_closed vector_covector vector_inf_comp vector_mult_closed)
     also have "... \<le> (p0\<^sup>T\<^sup>\<star> * x * y\<^sup>T) * (y * x\<^sup>T * p0\<^sup>\<star>)"
       by (metis a3 order.antisym comp_inf.top_right_mult_increasing conv_involutive dedekind_1 inf.sup_left_divisibility inf.sup_monoid.add_commute mult_right_isotone surjective_conv_total mult_assoc)
     also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (y \<sqinter> x\<^sup>T * p0\<^sup>\<star>)"
       by (metis a2 a3 vector_covector vector_inf_comp vector_mult_closed)
     also have "... = (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T)\<^sup>T"
       by (simp add: conv_dist_comp conv_dist_inf conv_star_commute inf_commute)
     also have "... \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       by (meson conv_isotone dual_order.trans mult_isotone star.circ_increasing sup.cobounded1)
     finally have "p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       .
     hence "(p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 3 le_supI by blast
     hence "p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 1 by (metis inf_commute maddux_3_11_pp)
     hence "fc p0 \<le> (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>\<star> * (p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>y])\<^sup>T\<^sup>\<star>"
       using 2 fc_idempotent fc_isotone by fastforce
     thus "fc p0 \<le> fc p"
       by (simp add: assms(2))
     have "((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0))\<^sup>\<star> = (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
     proof (rule star_sup_2)
       have 4: "transitive (p0\<^sup>T\<^sup>\<star> * x)"
         using a2 comp_associative mult_right_isotone rectangle_star_rectangle by auto
       have "transitive (y\<^sup>T)"
         by (metis a3 conv_dist_comp inf.eq_refl mult_assoc)
       thus "transitive (p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T)"
         using 4 transitive_inf_closed by auto
       have 5: "p0\<^sup>T\<^sup>\<star> * x * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star> * x"
         by (metis a2 mult_right_isotone top_greatest mult_assoc)
       have "(-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>T * y \<le> p0\<^sup>T * y"
         by (simp add: conv_dist_inf mult_left_isotone)
       also have "... \<le> y"
         using a1 a4 root_successor_loop by auto
       finally have "y\<^sup>T * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> y\<^sup>T"
         using conv_dist_comp conv_isotone by fastforce
       thus "(p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) * (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T"
         using 5 comp_left_subdist_inf inf_mono order_trans by blast
     qed
     hence "p\<^sup>\<star> = (-(p0\<^sup>T\<^sup>\<star> * x) \<sqinter> p0)\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
       by (simp add: assms(2))
     also have "... \<le> p0\<^sup>\<star> * ((p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<^sup>T) \<squnion> 1)"
       by (simp add: mult_left_isotone star_isotone)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * x * y\<^sup>T \<squnion> 1)"
       by (simp add: a2 a3 vector_covector vector_mult_closed)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * (x * x\<^sup>T) * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis a4 coreflexive_symmetric inf.cobounded2 root_var comp_associative conv_dist_comp conv_involutive conv_star_commute)
     also have "... \<le> p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * 1 * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis a2 mult_left_isotone mult_right_isotone semiring.add_left_mono sup_commute)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (simp add: a1 cancel_separate_eq mult_right_dist_sup)
     also have "... = p0\<^sup>\<star> * ((p0 \<sqinter> 1) \<squnion> p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (smt univalent_root_successors a1 conv_dist_comp conv_dist_inf coreflexive_idempotent coreflexive_symmetric inf.cobounded2 injective_codomain loop_root root_transitive_successor_loop symmetric_one_closed)
     also have "... = p0\<^sup>\<star> * (p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> 1)"
       by (metis inf.sup_left_divisibility inf_commute sup.left_idem sup_commute sup_relative_same_increasing)
     also have "... \<le> p0\<^sup>\<star> * p0\<^sup>\<star>"
       by (metis inf.cobounded2 inf_commute order.refl order_lesseq_imp star.circ_mult_upper_bound star.circ_reflexive star.circ_transitive_equal sup.boundedI sup_monoid.add_commute)
     also have "... = p0\<^sup>\<star>"
       by (simp add: star.circ_transitive_equal)
     finally show "fc p \<le> fc p0"
       by (metis conv_order conv_star_commute mult_isotone)
   qed
 qed
 
 lemma update_acyclic_6:
   assumes "disjoint_set_forest p"
     and "point x"
   shows "acyclic ((p[p\<^sup>T\<^sup>\<star>*x\<longmapsto>root p x]) - 1)"
   using assms root_point root_successor_loop update_acyclic_2 by auto
 
 theorem path_compression_assign:
   "VARS p
   [ path_compression_precondition p x y \<and> p0 = p ]
   p[p\<^sup>T\<^sup>\<star> * x] := y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
   apply (unfold path_compression_precondition_def path_compression_postcondition_def)
   apply (intro conjI)
   subgoal using update_univalent mult_assoc by auto
   subgoal using bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed update_mapping mult_assoc by auto
   subgoal using update_acyclic_6 by blast
-  subgoal by blast
-  subgoal by blast
-  subgoal by blast
-  subgoal by blast
-  subgoal by blast
-  subgoal by blast
   subgoal by (smt same_root path_compression_exact path_compression_precondition_def update_univalent vector_mult_closed)
   subgoal using path_compression_exact(1) path_compression_precondition_def by blast
   subgoal using path_compression_exact(2) path_compression_precondition_def by blast
   by blast
 
 text \<open>
 We next look at implementing these updates using a loop.
 \<close>
 
 lemma path_compression_1a:
   assumes "point x"
     and "disjoint_set_forest p"
     and "x \<noteq> root p x"
   shows "p\<^sup>T\<^sup>+ * x \<le> - x"
   by (meson assms bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed vector_mult_closed point_in_vector_or_complement_2 loop_root_2)
 
 lemma path_compression_1b:
   "x \<le> p\<^sup>T\<^sup>\<star> * x"
   using mult_left_isotone star.circ_reflexive by fastforce
 
 lemma path_compression_1:
   "path_compression_precondition p x y \<Longrightarrow> path_compression_invariant p x y p x"
   using path_compression_invariant_def path_compression_precondition_def loop_root path_compression_1a path_compression_1b by auto
 
 lemma path_compression_2:
   "path_compression_invariant p x y p0 w \<and> y \<noteq> p[[w]] \<Longrightarrow> path_compression_invariant (p[w\<longmapsto>y]) x y p0 (p[[w]]) \<and> ((p[w\<longmapsto>y])\<^sup>T\<^sup>\<star> * (p[[w]]))\<down> < (p\<^sup>T\<^sup>\<star> * w)\<down>"
 proof -
   let ?p = "p[w\<longmapsto>y]"
   let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * w }"
   let ?t = "{ z . regular z \<and> z \<le> ?p\<^sup>T\<^sup>\<star> * (p[[w]]) }"
   assume 1: "path_compression_invariant p x y p0 w \<and> y \<noteq> p[[w]]"
   have i1: "disjoint_set_forest p" and i2: "point x" and i3: "point y" and i4: "y = root p x"
     using 1 path_compression_invariant_def path_compression_precondition_def by meson+
   have i5: "point w"
     and i8: "p \<sqinter> 1 = p0 \<sqinter> 1" and i9: "fc p = fc p0"
     and i10: "root p w = y" and i12: "p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w\<longmapsto>y] = p"
     using 1 path_compression_invariant_def by blast+
   have i13: "disjoint_set_forest p0" and i15: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
     using 1 path_compression_invariant_def by auto
   have i6: "y \<le> p\<^sup>T\<^sup>\<star> * w"
     using i10 by force
   have i11: "p[[w]] = p0[[w]]"
     by (smt (verit) i12 i2 i5 dual_order.trans inf_le2 p_antitone_iff put_get_different_vector vector_complement_closed vector_inf_closed vector_mult_closed path_compression_1b)
   have i14: "y = root p0 x"
     using i1 i13 i4 i8 i9 same_root by blast
   have 2: "point (p[[w]])"
     using i1 i5 read_point by blast
   show "path_compression_invariant ?p x y p0 (p[[w]]) \<and> card ?t < card ?s"
   proof (unfold path_compression_invariant_def, intro conjI)
     have 3: "mapping ?p"
       by (simp add: i1 i3 i5 bijective_regular update_total update_univalent)
     have 4: "w \<noteq> y"
       using 1 i1 i4 root_successor_loop by blast
     hence 5: "w \<sqinter> y = bot"
       by (simp add: i3 i5 distinct_points)
     hence "y * w\<^sup>T \<le> -1"
       using pseudo_complement schroeder_4_p by auto
     hence "y * w\<^sup>T \<le> p\<^sup>T\<^sup>\<star> - 1"
       using i5 i6 shunt_bijective by auto
     also have "... \<le> p\<^sup>T\<^sup>+"
       by (simp add: star_plus_without_loops)
     finally have 6: "y \<le> p\<^sup>T\<^sup>+ * w"
       using i5 shunt_bijective by auto
     have 7: "w * w\<^sup>T \<le> -p\<^sup>T\<^sup>+"
     proof (rule ccontr)
       assume "\<not> w * w\<^sup>T \<le> -p\<^sup>T\<^sup>+"
       hence "w * w\<^sup>T \<le> --p\<^sup>T\<^sup>+"
         using i5 point_arc arc_in_partition by blast
       hence "w * w\<^sup>T \<le> p\<^sup>T\<^sup>+ \<sqinter> 1"
         using i1 i5 mapping_regular regular_conv_closed regular_closed_star regular_mult_closed by simp
       also have "... = ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> ((p\<^sup>T - 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1)"
         by (metis comp_inf.mult_right_dist_sup maddux_3_11_pp mult_right_dist_sup regular_one_closed)
       also have "... = ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> ((p - 1)\<^sup>+ \<sqinter> 1)\<^sup>T"
         by (metis conv_complement conv_dist_inf conv_plus_commute equivalence_one_closed reachable_without_loops)
       also have "... \<le> ((p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1) \<squnion> (-1 \<sqinter> 1)\<^sup>T"
         by (metis (no_types, opaque_lifting) i1 sup_right_isotone inf.sup_left_isotone conv_isotone)
       also have "... = (p\<^sup>T \<sqinter> 1) * p\<^sup>T\<^sup>\<star> \<sqinter> 1"
         by simp
       also have "... \<le> (p\<^sup>T \<sqinter> 1) * top \<sqinter> 1"
         by (metis comp_inf.comp_isotone coreflexive_comp_top_inf equivalence_one_closed inf.cobounded1 inf.cobounded2)
       also have "... \<le> p\<^sup>T"
         by (simp add: coreflexive_comp_top_inf_one)
       finally have "w * w\<^sup>T \<le> p\<^sup>T"
         by simp
       hence "w \<le> p[[w]]"
         using i5 shunt_bijective by blast
       hence "w = p[[w]]"
         using 2 by (metis i5 epm_3 mult_semi_associative)
       thus False
         using 2 4 i10 loop_root by auto
     qed
     have 10: "acyclic (?p - 1)"
       using i1 i10 i3 i5 inf_le1 update_acyclic_3 by blast
     have "?p[[p\<^sup>T\<^sup>+ * w]] \<le> p\<^sup>T\<^sup>+ * w"
     proof -
       have "(w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>+ * w = y \<sqinter> w\<^sup>T * p\<^sup>T\<^sup>+ * w"
         by (metis i3 inf_vector_comp vector_inf_comp)
       hence "?p[[p\<^sup>T\<^sup>+ * w]] = (y \<sqinter> w\<^sup>T * p\<^sup>T\<^sup>+ * w) \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>+ * w"
         by (simp add: comp_associative conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... \<le> y \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>+ * w"
         using sup_left_isotone by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p\<^sup>T\<^sup>+ * w"
         using mult_left_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> p\<^sup>T\<^sup>+ * w"
         using semiring.add_left_mono mult_left_isotone mult_right_isotone star.left_plus_below_circ by auto
       also have "... = p\<^sup>T\<^sup>+ * w"
         using 6 by (simp add: sup_absorb2)
       finally show ?thesis
         by simp
     qed
     hence 11: "?p\<^sup>T\<^sup>\<star> * (p[[w]]) \<le> p\<^sup>T\<^sup>+ * w"
       using star_left_induct by (simp add: mult_left_isotone star.circ_mult_increasing)
     have 13: "?p[[x]] = y"
     proof (cases "w = x")
       case True
       hence "?p[[x]] = (w\<^sup>T \<sqinter> y) * w \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * w"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... = (w\<^sup>T \<sqinter> y) * w \<squnion> p\<^sup>T * (-w \<sqinter> w)"
         by (metis i5 conv_complement covector_inf_comp_3 inf.sup_monoid.add_commute vector_complement_closed)
       also have "... = (w\<^sup>T \<sqinter> y) * w"
         by simp
       also have "... = y * w"
         by (simp add: i5 covector_inf_comp_3 inf.sup_monoid.add_commute)
       also have "... = y"
         by (metis i3 i5 comp_associative)
       finally show ?thesis
         .
     next
       case False
       hence "\<not> x \<le> p0\<^sup>T\<^sup>\<star> * w"
         using forest_mutually_reachable_2 i13 i15 i2 i5 by blast
       hence "x \<le> - p0\<^sup>T\<^sup>\<star> * w"
         by (metis (mono_tags, lifting) i13 i2 i5 comp_bijective_complement mapping_regular point_in_vector_or_complement regular_closed_star regular_conv_closed vector_mult_closed)
       hence "x \<le> p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w"
         by (simp add: i5 comp_bijective_complement path_compression_1b)
       hence "p[[x]] = y"
         by (smt (verit) i12 i2 i3 i5 comp_bijective_complement put_get_sub vector_inf_comp vector_mult_closed)
       thus "?p[[x]] = y"
         using False i2 i5 put_get_different by blast
     qed
     have 14: "?p\<^sup>T\<^sup>\<star> * x = x \<squnion> y"
     proof (rule order.antisym)
       have "?p\<^sup>T * (x \<squnion> y) = y \<squnion> ?p\<^sup>T * y"
         using 13 by (simp add: mult_left_dist_sup)
       also have "... = y \<squnion> (w\<^sup>T \<sqinter> y) * y \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * y"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup sup_assoc)
       also have "... \<le> y \<squnion> (w\<^sup>T \<sqinter> y) * y \<squnion> p\<^sup>T * y"
         using mult_left_isotone sup_right_isotone by auto
       also have "... = y \<squnion> (w\<^sup>T \<sqinter> y) * y"
         using i1 i10 root_successor_loop sup_commute by auto
       also have "... \<le> y \<squnion> y * y"
         using mult_left_isotone sup_right_isotone by auto
       also have "... = y"
         by (metis i3 comp_associative sup.idem)
       also have "... \<le> x \<squnion> y"
         by simp
       finally show "?p\<^sup>T\<^sup>\<star> * x \<le> x \<squnion> y"
         by (simp add: star_left_induct)
     next
       show "x \<squnion> y \<le> ?p\<^sup>T\<^sup>\<star> * x"
         using 13 by (metis mult_left_isotone star.circ_increasing star.circ_loop_fixpoint sup.boundedI sup_ge2)
     qed
     have 15: "y = root ?p x"
     proof -
       have "(p \<sqinter> 1) * y = (p \<sqinter> 1) * (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
         by (simp add: i4 comp_associative root_var)
       also have "... = (p \<sqinter> 1) * p\<^sup>T\<^sup>\<star> * x"
         using coreflexive_idempotent by auto
       finally have 16: "(p \<sqinter> 1) * y = y"
         by (simp add: i4 root_var)
       have 17: "(p \<sqinter> 1) * x \<le> y"
         by (metis (no_types, lifting) i4 comp_right_one mult_left_isotone mult_right_isotone star.circ_reflexive root_var)
       have "root ?p x = (?p \<sqinter> 1) * (x \<squnion> y)"
         using 14 by (metis mult_assoc root_var)
       also have "... = (w \<sqinter> y\<^sup>T \<sqinter> 1) * (x \<squnion> y) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf_sup_distrib2 semiring.distrib_right)
       also have "... = (w \<sqinter> 1 \<sqinter> y\<^sup>T) * (x \<squnion> y) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf.left_commute inf.sup_monoid.add_commute)
       also have "... = (w \<sqinter> 1) * (y \<sqinter> (x \<squnion> y)) \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: i3 covector_inf_comp_3)
       also have "... = (w \<sqinter> 1) * y \<squnion> (-w \<sqinter> p \<sqinter> 1) * (x \<squnion> y)"
         by (simp add: inf.absorb1)
       also have "... = (w \<sqinter> 1 * y) \<squnion> (-w \<sqinter> (p \<sqinter> 1) * (x \<squnion> y))"
         by (simp add: i5 inf_assoc vector_complement_closed vector_inf_comp)
       also have "... = (w \<sqinter> y) \<squnion> (-w \<sqinter> ((p \<sqinter> 1) * x \<squnion> y))"
         using 16 by (simp add: mult_left_dist_sup)
       also have "... = (w \<sqinter> y) \<squnion> (-w \<sqinter> y)"
         using 17 by (simp add: sup.absorb2)
       also have "... = y"
         using 5 inf.sup_monoid.add_commute le_iff_inf pseudo_complement sup_monoid.add_0_left by fastforce
       finally show ?thesis
         by simp
     qed
     show "path_compression_precondition ?p x y"
       using 3 10 15 i2 i3 path_compression_precondition_def by blast
     show "vector (p[[w]])"
       using 2 by simp
     show "injective (p[[w]])"
       using 2 by simp
     show "surjective (p[[w]])"
       using 2 by simp
     have "w \<sqinter> p \<sqinter> 1 \<le> w \<sqinter> w\<^sup>T \<sqinter> p"
       by (metis inf.boundedE inf.boundedI inf.cobounded1 inf.cobounded2 one_inf_conv)
     also have "... = w * w\<^sup>T \<sqinter> p"
       by (simp add: i5 vector_covector)
     also have "... \<le> -p\<^sup>T\<^sup>+ \<sqinter> p"
       using 7 by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute)
     finally have "w \<sqinter> p \<sqinter> 1 = bot"
       by (metis (no_types, opaque_lifting) conv_dist_inf coreflexive_symmetric inf.absorb1 inf.boundedE inf.cobounded2 pseudo_complement star.circ_mult_increasing)
     also have "w \<sqinter> y\<^sup>T \<sqinter> 1 = bot"
       using 5 antisymmetric_bot_closed asymmetric_bot_closed comp_inf.schroeder_2 inf.absorb1 one_inf_conv by fastforce
     finally have "w \<sqinter> p \<sqinter> 1 = w \<sqinter> y\<^sup>T \<sqinter> 1"
       by simp
     thus 18: "?p \<sqinter> 1 = p0 \<sqinter> 1"
       by (metis i5 i8 bijective_regular inf.sup_monoid.add_commute inf_sup_distrib2 maddux_3_11_pp)
     show 19: "fc ?p = fc p0"
     proof -
       have "p[[w]] = p\<^sup>T * (w \<sqinter> p\<^sup>\<star> * y)"
         by (metis i3 i5 i6 bijective_reverse conv_star_commute inf.absorb1)
       also have "... = p\<^sup>T * (w \<sqinter> p\<^sup>\<star>) * y"
         by (simp add: i5 vector_inf_comp mult_assoc)
       also have "... = p\<^sup>T * ((w \<sqinter> 1) \<squnion> (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star>) * y"
         by (simp add: i5 omit_redundant_points)
       also have "... = p\<^sup>T * (w \<sqinter> 1) * y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (simp add: comp_associative mult_left_dist_sup mult_right_dist_sup)
       also have "... \<le> p\<^sup>T * y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis semiring.add_right_mono comp_isotone order.eq_iff inf.cobounded1 inf.sup_monoid.add_commute mult_1_right)
       also have "... = y \<squnion> p\<^sup>T * (w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         using i1 i4 root_successor_loop by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p * (-w \<sqinter> p)\<^sup>\<star> * y"
         using comp_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis i1 comp_associative eq_refl shunt_mapping sup_right_isotone)
       also have "... = (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 20: "p[[w]] \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         by simp
       have "p\<^sup>T * (-w \<sqinter> p)\<^sup>\<star> * y = p\<^sup>T * y \<squnion> p\<^sup>T * (-w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint sup_commute)
       also have "... = y \<squnion> p\<^sup>T * (-w \<sqinter> p) * (-w \<sqinter> p)\<^sup>\<star> * y"
         using i1 i4 root_successor_loop by auto
       also have "... \<le> y \<squnion> p\<^sup>T * p * (-w \<sqinter> p)\<^sup>\<star> * y"
         using comp_isotone sup_right_isotone by auto
       also have "... \<le> y \<squnion> (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis i1 comp_associative eq_refl shunt_mapping sup_right_isotone)
       also have "... = (-w \<sqinter> p)\<^sup>\<star> * y"
         by (metis star.circ_loop_fixpoint sup.left_idem sup_commute)
       finally have 21: "p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         using 20 by (simp add: comp_associative star_left_induct)
       have "w\<^sup>T \<sqinter> p\<^sup>T = p\<^sup>T * (w\<^sup>T \<sqinter> 1)"
         by (metis i5 comp_right_one covector_inf_comp_3 inf.sup_monoid.add_commute one_inf_conv)
       also have "... \<le> p[[w]]"
         by (metis comp_right_subdist_inf inf.boundedE inf.sup_monoid.add_commute one_inf_conv)
       also have "... \<le> p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
         by (simp add: mult_left_isotone star.circ_mult_increasing_2)
       also have "... \<le> (-w \<sqinter> p)\<^sup>\<star> * y"
         using 21 by simp
       finally have "w \<sqinter> p \<le> y\<^sup>T * (-w \<sqinter> p)\<^sup>T\<^sup>\<star>"
         by (metis conv_dist_comp conv_dist_inf conv_involutive conv_isotone conv_star_commute)
       hence "w \<sqinter> p \<le> (w \<sqinter> y\<^sup>T) * (-w \<sqinter> p)\<^sup>T\<^sup>\<star>"
         by (simp add: i5 vector_inf_comp)
       also have "... \<le> (w \<sqinter> y\<^sup>T) * ?p\<^sup>T\<^sup>\<star>"
         by (simp add: conv_isotone mult_right_isotone star_isotone)
       also have "... \<le> ?p * ?p\<^sup>T\<^sup>\<star>"
         by (simp add: mult_left_isotone)
       also have "... \<le> fc ?p"
         by (simp add: mult_left_isotone star.circ_increasing)
       finally have 22: "w \<sqinter> p \<le> fc ?p"
         by simp
       have "-w \<sqinter> p \<le> ?p"
         by simp
       also have "... \<le> fc ?p"
         by (simp add: fc_increasing)
       finally have "(w \<squnion> -w) \<sqinter> p \<le> fc ?p"
         using 22 by (simp add: comp_inf.semiring.distrib_left inf.sup_monoid.add_commute)
       hence "p \<le> fc ?p"
         by (metis i5 bijective_regular inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
       hence 23: "fc p \<le> fc ?p"
         using 3 fc_idempotent fc_isotone by fastforce
       have "?p \<le> (w \<sqinter> y\<^sup>T) \<squnion> p"
         using sup_right_isotone by auto
       also have "... = w * y\<^sup>T \<squnion> p"
         by (simp add: i3 i5 vector_covector)
       also have "... \<le> p\<^sup>\<star> \<squnion> p"
         by (smt i5 i6 conv_dist_comp conv_involutive conv_isotone conv_star_commute le_supI shunt_bijective star.circ_increasing sup_absorb1)
       also have "... \<le> fc p"
         using fc_increasing star.circ_back_loop_prefixpoint by auto
       finally have "fc ?p \<le> fc p"
         using i1 fc_idempotent fc_isotone by fastforce
       thus ?thesis
         using 23 i9 by auto
     qed
     have 24: "root ?p (p[[w]]) = root p0 (p[[w]])"
       using 3 18 19 i13 same_root by blast
     also have "... = root p0 (p0[[w]])"
       by (simp add: i11)
     also have 25: "... = root p0 w"
       by (metis i5 i13 conv_involutive forest_components_increasing mult_left_isotone shunt_bijective injective_mult_closed read_surjective same_component_same_root)
     finally show 26: "root ?p (p[[w]]) = y"
       by (metis i1 i10 i13 i8 i9 same_root)
     show "univalent p0" "total p0" "acyclic (p0 - 1)"
       by (simp_all add: i13)
     show "p[[w]] \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (metis i11 i15 mult_isotone star.circ_increasing star.circ_transitive_equal mult_assoc)
     let ?q = "p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * (p[[w]])\<longmapsto>y]"
     show "?q = ?p"
     proof -
       have 27: "w \<squnion> p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w"
         using comp_associative star.circ_loop_fixpoint sup_commute by auto
       hence 28: "p0\<^sup>T\<^sup>+ * w = p0\<^sup>T\<^sup>\<star> * w - w"
         using 4 24 25 26 by (metis i11 i13 i5 inf.orderE maddux_3_13 path_compression_1a)
       hence "p0\<^sup>T\<^sup>\<star> * (p[[w]]) \<le> -w"
         by (metis i11 inf_le2 star_plus mult.assoc)
       hence "w \<le> -(p0\<^sup>T\<^sup>\<star> * (p[[w]]))"
         by (simp add: p_antitone_iff)
       hence "w \<le> p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * (p[[w]])"
         by (simp add: i15)
       hence 29: "?q \<sqinter> w = ?p \<sqinter> w"
         by (metis update_inf update_inf_same)
       have 30: "?q \<sqinter> p0\<^sup>T\<^sup>+ * w = ?p \<sqinter> p0\<^sup>T\<^sup>+ * w"
       proof -
         have "?q \<sqinter> p0\<^sup>T\<^sup>+ * w = p0 \<sqinter> p0\<^sup>T\<^sup>+ * w"
           by (metis i11 comp_associative inf.cobounded2 p_antitone_iff star.circ_plus_same update_inf_different)
         also have "... = p \<sqinter> p0\<^sup>T\<^sup>+ * w"
           using 28 by (metis i12 inf.cobounded2 inf.sup_monoid.add_assoc p_antitone_iff update_inf_different)
         also have "... = ?p \<sqinter> p0\<^sup>T\<^sup>+ * w"
           using 28 by (simp add: update_inf_different)
         finally show ?thesis
           .
       qed
       have 31: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * w = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * w"
         using 27 29 30 by (metis inf_sup_distrib1)
       have 32: "?q \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w) = ?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w)"
       proof -
         have "p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w \<le> p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * (p[[w]])"
           using 28 by (metis i11 inf.sup_right_isotone mult.semigroup_axioms p_antitone_inf star_plus semigroup.assoc)
         hence "?q \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w) = y\<^sup>T \<sqinter> p0\<^sup>T\<^sup>\<star> * x \<sqinter> -(p0\<^sup>T\<^sup>\<star> * w)"
           by (metis inf_assoc update_inf)
         also have "... = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w)"
           by (metis i12 inf_assoc update_inf_same)
         also have "... = ?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w)"
           by (simp add: inf.coboundedI2 p_antitone path_compression_1b inf_assoc update_inf_different)
         finally show ?thesis
           .
       qed
       have "p0\<^sup>T\<^sup>\<star> * w \<squnion> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w) = p0\<^sup>T\<^sup>\<star> * x"
       proof -
         have 33: "regular (p0\<^sup>T\<^sup>\<star> * w)"
           using i13 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
         have "p0\<^sup>T\<^sup>\<star> * w \<le> p0\<^sup>T\<^sup>\<star> * x"
           by (metis i15 comp_associative mult_right_isotone star.circ_transitive_equal)
         hence "p0\<^sup>T\<^sup>\<star> * w \<squnion> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w) = p0\<^sup>T\<^sup>\<star> * x \<sqinter> (p0\<^sup>T\<^sup>\<star> * w \<squnion> -(p0\<^sup>T\<^sup>\<star> * w))"
           by (simp add: comp_inf.semiring.distrib_left inf.absorb2)
         also have "... = p0\<^sup>T\<^sup>\<star> * x"
           using 33 by (metis inf_sup_distrib1 maddux_3_11_pp)
         finally show ?thesis
           .
       qed
       hence 34: "?q \<sqinter> p0\<^sup>T\<^sup>\<star> * x = ?p \<sqinter> p0\<^sup>T\<^sup>\<star> * x"
         using 31 32 by (metis inf_sup_distrib1)
       have 35: "regular (p0\<^sup>T\<^sup>\<star> * x)"
         using i13 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
       have "-(p0\<^sup>T\<^sup>\<star> * x) \<le> -w"
         by (simp add: i15 p_antitone)
       hence "?q - p0\<^sup>T\<^sup>\<star> * x = ?p - p0\<^sup>T\<^sup>\<star> * x"
         by (metis i12 p_antitone_inf update_inf_different)
       thus ?thesis
         using 34 35 by (metis maddux_3_11_pp)
     qed
     show "card ?t < card ?s"
     proof -
       have "?p\<^sup>T * p\<^sup>T\<^sup>\<star> * w = (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> (-w\<^sup>T \<sqinter> p\<^sup>T) * p\<^sup>T\<^sup>\<star> * w"
         by (simp add: conv_complement conv_dist_inf conv_dist_sup mult_right_dist_sup)
       also have "... \<le> (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T * p\<^sup>T\<^sup>\<star> * w"
         using mult_left_isotone sup_right_isotone by auto
       also have "... \<le> (w\<^sup>T \<sqinter> y) * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T\<^sup>\<star> * w"
         using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast
       also have "... \<le> y * p\<^sup>T\<^sup>\<star> * w \<squnion> p\<^sup>T\<^sup>\<star> * w"
         using semiring.add_right_mono mult_left_isotone by auto
       also have "... \<le> y * top \<squnion> p\<^sup>T\<^sup>\<star> * w"
         by (simp add: comp_associative le_supI1 mult_right_isotone)
       also have "... = p\<^sup>T\<^sup>\<star> * w"
         by (simp add: i3 i6 sup_absorb2)
       finally have "?p\<^sup>T\<^sup>\<star> * p\<^sup>T * w \<le> p\<^sup>T\<^sup>\<star> * w"
         using 11 by (metis dual_order.trans star.circ_loop_fixpoint sup_commute sup_ge2 mult_assoc)
       hence 36: "?t \<subseteq> ?s"
         using order_lesseq_imp mult_assoc by auto
       have 37: "w \<in> ?s"
         by (simp add: i5 bijective_regular path_compression_1b)
       have 38: "\<not> w \<in> ?t"
       proof
         assume "w \<in> ?t"
         hence 39: "w \<le> (?p\<^sup>T - 1)\<^sup>\<star> * (p[[w]])"
           using reachable_without_loops by auto
         hence "p[[w]] \<le> (?p - 1)\<^sup>\<star> * w"
           using 2 by (smt i5 bijective_reverse conv_star_commute reachable_without_loops)
         also have "... \<le> p\<^sup>\<star> * w"
         proof -
           have "p\<^sup>T\<^sup>\<star> * y = y"
             using i1 i4 root_transitive_successor_loop by auto
           hence "y\<^sup>T * p\<^sup>\<star> * w = y\<^sup>T * w"
             by (metis conv_dist_comp conv_involutive conv_star_commute)
           also have "... = bot"
             using 5 by (metis i5 inf.idem inf.sup_monoid.add_commute mult_left_zero schroeder_1 vector_inf_comp)
           finally have 40: "y\<^sup>T * p\<^sup>\<star> * w = bot"
             by simp
           have "(?p - 1) * p\<^sup>\<star> * w = (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> (-w \<sqinter> p \<sqinter> -1) * p\<^sup>\<star> * w"
             by (simp add: comp_inf.mult_right_dist_sup mult_right_dist_sup)
           also have "... \<le> (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> p * p\<^sup>\<star> * w"
             by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_right_isotone)
           also have "... \<le> (w \<sqinter> y\<^sup>T \<sqinter> -1) * p\<^sup>\<star> * w \<squnion> p\<^sup>\<star> * w"
             using mult_left_isotone star.left_plus_below_circ sup_right_isotone by blast
           also have "... \<le> y\<^sup>T * p\<^sup>\<star> * w \<squnion> p\<^sup>\<star> * w"
             by (meson inf_le1 inf_le2 mult_left_isotone order_trans sup_left_isotone)
           also have "... = p\<^sup>\<star> * w"
             using 40 by simp
           finally show ?thesis
             by (metis comp_associative le_supI star.circ_loop_fixpoint sup_ge2 star_left_induct)
         qed
         finally have "w \<le> p\<^sup>T\<^sup>\<star> * p\<^sup>T * w"
           using 11 39 reachable_without_loops star_plus by auto
         thus False
           using 4 i1 i10 i5 loop_root_2 star.circ_plus_same by auto
       qed
       show "card ?t < card ?s"
         apply (rule psubset_card_mono)
         subgoal using finite_regular by simp
         subgoal using 36 37 38 by auto
         done
     qed
   qed
 qed
 
 lemma path_compression_3a:
   assumes "path_compression_invariant p x (p[[w]]) p0 w"
   shows "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>p[[w]]] = p"
 proof -
   let ?y = "p[[w]]"
   let ?p = "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>?y]"
   have i1: "disjoint_set_forest p" and i2: "point x" and i3: "point ?y" and i4: "?y = root p x"
     using assms path_compression_invariant_def path_compression_precondition_def by meson+
   have i5: "point w"
     and i8: "p \<sqinter> 1 = p0 \<sqinter> 1" and i9: "fc p = fc p0"
     and i10: "root p w = ?y" and i12: "p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w\<longmapsto>?y] = p"
     and i13: "disjoint_set_forest p0" and i15: "w \<le> p0\<^sup>T\<^sup>\<star> * x"
     using assms path_compression_invariant_def by blast+
   have i11: "p[[w]] = p0[[w]]"
     by (smt (verit) i12 i2 i5 dual_order.trans inf_le2 p_antitone_iff put_get_different_vector vector_complement_closed vector_inf_closed vector_mult_closed path_compression_1b)
   have i14: "?y = root p0 x"
     by (metis i1 i13 i4 i8 i9 same_root)
   have 1: "?p \<sqinter> ?y = p \<sqinter> ?y"
     by (metis i1 i14 i3 i4 get_put inf_le1 root_successor_loop update_inf update_inf_same)
   have 2: "?p \<sqinter> w = p \<sqinter> w"
     by (metis i5 i11 i15 get_put update_inf update_inf_same)
   have "?y = root p0 w"
     by (metis i1 i10 i13 i8 i9 same_root)
   hence "p0\<^sup>T\<^sup>\<star> * w = w \<squnion> ?y"
     by (metis i11 i13 root_transitive_successor_loop star.circ_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
   hence 3: "?p \<sqinter> p0\<^sup>T\<^sup>\<star> * w = p \<sqinter> p0\<^sup>T\<^sup>\<star> * w"
     using 1 2 by (simp add: inf_sup_distrib1)
   have "p0\<^sup>T\<^sup>\<star> * w \<le> p0\<^sup>T\<^sup>\<star> * x"
     by (metis i15 comp_associative mult_right_isotone star.circ_transitive_equal)
   hence 4: "?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0\<^sup>T\<^sup>\<star> * w) = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x \<sqinter> p0\<^sup>T\<^sup>\<star> * w)"
     using 3 by (simp add: inf.absorb2)
   have 5: "?p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w) = p \<sqinter> (p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * w)"
     by (metis i12 inf_le1 update_inf update_inf_same)
   have "regular (p0\<^sup>T\<^sup>\<star> * w)"
     using i13 i5 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   hence 6: "?p \<sqinter> p0\<^sup>T\<^sup>\<star> * x = p \<sqinter> p0\<^sup>T\<^sup>\<star> * x"
     using 4 5 by (smt inf_sup_distrib1 maddux_3_11_pp)
   have 7: "?p - p0\<^sup>T\<^sup>\<star> * x = p - p0\<^sup>T\<^sup>\<star> * x"
     by (smt i12 inf.sup_monoid.add_commute inf_import_p inf_sup_absorb le_iff_inf p_dist_inf update_inf_different inf.idem p_antitone_inf)
   have "regular (p0\<^sup>T\<^sup>\<star> * x)"
     using i13 i2 bijective_regular mapping_regular regular_closed_star regular_conv_closed regular_mult_closed by auto
   thus "?p = p"
     using 6 7 by (smt inf_sup_distrib1 maddux_3_11_pp)
 qed
 
 lemma path_compression_3:
   "path_compression_invariant p x (p[[w]]) p0 w \<Longrightarrow> path_compression_postcondition p x (p[[w]]) p0"
   using path_compression_invariant_def path_compression_postcondition_def path_compression_precondition_def path_compression_3a by blast
 
 theorem path_compression:
   "VARS p t w
   [ path_compression_precondition p x y \<and> p0 = p ]
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { (p\<^sup>T\<^sup>\<star> * w)\<down> }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_compression_1)
    apply (fact path_compression_2)
   using path_compression_3 by auto
 
 lemma path_compression_exists:
   "path_compression_precondition p x y \<Longrightarrow> \<exists>p' . path_compression_postcondition p' x y p"
   using tc_extract_function path_compression by blast
 
 definition "path_compression p x y \<equiv> (SOME p' . path_compression_postcondition p' x y p)"
 
 lemma path_compression_function:
   assumes "path_compression_precondition p x y"
     and "p' = path_compression p x y"
   shows "path_compression_postcondition p' x y p"
   by (metis assms path_compression_def path_compression_exists someI)
 
 subsection \<open>Find-Set with Path Compression\<close>
 
 text \<open>
 We sequentially combine find-set and path compression.
 We consider implementations which use the previously derived functions and implementations which unfold their definitions.
 \<close>
 
 theorem find_set_path_compression:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := find_set p x;
   p := path_compression p x y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
   using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by fastforce
 
 theorem find_set_path_compression_1:
   "VARS p t w y
   [ find_set_precondition p x \<and> p0 = p ]
   y := find_set p x;
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { (p\<^sup>T\<^sup>\<star> * w)\<down> }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_1 path_compression_precondition_def apply fastforce
    apply (fact path_compression_2)
   by (fact path_compression_3)
 
 theorem find_set_path_compression_2:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y \<and> p0 = p }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO y := p[[y]]
      OD;
   p := path_compression p x y
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact find_set_1)
    apply (fact find_set_2)
   by (smt find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def)
 
 theorem find_set_path_compression_3:
   "VARS p t w y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { find_set_invariant p x y \<and> p0 = p }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO y := p[[y]]
      OD;
   w := x;
   WHILE y \<noteq> p[[w]]
     INV { path_compression_invariant p x y p0 w }
     VAR { (p\<^sup>T\<^sup>\<star> * w)\<down> }
      DO t := w;
         w := p[[w]];
         p[t] := y
      OD
   [ path_compression_postcondition p x y p0 ]"
   apply vcg_tc_simp
       apply (simp add: find_set_1)
      apply (fact find_set_2)
     using find_set_3 find_set_invariant_def find_set_postcondition_def find_set_precondition_def path_compression_1 path_compression_precondition_def apply blast
    apply (fact path_compression_2)
   by (fact path_compression_3)
 
 text \<open>
 Find-set with path compression returns two results: the representative of the tree and the modified disjoint-set forest.
 \<close>
 
 lemma find_set_path_compression_exists:
   "find_set_precondition p x \<Longrightarrow> \<exists>p' y . path_compression_postcondition p' x y p"
   using tc_extract_function find_set_path_compression by blast
 
 definition "find_set_path_compression p x \<equiv> (SOME (p',y) . path_compression_postcondition p' x y p)"
 
 lemma find_set_path_compression_function:
   assumes "find_set_precondition p x"
     and "(p',y) = find_set_path_compression p x"
   shows "path_compression_postcondition p' x y p"
 proof -
   let ?P = "\<lambda>(p',y) . path_compression_postcondition p' x y p"
   have "?P (SOME z . ?P z)"
     apply (unfold some_eq_ex)
     using assms(1) find_set_path_compression_exists by simp
   thus ?thesis
     using assms(2) find_set_path_compression_def by auto
 qed
 
 text \<open>
 We prove that \<open>find_set_path_compression\<close> returns the same representative as \<open>find_set\<close>.
 \<close>
 
 lemma find_set_path_compression_find_set:
   assumes "find_set_precondition p x"
   shows "find_set p x = snd (find_set_path_compression p x)"
 proof -
   let ?r = "find_set p x"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "find_set_postcondition p x ?r"
     by (simp add: assms find_set_function)
   have "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   thus "?r = ?y"
-    using 1 by (smt assms same_root find_set_precondition_def find_set_postcondition_def path_compression_precondition_def path_compression_postcondition_def)
+    using 1 by (smt assms same_root find_set_precondition_def find_set_postcondition_def path_compression_postcondition_def)
 qed
 
 text \<open>
 A weaker postcondition suffices to prove that the two forests have the same semantics; that is, they describe the same disjoint sets and have the same roots.
 \<close>
 
 lemma find_set_path_compression_path_compression_semantics:
   assumes "find_set_precondition p x"
   shows "fc (path_compression p x (find_set p x)) = fc (fst (find_set_path_compression p x))"
     and "path_compression p x (find_set p x) \<sqinter> 1 = fst (find_set_path_compression p x) \<sqinter> 1"
 proof -
   let ?r = "find_set p x"
   let ?q = "path_compression p x ?r"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "path_compression_postcondition (path_compression p x ?r) x ?r p"
     using assms find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by auto
   have 2: "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   show "fc ?q = fc ?p"
     using 1 2 by (simp add: path_compression_postcondition_def)
   show "?q \<sqinter> 1 = ?p \<sqinter> 1"
     using 1 2 by (simp add: path_compression_postcondition_def)
 qed
 
 text \<open>
 With the current, stronger postcondition of path compression describing the precise effect of how links change, we can prove that the two forests are actually equal.
 \<close>
 
 lemma find_set_path_compression_find_set_pathcompression:
   assumes "find_set_precondition p x"
   shows "path_compression p x (find_set p x) = fst (find_set_path_compression p x)"
 proof -
   let ?r = "find_set p x"
   let ?q = "path_compression p x ?r"
   let ?p = "fst (find_set_path_compression p x)"
   let ?y = "snd (find_set_path_compression p x)"
   have 1: "path_compression_postcondition (path_compression p x ?r) x ?r p"
     using assms find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def by auto
   have 2: "path_compression_postcondition ?p x ?y p"
     using assms find_set_path_compression_function prod.collapse by blast
   have "?r = ?y"
     by (simp add: assms find_set_path_compression_find_set)
   thus "?q = ?p"
-    using 1 2 by (simp add: path_compression_postcondition_def)
+    using 1 2 path_compression_postcondition_def by auto
 qed
 
 subsection \<open>Union-Sets\<close>
 
 text \<open>
 We only consider a naive union-sets operation (without ranks).
 The semantics is the equivalence closure obtained after adding the link between the two given nodes, 
 which requires those two elements to be in the same set.
 The implementation uses temporary variable \<open>t\<close> to store the two results returned by find-set with path compression.
 The disjoint-set forest, which keeps being updated, is threaded through the sequence of operations.
 \<close>
 
 definition "union_sets_precondition p x y \<equiv> disjoint_set_forest p \<and> point x \<and> point y"
-definition "union_sets_postcondition p x y p0 \<equiv> union_sets_precondition p x y \<and> fc p = wcc (p0 \<squnion> x * y\<^sup>T)"
+definition "union_sets_postcondition p x y p0 \<equiv> disjoint_set_forest p \<and> fc p = wcc (p0 \<squnion> x * y\<^sup>T)"
 
 lemma union_sets_1:
   assumes "union_sets_precondition p0 x y"
     and "path_compression_postcondition p1 x r p0"
     and "path_compression_postcondition p2 y s p1"
   shows "union_sets_postcondition (p2[r\<longmapsto>s]) x y p0"
-proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
+proof (unfold union_sets_postcondition_def, intro conjI)
   let ?p = "p2[r\<longmapsto>s]"
   have 1: "disjoint_set_forest p1 \<and> point r \<and> r = root p1 x \<and> p1 \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p1 = fc p0"
-    using assms(2) path_compression_precondition_def path_compression_postcondition_def by auto
+    by (smt (verit) assms(1,2) path_compression_postcondition_def root_point union_sets_precondition_def)
   have 2: "disjoint_set_forest p2 \<and> point s \<and> s = root p2 y \<and> p2 \<sqinter> 1 = p1 \<sqinter> 1 \<and> fc p2 = fc p1"
-    using assms(3) path_compression_precondition_def path_compression_postcondition_def by auto
+    by (smt (verit) assms(1,3) path_compression_postcondition_def root_point union_sets_precondition_def)
   hence 3: "fc p2 = fc p0"
     using 1 by simp
   show 4: "univalent ?p"
     using 1 2 update_univalent by blast
   show "total ?p"
     using 1 2 bijective_regular update_total by blast
   show "acyclic (?p - 1)"
   proof (cases "r = s")
     case True
     thus ?thesis
       using 2 update_acyclic_5 by fastforce
   next
     case False
     hence "bot = r \<sqinter> s"
       using 1 2 distinct_points by blast
     also have "... = r \<sqinter> p2\<^sup>T\<^sup>\<star> * s"
       using 2 by (smt root_transitive_successor_loop)
     finally have "s \<sqinter> p2\<^sup>\<star> * r = bot"
       using schroeder_1 conv_star_commute inf.sup_monoid.add_commute by fastforce
     thus ?thesis
       using 1 2 update_acyclic_4 by blast
   qed
-  show "vector x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "injective x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "surjective x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "vector y"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "injective y"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "surjective y"
-    using assms(1) by (simp add: union_sets_precondition_def)
   show "fc ?p = wcc (p0 \<squnion> x * y\<^sup>T)"
   proof (rule order.antisym)
     have "r = p1[[r]]"
       using 1 by (metis root_successor_loop)
     hence "r * r\<^sup>T \<le> p1\<^sup>T"
       using 1 eq_refl shunt_bijective by blast
     hence "r * r\<^sup>T \<le> p1"
       using 1 conv_order coreflexive_symmetric by fastforce
     hence "r * r\<^sup>T \<le> p1 \<sqinter> 1"
       using 1 inf.boundedI by blast
     also have "... = p2 \<sqinter> 1"
       using 2 by simp
     finally have "r * r\<^sup>T \<le> p2"
       by simp
     hence "r \<le> p2 * r"
       using 1 shunt_bijective by blast
     hence 5: "p2[[r]] \<le> r"
       using 2 shunt_mapping by blast
     have "r \<sqinter> p2 \<le> r * (top \<sqinter> r\<^sup>T * p2)"
       using 1 by (metis dedekind_1)
     also have "... = r * r\<^sup>T * p2"
       by (simp add: mult_assoc)
     also have "... \<le> r * r\<^sup>T"
       using 5 by (metis comp_associative conv_dist_comp conv_involutive conv_order mult_right_isotone)
     also have "... \<le> 1"
       using 1 by blast
     finally have 6: "r \<sqinter> p2 \<le> 1"
       by simp
     have "p0 \<le> wcc p0"
       by (simp add: star.circ_sub_dist_1)
     also have "... = wcc p2"
       using 3 by (simp add: star_decompose_1)
     also have 7: "... \<le> wcc ?p"
     proof -
       have "wcc p2 = wcc ((-r \<sqinter> p2) \<squnion> (r \<sqinter> p2))"
         using 1 by (metis bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
       also have "... \<le> wcc ((-r \<sqinter> p2) \<squnion> 1)"
         using 6 wcc_isotone sup_right_isotone by simp
       also have "... = wcc (-r \<sqinter> p2)"
         using wcc_with_loops by simp
       also have "... \<le> wcc ?p"
         using wcc_isotone sup_ge2 by blast
       finally show ?thesis
         by simp
     qed
     finally have 8: "p0 \<le> wcc ?p"
       by force
     have "r \<le> p1\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis inf_le1)
     hence 9: "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "x * r\<^sup>T \<le> p1\<^sup>\<star>"
       using conv_dist_comp conv_order conv_star_commute by force
     also have "... \<le> wcc p1"
       by (simp add: star.circ_sub_dist)
     also have "... = wcc p2"
       using 1 2 by (simp add: fc_wcc)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 10: "x * r\<^sup>T \<le> wcc ?p"
       by simp
     have 11: "r * s\<^sup>T \<le> wcc ?p"
       using 1 2 star.circ_sub_dist_1 sup_assoc vector_covector by auto
     have "s \<le> p2\<^sup>T\<^sup>\<star> * y"
       using 2 by (metis inf_le1)
     hence 12: "s * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     also have "... \<le> wcc p2"
       using star_isotone sup_ge2 by blast
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 13: "s * y\<^sup>T \<le> wcc ?p"
       by simp
     have "x \<le> x * r\<^sup>T * r \<and> y \<le> y * s\<^sup>T * s"
       using 1 2 shunt_bijective by blast
     hence "x * y\<^sup>T \<le> x * r\<^sup>T * r * (y * s\<^sup>T * s)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = x * r\<^sup>T * r * s\<^sup>T * s * y\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc ?p * (r * s\<^sup>T) * (s * y\<^sup>T)"
       using 10 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc ?p * wcc ?p * (s * y\<^sup>T)"
       using 11 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc ?p * wcc ?p * wcc ?p"
       using 13 by (metis mult_right_isotone)
     also have "... = wcc ?p"
       by (simp add: star.circ_transitive_equal)
     finally have "p0 \<squnion> x * y\<^sup>T \<le> wcc ?p"
       using 8 by simp
     hence "wcc (p0 \<squnion> x * y\<^sup>T) \<le> wcc ?p"
       using wcc_below_wcc by simp
     thus "wcc (p0 \<squnion> x * y\<^sup>T) \<le> fc ?p"
       using 4 fc_wcc by simp
     have "-r \<sqinter> p2 \<le> wcc p2"
       by (simp add: inf.coboundedI2 star.circ_sub_dist_1)
     also have "... = wcc p0"
       using 3 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 14: "-r \<sqinter> p2 \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by simp
     have "r * x\<^sup>T \<le> wcc p1"
       using 9 inf.order_trans star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 1 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 15: "r * x\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by simp
     have 16: "x * y\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using le_supE star.circ_sub_dist_1 by blast
     have "y * s\<^sup>T \<le> p2\<^sup>\<star>"
       using 12 conv_dist_comp conv_order conv_star_commute by fastforce
     also have "... \<le> wcc p2"
       using star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 3 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 17: "y * s\<^sup>T \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       by simp
     have "r \<le> r * x\<^sup>T * x \<and> s \<le> s * y\<^sup>T * y"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "r * s\<^sup>T \<le> r * x\<^sup>T * x * (s * y\<^sup>T * y)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = r * x\<^sup>T * x * y\<^sup>T * y * s\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * (x * y\<^sup>T) * (y * s\<^sup>T)"
       using 15 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T) * (y * s\<^sup>T)"
       using 16 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T) * wcc (p0 \<squnion> x * y\<^sup>T)"
       using 17 by (metis mult_right_isotone)
     also have "... = wcc (p0 \<squnion> x * y\<^sup>T)"
       by (simp add: star.circ_transitive_equal)
     finally have "?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 1 2 14 vector_covector by auto
     hence "wcc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using wcc_below_wcc by blast
     thus "fc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 4 fc_wcc by simp
   qed
 qed
 
 theorem union_sets:
   "VARS p r s t
   [ union_sets_precondition p x y \<and> p0 = p ]
   t := find_set_path_compression p x;
   p := fst t;
   r := snd t;
   t := find_set_path_compression p y;
   p := fst t;
   s := snd t;
   p[r] := s
   [ union_sets_postcondition p x y p0 ]"
 proof vcg_tc_simp
   let ?t1 = "find_set_path_compression p0 x"
   let ?p1 = "fst ?t1"
   let ?r = "snd ?t1"
   let ?t2 = "find_set_path_compression ?p1 y"
   let ?p2 = "fst ?t2"
   let ?s = "snd ?t2"
   let ?p = "?p2[?r\<longmapsto>?s]"
   assume 1: "union_sets_precondition p0 x y"
   hence 2: "path_compression_postcondition ?p1 x ?r p0"
     by (simp add: find_set_precondition_def union_sets_precondition_def find_set_path_compression_function)
   hence "path_compression_postcondition ?p2 y ?s ?p1"
-    using 1 by (meson find_set_precondition_def union_sets_precondition_def find_set_path_compression_function path_compression_postcondition_def path_compression_precondition_def prod.collapse)
+    using 1 by (meson find_set_precondition_def union_sets_precondition_def find_set_path_compression_function path_compression_postcondition_def prod.collapse)
   thus "union_sets_postcondition (?p2[?r\<longmapsto>?s]) x y p0"
     using 1 2 by (simp add: union_sets_1)
 qed
 
 lemma union_sets_exists:
   "union_sets_precondition p x y \<Longrightarrow> \<exists>p' . union_sets_postcondition p' x y p"
   using tc_extract_function union_sets by blast
 
 definition "union_sets p x y \<equiv> (SOME p' . union_sets_postcondition p' x y p)"
 
 lemma union_sets_function:
   assumes "union_sets_precondition p x y"
     and "p' = union_sets p x y"
   shows "union_sets_postcondition p' x y p"
   by (metis assms union_sets_def union_sets_exists someI)
 
 theorem union_sets_2:
   "VARS p r s
   [ union_sets_precondition p x y \<and> p0 = p ]
   r := find_set p x;
   p := path_compression p x r;
   s := find_set p y;
   p := path_compression p y s;
   p[r] := s
   [ union_sets_postcondition p x y p0 ]"
 proof vcg_tc_simp
   let ?r = "find_set p0 x"
   let ?p1 = "path_compression p0 x ?r"
   let ?s = "find_set ?p1 y"
   let ?p2 = "path_compression ?p1 y ?s"
   assume 1: "union_sets_precondition p0 x y"
   hence 2: "path_compression_postcondition ?p1 x ?r p0"
     using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def by auto
   hence "path_compression_postcondition ?p2 y ?s ?p1"
     using 1 find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def path_compression_postcondition_def by meson
   thus "union_sets_postcondition (?p2[?r\<longmapsto>?s]) x y p0"
     using 1 2 by (simp add: union_sets_1)
 qed
 
 end
 
 end
 
diff --git a/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy b/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
--- a/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
+++ b/thys/Relational_Disjoint_Set_Forests/More_Disjoint_Set_Forests.thy
@@ -1,3117 +1,3096 @@
 (* Title:      More on Disjoint-Set Forests
    Author:     Walter Guttmann
    Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
 *)
 
 theory More_Disjoint_Set_Forests
 
 imports Disjoint_Set_Forests
 
 begin
 
 section \<open>More on Array Access and Disjoint-Set Forests\<close>
 
 text \<open>
 This section contains further results about directed acyclic graphs and relational array operations.
 \<close>
 
 context stone_relation_algebra
 begin
 
 lemma update_square:
   assumes "point y"
     shows "x[y\<longmapsto>x[[x[[y]]]]] \<le> x * x \<squnion> x"
 proof -
   have "x[y\<longmapsto>x[[x[[y]]]]] = (y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... \<le> (y \<sqinter> y\<^sup>T) * x * x \<squnion> x"
     by (smt assms inf.eq_refl inf.sup_monoid.add_commute inf_le1 sup_mono vector_inf_comp)
   also have "... \<le> x * x \<squnion> x"
     by (smt (z3) assms comp_associative conv_dist_comp coreflexive_comp_top_inf inf.cobounded2 sup_left_isotone symmetric_top_closed)
   finally show ?thesis
     .
 qed
 
 lemma update_ub:
   "x[y\<longmapsto>z] \<le> x \<squnion> z\<^sup>T"
   by (meson dual_order.trans inf.cobounded2 le_supI sup.cobounded1 sup_ge2)
 
 lemma update_square_ub:
   "x[y\<longmapsto>(x * x)\<^sup>T] \<le> x \<squnion> x * x"
   by (metis conv_involutive update_ub)
 
 lemma update_same_sub:
   assumes "u \<sqinter> x = u \<sqinter> z"
       and "y \<le> u"
       and "regular y"
     shows "x[y\<longmapsto>z\<^sup>T] = x"
   by (smt (z3) assms conv_involutive inf.sup_monoid.add_commute inf.sup_relative_same_increasing maddux_3_11_pp)
 
 lemma update_point_get:
   "point y \<Longrightarrow> x[y\<longmapsto>z[[y]]] = x[y\<longmapsto>z\<^sup>T]"
   by (metis conv_involutive get_put inf_commute update_inf_same)
 
 lemma update_bot:
   "x[bot\<longmapsto>z] = x"
   by simp
 
 lemma update_top:
   "x[top\<longmapsto>z] = z\<^sup>T"
   by simp
 
 lemma update_same:
   assumes "regular u"
     shows "(x[y\<longmapsto>z])[u\<longmapsto>z] = x[y \<squnion> u\<longmapsto>z]"
 proof -
   have "(x[y\<longmapsto>z])[u\<longmapsto>z] = (u \<sqinter> z\<^sup>T) \<squnion> (-u \<sqinter> y \<sqinter> z\<^sup>T) \<squnion> (-u \<sqinter> -y \<sqinter> x)"
     using inf.sup_monoid.add_assoc inf_sup_distrib1 sup_assoc by force
   also have "... = (u \<sqinter> z\<^sup>T) \<squnion> (y \<sqinter> z\<^sup>T) \<squnion> (-(u \<squnion> y) \<sqinter> x)"
     by (metis assms inf_sup_distrib2 maddux_3_21_pp p_dist_sup)
   also have "... = x[y \<squnion> u\<longmapsto>z]"
     using comp_inf.mult_right_dist_sup sup_commute by auto
   finally show ?thesis
     .
 qed
 
 lemma update_same_3:
   assumes "regular u"
       and "regular v"
     shows "((x[y\<longmapsto>z])[u\<longmapsto>z])[v\<longmapsto>z] = x[y \<squnion> u \<squnion> v\<longmapsto>z]"
   by (metis assms update_same)
 
 lemma update_split:
   assumes "regular w"
     shows "x[y\<longmapsto>z] = (x[y - w\<longmapsto>z])[y \<sqinter> w\<longmapsto>z]"
   by (smt (z3) assms comp_inf.semiring.distrib_left inf.left_commute inf.sup_monoid.add_commute inf_import_p maddux_3_11_pp maddux_3_12 p_dist_inf sup_assoc)
 
 lemma update_injective_swap:
   assumes "injective x"
       and "point y"
       and "injective z"
       and "vector z"
     shows "injective ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
 proof -
   have 1: "(z \<sqinter> y\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using assms(3) injective_inf_closed by auto
   have "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> (z \<sqinter> y\<^sup>T * x) * (y\<^sup>T \<sqinter> x\<^sup>T * z)"
     by (metis conv_dist_comp conv_involutive conv_order inf.boundedE inf.boundedI inf.cobounded1 inf.cobounded2 mult_right_isotone)
   also have "... = (z \<sqinter> z\<^sup>T * x) * (y\<^sup>T \<sqinter> x\<^sup>T * y)"
     by (smt (z3) assms(2,4) covector_inf_comp_3 inf.left_commute inf.sup_monoid.add_commute comp_associative conv_dist_comp conv_involutive)
   also have "... = (z \<sqinter> z\<^sup>T) * x * x\<^sup>T * (y \<sqinter> y\<^sup>T)"
     by (smt (z3) assms(2,4) comp_associative inf.sup_monoid.add_commute vector_covector vector_inf_comp)
   also have "... \<le> x * x\<^sup>T"
     by (metis assms(2-4) comp_associative comp_right_one coreflexive_comp_top_inf inf.coboundedI2 mult_right_isotone vector_covector)
   also have "... \<le> 1"
     by (simp add: assms(1))
   finally have 2: "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     .
   have "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> y\<^sup>T * x * (-y\<^sup>T \<sqinter> x\<^sup>T)"
     by (smt comp_isotone conv_complement conv_dist_inf inf.cobounded2 inf.sup_monoid.add_assoc)
   also have "... = y\<^sup>T * x * x\<^sup>T \<sqinter> -y\<^sup>T"
     by (simp add: inf.commute assms(2) covector_comp_inf vector_conv_compl)
   also have "... \<le> y\<^sup>T \<sqinter> -y\<^sup>T"
     by (metis assms(1) comp_associative comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
   finally have 3: "(z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using pseudo_complement by fastforce
   have 4: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using 2 conv_dist_comp conv_order by force
   have 5: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     by (simp add: assms(2) inf_assoc inf_left_commute injective_inf_closed)
   have "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> z\<^sup>T * x * (-z\<^sup>T \<sqinter> x\<^sup>T)"
     using comp_inf.mult_left_isotone comp_isotone conv_complement conv_dist_inf inf.cobounded1 inf.cobounded2 by auto
   also have "... = z\<^sup>T * x * x\<^sup>T \<sqinter> -z\<^sup>T"
     by (metis assms(4) covector_comp_inf inf.sup_monoid.add_commute vector_conv_compl)
   also have "... \<le> z\<^sup>T \<sqinter> -z\<^sup>T"
     by (metis assms(1) comp_associative comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
   finally have 6: "(-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using pseudo_complement by fastforce
   have 7: "(-z \<sqinter> -y \<sqinter> x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<le> 1"
     using 3 conv_dist_comp coreflexive_symmetric by fastforce
   have 8: "(-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<le> 1"
     using 6 conv_dist_comp coreflexive_symmetric by fastforce
   have 9: "(-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<le> 1"
     using assms(1) inf.sup_monoid.add_commute injective_inf_closed by auto
   have "(x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]] = (z \<sqinter> y\<^sup>T * x) \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) \<squnion> (-z \<sqinter> -y \<sqinter> x)"
     by (simp add: comp_inf.comp_left_dist_sup conv_dist_comp inf_assoc sup_monoid.add_assoc)
   hence "((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]]) * ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])\<^sup>T = ((z \<sqinter> y\<^sup>T * x) \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) \<squnion> (-z \<sqinter> -y \<sqinter> x)) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T)"
     by (simp add: conv_dist_sup)
   also have "... = (z \<sqinter> y\<^sup>T * x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T) \<squnion>
                    (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T) \<squnion>
                    (-z \<sqinter> -y \<sqinter> x) * ((z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x)\<^sup>T)"
     using mult_right_dist_sup by auto
   also have "... = (z \<sqinter> y\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (z \<sqinter> y\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<squnion>
                    (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> y \<sqinter> z\<^sup>T * x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T \<squnion>
                    (-z \<sqinter> -y \<sqinter> x) * (z \<sqinter> y\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> y \<sqinter> z\<^sup>T * x)\<^sup>T \<squnion> (-z \<sqinter> -y \<sqinter> x) * (-z \<sqinter> -y \<sqinter> x)\<^sup>T"
     using mult_left_dist_sup sup.left_commute sup_commute by auto
   also have "... \<le> 1"
     using 1 2 3 4 5 6 7 8 9 by simp_all
   finally show ?thesis
     .
 qed
 
 lemma update_injective_swap_2:
   assumes "injective x"
     shows "injective ((x[y\<longmapsto>x[[bot]]])[bot\<longmapsto>x[[y]]])"
   by (simp add: assms inf.sup_monoid.add_commute injective_inf_closed)
 
 lemma update_univalent_swap:
   assumes "univalent x"
       and "injective y"
       and "vector y"
       and "injective z"
       and "vector z"
     shows "univalent ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
   by (simp add: assms read_injective update_univalent)
 
 lemma update_mapping_swap:
   assumes "mapping x"
       and "point y"
       and "point z"
     shows "mapping ((x[y\<longmapsto>x[[z]]])[z\<longmapsto>x[[y]]])"
   by (simp add: assms bijective_regular read_injective read_surjective update_total update_univalent)
 
 text \<open>lemma \<open>mapping_inf_point_arc\<close> has been moved to theory \<open>Relation_Algebras\<close> in entry \<open>Stone_Relation_Algebras\<close>\<close>
 
 end
 
 context stone_kleene_relation_algebra
 begin
 
 lemma omit_redundant_points_2:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
 proof -
   let ?p = "p \<sqinter> 1"
   let ?np = "-p \<sqinter> 1"
   have 1: "p \<sqinter> x\<^sup>\<star> \<sqinter> 1 = p \<sqinter> 1"
     by (metis inf.le_iff_sup inf.left_commute inf.sup_monoid.add_commute star.circ_reflexive)
   have 2: "p \<sqinter> 1 \<sqinter> -p\<^sup>T = bot"
     by (smt (z3) inf_bot_right inf_commute inf_left_commute one_inf_conv p_inf)
   have "p \<sqinter> x\<^sup>\<star> \<sqinter> -1 = p \<sqinter> x\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms antisymmetric_inf_diversity inf.cobounded1 inf.sup_relative_same_increasing vector_covector)
   also have "... = (p \<sqinter> 1 \<sqinter> -p\<^sup>T) \<squnion> ((p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T)"
     by (simp add: assms omit_redundant_points comp_inf.semiring.distrib_right)
   also have "... = (p \<sqinter> x) * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     using 2 by simp
   also have "... = ?p * x * (-p \<sqinter> x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms vector_export_comp_unit)
   also have "... = ?p * x * (?np * x)\<^sup>\<star> \<sqinter> -p\<^sup>T"
     by (metis assms vector_complement_closed vector_export_comp_unit)
   also have "... = ?p * x * (?np * x)\<^sup>\<star> * ?np"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = ?p * x * ?np * (x * ?np)\<^sup>\<star>"
     using star_slide mult_assoc by auto
   also have "... = (?p * x \<sqinter> -p\<^sup>T) * (x * ?np)\<^sup>\<star>"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = (?p * x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
     by (metis assms conv_complement covector_comp_inf inf.sup_monoid.add_commute mult_1_right one_inf_conv vector_conv_compl)
   also have "... = (p \<sqinter> x \<sqinter> -p\<^sup>T) * (x \<sqinter> -p\<^sup>T)\<^sup>\<star>"
     by (metis assms vector_export_comp_unit)
   finally show ?thesis
     using 1 by (metis maddux_3_11_pp regular_one_closed)
 qed
 
 lemma omit_redundant_points_3:
   assumes "point p"
   shows "p \<sqinter> x\<^sup>\<star> = (p \<sqinter> 1) \<squnion> (p \<sqinter> (x \<sqinter> -p\<^sup>T)\<^sup>+)"
   by (simp add: assms inf_assoc vector_inf_comp omit_redundant_points_2)
 
 lemma even_odd_root:
   assumes "acyclic (x - 1)"
       and "regular x"
       and "univalent x"
     shows "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> = (1 \<sqinter> x) * ((x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star>)"
 proof -
   have 1: "univalent (x * x)"
     by (simp add: assms(3) univalent_mult_closed)
   have "x \<sqinter> 1 \<le> top * (x \<sqinter> 1)"
     by (simp add: top_left_mult_increasing)
   hence "x \<sqinter> -(top * (x \<sqinter> 1)) \<le> x - 1"
     using assms(2) p_shunting_swap pp_dist_comp by auto
   hence "x\<^sup>\<star> * (x \<sqinter> -(top * (x \<sqinter> 1))) \<le> (x - 1)\<^sup>\<star> * (x - 1)"
     using mult_right_isotone reachable_without_loops by auto
   also have "... \<le> -1"
     by (simp add: assms(1) star_plus)
   finally have "(x \<sqinter> -(top * (x \<sqinter> 1)))\<^sup>T \<le> -x\<^sup>\<star>"
     using schroeder_4_p by force
   hence "x\<^sup>T \<sqinter> x\<^sup>\<star> \<le> (top * (x \<sqinter> 1))\<^sup>T"
     by (smt (z3) assms(2) conv_complement conv_dist_inf p_shunting_swap regular_closed_inf regular_closed_top regular_mult_closed regular_one_closed)
   also have "... = (1 \<sqinter> x) * top"
     by (metis conv_dist_comp conv_dist_inf inf_commute one_inf_conv symmetric_one_closed symmetric_top_closed)
   finally have 2: "(x\<^sup>T \<sqinter> x\<^sup>\<star>) * top \<le> (1 \<sqinter> x) * top"
     by (metis inf.orderE inf.orderI inf_commute inf_vector_comp)
   have "1 \<sqinter> x\<^sup>T\<^sup>+ \<le> (x\<^sup>T \<sqinter> 1 * x\<^sup>\<star>) * x\<^sup>T\<^sup>\<star>"
     by (metis conv_involutive conv_star_commute dedekind_2 inf_commute)
   also have "... \<le> (x\<^sup>T \<sqinter> x\<^sup>\<star>) * top"
     by (simp add: mult_right_isotone)
   also have "... \<le> (1 \<sqinter> x) * top"
     using 2 by simp
   finally have 3: "1 \<sqinter> x\<^sup>T\<^sup>+ \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+ = 1 * x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> * x\<^sup>T * x\<^sup>T"
     using star_plus mult_assoc by auto
   also have "... = (1 \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> * x\<^sup>T) * x\<^sup>T"
     using assms(3) injective_comp_right_dist_inf by force
   also have "... \<le> (1 \<sqinter> x\<^sup>T\<^sup>\<star> * x\<^sup>T) * x\<^sup>T"
     by (meson comp_inf.mult_right_isotone comp_isotone inf.eq_refl star.circ_square)
   also have "... \<le> (1 \<sqinter> x) * top * x\<^sup>T"
     using 3 by (simp add: mult_left_isotone star_plus)
   also have "... \<le> (1 \<sqinter> x) * top"
     by (simp add: comp_associative mult_right_isotone)
   finally have 4: "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+ \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> = (x\<^sup>T \<sqinter> 1) \<squnion> (x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>+)"
     by (metis inf_sup_distrib1 star_left_unfold_equal)
   also have "... \<le> (1 \<sqinter> x) * top"
     using 4 by (metis inf.sup_monoid.add_commute le_supI one_inf_conv top_right_mult_increasing)
   finally have 4: "x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star> \<le> (1 \<sqinter> x) * top"
     .
   have "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1 \<le> x\<^sup>T \<sqinter> x\<^sup>\<star> \<sqinter> -1"
     by (simp add: inf.coboundedI2 inf.sup_monoid.add_commute star.circ_square)
   also have "... = (x - 1)\<^sup>\<star> \<sqinter> (x - 1)\<^sup>T"
     using conv_complement conv_dist_inf inf_assoc inf_left_commute reachable_without_loops symmetric_one_closed by auto
   also have "... = bot"
     using assms(1) acyclic_star_below_complement_1 by auto
   finally have 5: "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1 = bot"
     by (simp add: le_bot)
   have "x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> = (x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> 1) \<squnion> (x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> -1)"
     by (metis maddux_3_11_pp regular_one_closed)
   also have "... = x\<^sup>T \<sqinter> (x * x)\<^sup>\<star> \<sqinter> 1"
     using 5 by simp
   also have "... = x\<^sup>T \<sqinter> 1"
     by (metis calculation comp_inf.semiring.distrib_left inf.sup_monoid.add_commute star.circ_transitive_equal star_involutive star_left_unfold_equal sup_inf_absorb)
   finally have "(x\<^sup>T \<sqinter> (x * x)\<^sup>\<star>) \<squnion> (x\<^sup>T \<sqinter> (x\<^sup>T * x\<^sup>T)\<^sup>\<star>) \<le> (1 \<sqinter> x) * top"
     using 4 inf.sup_monoid.add_commute one_inf_conv top_right_mult_increasing by auto
   hence "x\<^sup>T \<sqinter> ((x * x)\<^sup>\<star> \<squnion> (x * x)\<^sup>T\<^sup>\<star>) \<le> (1 \<sqinter> x) * top"
     by (simp add: comp_inf.semiring.distrib_left conv_dist_comp)
   hence 6: "x\<^sup>T \<sqinter> (x * x)\<^sup>T\<^sup>\<star> * (x * x)\<^sup>\<star> \<le> (1 \<sqinter> x) * top"
     using 1 by (simp add: cancel_separate_eq sup_commute)
   have "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> \<le> (x\<^sup>T \<sqinter> (x * x)\<^sup>T\<^sup>\<star> * (x * x)\<^sup>\<star>) * (x * x)\<^sup>T\<^sup>\<star>"
     by (metis conv_involutive conv_star_commute dedekind_2 inf_commute)
   also have "... \<le> (1 \<sqinter> x) * top * (x * x)\<^sup>T\<^sup>\<star>"
     using 6 by (simp add: mult_left_isotone)
   also have "... = (1 \<sqinter> x) * top"
     by (simp add: comp_associative star.circ_left_top)
   finally have "(x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> = (x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star> \<sqinter> (1 \<sqinter> x) * top"
     using inf.order_iff by auto
   also have "... = (1 \<sqinter> x) * ((x * x)\<^sup>T\<^sup>\<star> \<sqinter> x\<^sup>T * (x * x)\<^sup>T\<^sup>\<star>)"
     by (metis coreflexive_comp_top_inf inf.cobounded1 inf.sup_monoid.add_commute)
   finally show ?thesis
     .
 qed
 
 lemma update_square_plus:
   "point y \<Longrightarrow> x[y\<longmapsto>x[[x[[y]]]]] \<le> x\<^sup>+"
   by (meson update_square comp_isotone dual_order.trans le_supI order_refl star.circ_increasing star.circ_mult_increasing)
 
 lemma update_square_ub_plus:
   "x[y\<longmapsto>(x * x)\<^sup>T] \<le> x\<^sup>+"
   by (simp add: comp_isotone inf.coboundedI2 star.circ_increasing star.circ_mult_increasing)
 
 lemma acyclic_square:
   assumes "acyclic (x - 1)"
     shows "x * x \<sqinter> 1 = x \<sqinter> 1"
 proof (rule order.antisym)
   have "1 \<sqinter> x * x = 1 \<sqinter> ((x - 1) * x \<squnion> (x \<sqinter> 1) * x)"
     by (metis maddux_3_11_pp regular_one_closed semiring.distrib_right)
   also have "... \<le> 1 \<sqinter> ((x - 1) * x \<squnion> x)"
     by (metis inf.cobounded2 mult_1_left mult_left_isotone inf.sup_right_isotone semiring.add_left_mono)
   also have "... = 1 \<sqinter> ((x - 1) * (x - 1) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x)"
     by (metis maddux_3_11_pp mult_left_dist_sup regular_one_closed)
   also have "... \<le> (1 \<sqinter> (x - 1) * (x - 1)) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis inf_le2 inf_sup_distrib1 semiring.add_left_mono sup_monoid.add_assoc)
   also have "... \<le> (1 \<sqinter> (x - 1)\<^sup>+) \<squnion> (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis comp_isotone inf.eq_refl inf.sup_right_isotone star.circ_increasing sup_monoid.add_commute sup_right_isotone)
   also have "... = (x - 1) * (x \<sqinter> 1) \<squnion> x"
     by (metis assms inf.le_iff_sup inf.sup_monoid.add_commute inf_import_p inf_p regular_one_closed sup_inf_absorb sup_monoid.add_commute)
   also have "... = x"
     by (metis comp_isotone inf.cobounded1 inf_le2 mult_1_right sup.absorb2)
   finally show "x * x \<sqinter> 1 \<le> x \<sqinter> 1"
     by (simp add: inf.sup_monoid.add_commute)
   show "x \<sqinter> 1 \<le> x * x \<sqinter> 1"
     by (metis coreflexive_idempotent inf_le1 inf_le2 le_infI mult_isotone)
 qed
 
 lemma diagonal_update_square_aux:
   assumes "acyclic (x - 1)"
       and "point y"
     shows "1 \<sqinter> y \<sqinter> y\<^sup>T * x * x = 1 \<sqinter> y \<sqinter> x"
 proof -
   have 1: "1 \<sqinter> y \<sqinter> x \<le> y\<^sup>T * x * x"
     by (metis comp_isotone coreflexive_idempotent inf.boundedE inf.cobounded1 inf.cobounded2 one_inf_conv)
   have "1 \<sqinter> y \<sqinter> y\<^sup>T * x * x = 1 \<sqinter> (y \<sqinter> y\<^sup>T) * x * x"
     by (simp add: assms(2) inf.sup_monoid.add_assoc vector_inf_comp)
   also have "... = 1 \<sqinter> (y \<sqinter> 1) * x * x"
     by (metis assms(2) inf.cobounded1 inf.sup_monoid.add_commute inf.sup_same_context one_inf_conv vector_covector)
   also have "... \<le> 1 \<sqinter> x * x"
     by (metis comp_left_subdist_inf inf.sup_right_isotone le_infE mult_left_isotone mult_left_one)
   also have "... \<le> x"
     using assms(1) acyclic_square inf.sup_monoid.add_commute by auto
   finally show ?thesis
     using 1 by (metis inf.absorb2 inf.left_commute inf.sup_monoid.add_commute)
 qed
 
 lemma diagonal_update_square:
   assumes "acyclic (x - 1)"
       and "point y"
     shows "(x[y\<longmapsto>x[[x[[y]]]]]) \<sqinter> 1 = x \<sqinter> 1"
 proof -
   let ?xy = "x[[y]]"
   let ?xxy = "x[[?xy]]"
   let ?xyxxy = "x[y\<longmapsto>?xxy]"
   have "?xyxxy \<sqinter> 1 = ((y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)) \<sqinter> 1"
     by (simp add: conv_dist_comp)
   also have "... = (y \<sqinter> y\<^sup>T * x * x \<sqinter> 1) \<squnion> (-y \<sqinter> x \<sqinter> 1)"
     by (simp add: inf_sup_distrib2)
   also have "... = (y \<sqinter> x \<sqinter> 1) \<squnion> (-y \<sqinter> x \<sqinter> 1)"
     using assms by (smt (verit, ccfv_threshold) diagonal_update_square_aux find_set_precondition_def inf_assoc inf_commute)
   also have "... = x \<sqinter> 1"
     by (metis assms(2) bijective_regular comp_inf.mult_right_dist_sup inf.sup_monoid.add_commute maddux_3_11_pp)
   finally show ?thesis
     .
 qed
 
 lemma fc_update_square:
   assumes "mapping x"
       and "point y"
     shows "fc (x[y\<longmapsto>x[[x[[y]]]]]) = fc x"
 proof (rule order.antisym)
   let ?xy = "x[[y]]"
   let ?xxy = "x[[?xy]]"
   let ?xyxxy = "x[y\<longmapsto>?xxy]"
   have 1: "y \<sqinter> y\<^sup>T * x * x \<le> x * x"
     by (smt (z3) assms(2) inf.cobounded2 inf.sup_monoid.add_commute inf.sup_same_context mult_1_left one_inf_conv vector_covector vector_inf_comp)
   have 2: "?xyxxy = (y \<sqinter> y\<^sup>T * x * x) \<squnion> (-y \<sqinter> x)"
     by (simp add: conv_dist_comp)
   also have "... \<le> x * x \<squnion> x"
     using 1 inf_le2 sup_mono by blast
   also have "... \<le> x\<^sup>\<star>"
     by (simp add: star.circ_increasing star.circ_mult_upper_bound)
   finally show "fc ?xyxxy \<le> fc x"
     by (metis comp_isotone conv_order conv_star_commute star_involutive star_isotone)
   have 3: "y \<sqinter> x \<sqinter> 1 \<le> fc ?xyxxy"
     using inf.coboundedI1 inf.sup_monoid.add_commute reflexive_mult_closed star.circ_reflexive by auto
   have 4: "y - 1 \<le> -y\<^sup>T"
     using assms(2) p_shunting_swap regular_one_closed vector_covector by auto
   have "y \<sqinter> x \<le> y\<^sup>T * x"
     by (simp add: assms(2) vector_restrict_comp_conv)
   also have "... \<le> y\<^sup>T * x * x * x\<^sup>T"
     by (metis assms(1) comp_associative mult_1_right mult_right_isotone total_var)
   finally have "y \<sqinter> x \<sqinter> -1 \<le> y \<sqinter> -y\<^sup>T \<sqinter> y\<^sup>T * x * x * x\<^sup>T"
     using 4 by (smt (z3) inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_greatest)
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * x\<^sup>T \<sqinter> -y\<^sup>T"
     by (metis assms(2) inf.sup_monoid.add_assoc inf.sup_monoid.add_commute vector_inf_comp)
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * (x\<^sup>T \<sqinter> -y\<^sup>T)"
     using assms(2) covector_comp_inf vector_conv_compl by auto
   also have "... = (y \<sqinter> y\<^sup>T * x * x) * (-y \<sqinter> x)\<^sup>T"
     by (simp add: conv_complement conv_dist_inf inf_commute)
   also have "... \<le> ?xyxxy * (-y \<sqinter> x)\<^sup>T"
     using 2 by (simp add: comp_left_increasing_sup)
   also have "... \<le> ?xyxxy * ?xyxxy\<^sup>T"
     by (simp add: conv_isotone mult_right_isotone)
   also have "... \<le> fc ?xyxxy"
     using comp_isotone star.circ_increasing by blast
   finally have 5: "y \<sqinter> x \<le> fc ?xyxxy"
     using 3 by (smt (z3) comp_inf.semiring.distrib_left inf.le_iff_sup maddux_3_11_pp regular_one_closed)
   have "x = (y \<sqinter> x) \<squnion> (-y \<sqinter> x)"
     by (metis assms(2) bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
   also have "... \<le> fc ?xyxxy"
     using 5 dual_order.trans fc_increasing sup.cobounded2 sup_least by blast
   finally show "fc x \<le> fc ?xyxxy"
     by (smt (z3) assms fc_equivalence fc_isotone fc_wcc read_injective star.circ_decompose_9 star_decompose_1 update_univalent)
 qed
 
 lemma acyclic_plus_loop:
   assumes "acyclic (x - 1)"
   shows "x\<^sup>+ \<sqinter> 1 = x \<sqinter> 1"
 proof -
   let ?r = "x \<sqinter> 1"
   let ?i = "x - 1"
   have "x\<^sup>+ \<sqinter> 1 = (?i \<squnion> ?r)\<^sup>+ \<sqinter> 1"
     by (metis maddux_3_11_pp regular_one_closed)
   also have "... = ((?i\<^sup>\<star> * ?r)\<^sup>\<star> * ?i\<^sup>+ \<squnion> (?i\<^sup>\<star> * ?r)\<^sup>+) \<sqinter> 1"
     using plus_sup by auto
   also have "... \<le> (?i\<^sup>+ \<squnion> (?i\<^sup>\<star> * ?r)\<^sup>+) \<sqinter> 1"
     by (metis comp_associative dual_order.eq_iff maddux_3_11_pp reachable_without_loops regular_one_closed star.circ_plus_same star.circ_sup_9)
   also have "... = (?i\<^sup>\<star> * ?r)\<^sup>+ \<sqinter> 1"
     by (smt (z3) assms comp_inf.mult_right_dist_sup inf.absorb2 inf.sup_monoid.add_commute inf_le2 maddux_3_11_pp pseudo_complement regular_one_closed)
   also have "... \<le> ?i\<^sup>\<star> * ?r \<sqinter> 1"
     by (metis comp_associative dual_order.eq_iff maddux_3_11_pp reachable_without_loops regular_one_closed star.circ_sup_9 star_slide)
   also have "... = (?r \<squnion> ?i\<^sup>+ * ?r) \<sqinter> 1"
     using comp_associative star.circ_loop_fixpoint sup_commute by force
   also have "... \<le> x \<squnion> (?i\<^sup>+ * ?r \<sqinter> 1)"
     by (metis comp_inf.mult_right_dist_sup inf.absorb1 inf.cobounded1 inf.cobounded2)
   also have "... \<le> x \<squnion> (-1 * ?r \<sqinter> 1)"
     by (meson assms comp_inf.comp_isotone mult_left_isotone order.refl semiring.add_left_mono)
   also have "... = x"
     by (metis comp_inf.semiring.mult_not_zero comp_right_one inf.cobounded2 inf_sup_absorb mult_right_isotone pseudo_complement sup.idem sup_inf_distrib1)
   finally show ?thesis
     by (meson inf.sup_same_context inf_le1 order_trans star.circ_mult_increasing)
 qed
 
 lemma star_irreflexive_part_eq:
   "x\<^sup>\<star> - 1 = (x - 1)\<^sup>+ - 1"
   by (metis reachable_without_loops star_plus_without_loops)
 
 lemma star_irreflexive_part:
   "x\<^sup>\<star> - 1 \<le> (x - 1)\<^sup>+"
   using star_irreflexive_part_eq by auto
 
 lemma square_irreflexive_part:
   "x * x - 1 \<le> (x - 1)\<^sup>+"
 proof -
   have "x * x = (x \<sqinter> 1) * x \<squnion> (x - 1) * x"
     by (metis maddux_3_11_pp mult_right_dist_sup regular_one_closed)
   also have "... \<le> 1 * x \<squnion> (x - 1) * x"
     using comp_isotone inf.cobounded2 semiring.add_right_mono by blast
   also have "... \<le> 1 \<squnion> (x - 1) \<squnion> (x - 1) * x"
     by (metis inf.cobounded2 maddux_3_11_pp mult_1_left regular_one_closed sup_left_isotone)
   also have "... = (x - 1) * (x \<squnion> 1) \<squnion> 1"
     by (simp add: mult_left_dist_sup sup_assoc sup_commute)
   finally have "x * x - 1 \<le> (x - 1) * (x \<squnion> 1)"
     using shunting_var_p by auto
   also have "... = (x - 1) * (x - 1) \<squnion> (x - 1)"
     by (metis comp_right_one inf.sup_monoid.add_commute maddux_3_21_pp mult_left_dist_sup regular_one_closed sup_commute)
   also have "... \<le> (x - 1)\<^sup>+"
     by (metis mult_left_isotone star.circ_increasing star.circ_mult_increasing star.circ_plus_same sup.bounded_iff)
   finally show ?thesis
     .
 qed
 
 lemma square_irreflexive_part_2:
   "x * x - 1 \<le> x\<^sup>\<star> - 1"
   using comp_inf.mult_left_isotone star.circ_increasing star.circ_mult_upper_bound by blast
 
 lemma acyclic_update_square:
   assumes "acyclic (x - 1)"
   shows "acyclic ((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)"
 proof -
   have "((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)\<^sup>+ \<le> ((x \<squnion> x * x) - 1)\<^sup>+"
     by (metis comp_inf.mult_right_isotone comp_isotone inf.sup_monoid.add_commute star_isotone update_square_ub)
   also have "... = ((x - 1) \<squnion> (x * x - 1))\<^sup>+"
     using comp_inf.semiring.distrib_right by auto
   also have "... \<le> ((x - 1)\<^sup>+)\<^sup>+"
     by (smt (verit, del_insts) comp_isotone reachable_without_loops star.circ_mult_increasing star.circ_plus_same star.circ_right_slide star.circ_separate_5 star.circ_square star.circ_transitive_equal star.left_plus_circ sup.bounded_iff sup_ge1 square_irreflexive_part)
   also have "... \<le> -1"
     using assms by (simp add: acyclic_plus)
   finally show ?thesis
     .
 qed
 
 lemma disjoint_set_forest_update_square:
   assumes "disjoint_set_forest x"
       and "vector y"
       and "regular y"
     shows "disjoint_set_forest (x[y\<longmapsto>(x * x)\<^sup>T])"
 proof (intro conjI)
   show "univalent (x[y\<longmapsto>(x * x)\<^sup>T])"
     using assms update_univalent mapping_mult_closed univalent_conv_injective by blast
   show "total (x[y\<longmapsto>(x * x)\<^sup>T])"
     using assms update_total total_conv_surjective total_mult_closed by blast
   show "acyclic ((x[y\<longmapsto>(x * x)\<^sup>T]) - 1)"
     using acyclic_update_square assms(1) by blast
 qed
 
 lemma disjoint_set_forest_update_square_point:
   assumes "disjoint_set_forest x"
       and "point y"
     shows "disjoint_set_forest (x[y\<longmapsto>(x * x)\<^sup>T])"
   using assms disjoint_set_forest_update_square bijective_regular by blast
 
 end
 
 section \<open>Verifying Further Operations on Disjoint-Set Forests\<close>
 
 text \<open>
 In this section we verify the init-sets, path-halving and path-splitting operations of disjoint-set forests.
 \<close>
 
 class choose_point =
   fixes choose_point :: "'a \<Rightarrow> 'a"
 
 text \<open>
 Using the \<open>choose_point\<close> operation we define a simple for-each-loop abstraction as syntactic sugar translated to a while-loop.
 Regular vector \<open>h\<close> describes the set of all elements that are yet to be processed.
 It is made explicit so that the invariant can refer to it.
 \<close>
 
 syntax
   "_Foreach" :: "idt \<Rightarrow> idt \<Rightarrow> 'assn \<Rightarrow> 'com \<Rightarrow> 'com"  ("(1FOREACH _/ USING _/ INV {_} //DO _ /OD)" [0,0,0,0] 61)
 translations "FOREACH x USING h INV { i } DO c OD" =>
   "h := CONST top;
    WHILE h \<noteq> CONST bot
      INV { CONST regular h \<and> CONST vector h \<and> i }
      VAR { h\<down> }
       DO x := CONST choose_point h;
          c;
          h[x] := CONST bot
       OD"
 
 class stone_kleene_relation_algebra_choose_point_finite_regular = stone_kleene_relation_algebra + finite_regular_p_algebra + choose_point +
   assumes choose_point_point: "vector x \<Longrightarrow> x \<noteq> bot \<Longrightarrow> point (choose_point x)"
   assumes choose_point_decreasing: "choose_point x \<le> --x"
 begin
 
 subclass stone_kleene_relation_algebra_tarski_finite_regular
 proof unfold_locales
   fix x
   let ?p = "choose_point (x * top)"
   let ?q = "choose_point ((?p \<sqinter> x)\<^sup>T * top)"
   let ?y = "?p \<sqinter> ?q\<^sup>T"
   assume 1: "regular x" "x \<noteq> bot"
   hence 2: "x * top \<noteq> bot"
     using le_bot top_right_mult_increasing by auto
   hence 3: "point ?p"
     by (simp add: choose_point_point comp_associative)
   hence 4: "?p \<noteq> bot"
     using 2 mult_right_zero by force
   have "?p \<sqinter> x \<noteq> bot"
   proof
     assume "?p \<sqinter> x = bot"
     hence 5: "x \<le> -?p"
       using p_antitone_iff pseudo_complement by auto
     have "?p \<le> --(x * top)"
       by (simp add: choose_point_decreasing)
     also have "... \<le> --(-?p * top)"
       using 5 by (simp add: comp_isotone pp_isotone)
     also have "... = -?p * top"
       using regular_mult_closed by auto
     also have "... = -?p"
       using 3 vector_complement_closed by auto
     finally have "?p = bot"
       using inf_absorb2 by fastforce
     thus False
       using 4 by auto
   qed
   hence "(?p \<sqinter> x)\<^sup>T * top \<noteq> bot"
     by (metis comp_inf.semiring.mult_zero_left comp_right_one inf.sup_monoid.add_commute inf_top.left_neutral schroeder_1)
   hence "point ?q"
     using choose_point_point vector_top_closed mult_assoc by auto
   hence 6: "arc ?y"
     using 3 by (smt bijective_conv_mapping inf.sup_monoid.add_commute mapping_inf_point_arc)
   have "?q \<le> --((?p \<sqinter> x)\<^sup>T * top)"
     by (simp add: choose_point_decreasing)
   hence "?y \<le> ?p \<sqinter> --((?p \<sqinter> x)\<^sup>T * top)\<^sup>T"
     by (metis conv_complement conv_isotone inf.sup_right_isotone)
   also have "... = ?p \<sqinter> --(top * (?p \<sqinter> x))"
     by (simp add: conv_dist_comp)
   also have "... = ?p \<sqinter> top * (?p \<sqinter> x)"
     using 1 3 bijective_regular pp_dist_comp by auto
   also have "... = ?p \<sqinter> ?p\<^sup>T * x"
     using 3 by (metis comp_inf_vector conv_dist_comp inf.sup_monoid.add_commute inf_top_right symmetric_top_closed)
   also have "... = (?p \<sqinter> ?p\<^sup>T) * x"
     using 3 by (simp add: vector_inf_comp)
   also have "... \<le> 1 * x"
     using 3 point_antisymmetric mult_left_isotone by blast
   finally have "?y \<le> x"
     by simp
   thus "top * x * top = top"
     using 6 by (smt (verit, ccfv_SIG) mult_assoc le_iff_sup mult_left_isotone semiring.distrib_left sup.orderE top.extremum)
 qed
 
 subsection \<open>Init-Sets\<close>
 
 text \<open>
 A disjoint-set forest is initialised by applying \<open>make_set\<close> to each node.
 We prove that the resulting disjoint-set forest is the identity relation.
 \<close>
 
 theorem init_sets:
   "VARS h p x
   [ True ]
   FOREACH x
     USING h
       INV { p - h = 1 - h }
        DO p := make_set p x
        OD
   [ p = 1 \<and> disjoint_set_forest p \<and> h = bot ]"
 proof vcg_tc_simp
   fix h p
   let ?x = "choose_point h"
   let ?m = "make_set p ?x"
   assume 1: "regular h \<and> vector h \<and> p - h = 1 - h \<and> h \<noteq> bot"
   show "vector (-?x \<sqinter> h) \<and>
         ?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h) \<and>
         card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
   proof (intro conjI)
     show "vector (-?x \<sqinter> h)"
       using 1 choose_point_point vector_complement_closed vector_inf_closed by blast
     have 2: "point ?x \<and> regular ?x"
       using 1 bijective_regular choose_point_point by blast
     have 3: "-h \<le> -?x"
       using choose_point_decreasing p_antitone_iff by auto
     have 4: "?x \<sqinter> ?m = ?x * ?x\<^sup>T \<and> -?x \<sqinter> ?m = -?x \<sqinter> p"
       using 1 choose_point_point make_set_function make_set_postcondition_def by auto
     have "?m \<sqinter> (--?x \<squnion> -h) = (?m \<sqinter> ?x) \<squnion> (?m - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = ?x * ?x\<^sup>T \<squnion> (?m \<sqinter> -?x \<sqinter> -h)"
       using 3 4 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = ?x * ?x\<^sup>T \<squnion> (1 - h)"
       using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = (1 \<sqinter> ?x) \<squnion> (1 - h)"
       using 2 by (metis inf.cobounded2 inf.sup_same_context one_inf_conv vector_covector)
     also have "... = 1 \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "\<not> ?x \<le> -?x"
       using 1 2 by (metis comp_commute_below_diversity conv_order inf.cobounded2 inf_absorb2 pseudo_complement strict_order_var top.extremum)
     have 6: "?x \<le> h"
       using 1 by (metis choose_point_decreasing)
     show "card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
       apply (rule psubset_card_mono)
       using finite_regular apply simp
       using 2 5 6 by auto
   qed
 qed
 
 end
 
 subsection \<open>Path Halving\<close>
 
 text \<open>
 Path halving is a variant of the path compression technique.
 Similarly to path compression, we implement path halving independently of find-set, using a second while-loop which iterates over the same path to the root.
 We prove that path halving preserves the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the component trees.
 Additionally we prove the exact effect of path halving, which is to replace every other parent pointer with a pointer to the respective grandparent.
 \<close>
 
 context stone_kleene_relation_algebra_tarski_finite_regular
 begin
 
 definition "path_halving_invariant p x y p0 \<equiv> 
   find_set_precondition p x \<and> point y \<and> y \<le> p\<^sup>T\<^sup>\<star> * x \<and> y \<le> (p0 * p0)\<^sup>T\<^sup>\<star> * x \<and>
   p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T] = p \<and>
   disjoint_set_forest p0"
 definition "path_halving_postcondition p x y p0 \<equiv> 
-  path_compression_precondition p x y \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
+  disjoint_set_forest p \<and> y = root p x \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
 
 lemma path_halving_invariant_aux_1:
   assumes "point x"
       and "point y"
       and "disjoint_set_forest p0"
   shows "p0 \<le> wcc (p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T])"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have 1: "regular ?pxy"
     using assms(1,3) bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
   have 2: "vector x \<and> vector ?px \<and> vector ?py"
     using assms(1,2) find_set_precondition_def vector_complement_closed vector_mult_closed path_halving_invariant_def by auto
   have 3: "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> -?px\<^sup>T"
   proof -
     have 4: "injective x \<and> univalent ?p2 \<and> regular p0"
       using assms(1,3) find_set_precondition_def mapping_regular univalent_mult_closed path_halving_invariant_def by auto
     have "?p2\<^sup>\<star> * p0 \<sqinter> 1 \<le> p0\<^sup>+ \<sqinter> 1"
       using comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one star.circ_square star_slide by auto
     also have "... \<le> p0"
       using acyclic_plus_loop assms(3) path_halving_invariant_def by auto
     finally have 5: "?p2\<^sup>\<star> * p0 \<sqinter> 1 \<le> p0"
       .
     hence 6: "?p2ts * (1 - p0) \<le> -p0"
       by (smt (verit, ccfv_SIG) conv_star_commute dual_order.trans inf.sup_monoid.add_assoc order.refl p_antitone_iff pseudo_complement schroeder_4_p schroeder_6_p)
     have "?p2t\<^sup>+ * p0 \<sqinter> 1 = ?p2ts * p0\<^sup>T * (p0\<^sup>T * p0) \<sqinter> 1"
       by (metis conv_dist_comp star_plus mult_assoc)
     also have "... \<le> ?p2ts * p0\<^sup>T \<sqinter> 1"
       by (metis assms(3) comp_inf.mult_left_isotone comp_isotone comp_right_one mult_sub_right_one)
     also have "... \<le> p0"
       using 5 by (metis conv_dist_comp conv_star_commute inf_commute one_inf_conv star_slide)
     finally have "?p2t\<^sup>+ * p0 \<le> -1 \<squnion> p0"
       by (metis regular_one_closed shunting_var_p sup_commute)
     hence 7: "?p2\<^sup>+ * (1 - p0) \<le> -p0"
       by (smt (z3) conv_dist_comp conv_star_commute half_shunting inf.sup_monoid.add_assoc inf.sup_monoid.add_commute pseudo_complement schroeder_4_p schroeder_6_p star.circ_plus_same)
     have "(1 \<sqinter> ?px) * top * (1 \<sqinter> ?px \<sqinter> -p0) = ?px \<sqinter> top * (1 \<sqinter> ?px \<sqinter> -p0)"
       using 2 by (metis inf_commute vector_inf_one_comp mult_assoc)
     also have "... = ?px \<sqinter> ?px\<^sup>T * (1 - p0)"
       using 2 by (smt (verit, ccfv_threshold) covector_inf_comp_3 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_top.left_neutral)
     also have "... = ?px \<sqinter> x\<^sup>T * ?p2\<^sup>\<star> * (1 - p0)"
       by (simp add: conv_dist_comp conv_star_commute)
     also have "... = (?px \<sqinter> x\<^sup>T) * ?p2\<^sup>\<star> * (1 - p0)"
       using 2 vector_inf_comp by auto
     also have "... = ?p2ts * (x * x\<^sup>T) * ?p2\<^sup>\<star> * (1 - p0)"
       using 2 vector_covector mult_assoc by auto
     also have "... \<le> ?p2ts * ?p2\<^sup>\<star> * (1 - p0)"
       using 4 by (metis inf.order_lesseq_imp mult_left_isotone star.circ_mult_upper_bound star.circ_reflexive)
     also have "... = (?p2ts \<squnion> ?p2\<^sup>\<star>) * (1 - p0)"
       using 4 by (simp add: cancel_separate_eq)
     also have "... = (?p2ts \<squnion> ?p2\<^sup>+) * (1 - p0)"
       by (metis star.circ_plus_one star_plus_loops sup_assoc sup_commute)
     also have "... \<le> -p0"
       using 6 7 by (simp add: mult_right_dist_sup)
     finally have "(1 \<sqinter> ?px)\<^sup>T * p0 * (1 \<sqinter> ?px \<sqinter> -p0)\<^sup>T \<le> bot"
       by (smt (z3) inf.boundedI inf_p top.extremum triple_schroeder_p)
     hence 8: "(1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> -p0) = bot"
       by (simp add: coreflexive_inf_closed coreflexive_symmetric le_bot)
     have "?px \<sqinter> p0 \<sqinter> ?px\<^sup>T = (1 \<sqinter> ?px) * p0 \<sqinter> ?px\<^sup>T"
       using 2 inf_commute vector_inf_one_comp by fastforce
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px)"
       using 2 by (metis comp_inf_vector mult_1_right vector_conv_covector)
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> p0) \<squnion> (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> -p0)"
       using 4 by (metis maddux_3_11_pp mult_left_dist_sup)
     also have "... = (1 \<sqinter> ?px) * p0 * (1 \<sqinter> ?px \<sqinter> p0)"
       using 8 by simp
     also have "... \<le> ?p2"
       by (metis comp_isotone coreflexive_comp_top_inf inf.cobounded1 inf.cobounded2)
     finally have "?px \<sqinter> p0 \<sqinter> -?p2 \<le> -?px\<^sup>T"
       using 4 p_shunting_swap regular_mult_closed by fastforce
     thus ?thesis
       by (meson comp_inf.mult_left_isotone dual_order.trans inf.cobounded1)
   qed
   have "p0 \<le> ?p2 * p0\<^sup>T"
     by (metis assms(3) comp_associative comp_isotone comp_right_one eq_refl total_var)
   hence "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> ?p2 * p0\<^sup>T"
     by (metis inf.coboundedI1 inf.sup_monoid.add_commute)
   hence "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> ?pxy \<sqinter> ?p2 * p0\<^sup>T \<sqinter> -?px\<^sup>T"
     using 3 by (meson dual_order.trans inf.boundedI inf.cobounded1)
   also have "... = (?pxy \<sqinter> ?p2) * p0\<^sup>T \<sqinter> -?px\<^sup>T"
     using 2 vector_inf_comp by auto
   also have "... = (?pxy \<sqinter> ?p2) * (-?px \<sqinter> p0)\<^sup>T"
     using 2 by (simp add: covector_comp_inf inf.sup_monoid.add_commute vector_conv_compl conv_complement conv_dist_inf)
   also have "... \<le> ?p * (-?px \<sqinter> p0)\<^sup>T"
     using comp_left_increasing_sup by auto
   also have "... \<le> ?p * ?p\<^sup>T"
     by (metis comp_inf.mult_right_isotone comp_isotone conv_isotone inf.eq_refl inf.sup_monoid.add_commute le_supI1 p_antitone_inf sup_commute)
   also have "... \<le> wcc ?p"
     using star.circ_sub_dist_2 by auto
   finally have 9: "?pxy \<sqinter> p0 \<sqinter> -?p2 \<le> wcc ?p"
     .
   have "p0 = (?pxy \<sqinter> p0) \<squnion> (-?pxy \<sqinter> p0)"
     using 1 by (metis inf.sup_monoid.add_commute maddux_3_11_pp)
   also have "... \<le> (?pxy \<sqinter> p0) \<squnion> ?p"
     using sup_right_isotone by auto
   also have "... = (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> (?pxy \<sqinter> p0 \<sqinter> ?p2) \<squnion> ?p"
     by (smt (z3) assms(3) maddux_3_11_pp mapping_regular pp_dist_comp path_halving_invariant_def)
   also have "... \<le> (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> (?pxy \<sqinter> ?p2) \<squnion> ?p"
     by (meson comp_inf.comp_left_subdist_inf inf.boundedE semiring.add_left_mono semiring.add_right_mono)
   also have "... = (?pxy \<sqinter> p0 \<sqinter> -?p2) \<squnion> ?p"
     using sup_assoc by auto
   also have "... \<le> wcc ?p \<squnion> ?p"
     using 9 sup_left_isotone by blast
   also have "... \<le> wcc ?p"
     by (simp add: star.circ_sub_dist_1)
   finally show ?thesis
     .
 qed
 
 lemma path_halving_invariant_aux:
   assumes "path_halving_invariant p x y p0"
   shows "p[[y]] = p0[[y]]"
     and "p[[p[[y]]]] = p0[[p0[[y]]]]"
     and "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     and "p \<sqinter> 1 = p0 \<sqinter> 1"
     and "fc p = fc p0"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have "?p[[y]] = p0[[y]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (meson inf.cobounded2 order_lesseq_imp p_antitone_iff path_compression_1b)
   thus 1: "p[[y]] = p0[[y]]"
     using assms path_halving_invariant_def by auto
   have "?p[[p0[[y]]]] = p0[[p0[[y]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (metis comp_isotone inf.boundedE inf.coboundedI2 inf.eq_refl p_antitone_iff selection_closed_id star.circ_increasing)
   thus 2: "p[[p[[y]]]] = p0[[p0[[y]]]]"
     using 1 assms path_halving_invariant_def by auto
   have "?p[[p0[[p0[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def apply force
     by (metis comp_associative comp_isotone conv_dist_comp conv_involutive conv_order inf.coboundedI2 inf.le_iff_sup mult_left_isotone p_antitone_iff p_antitone_inf star.circ_increasing star.circ_transitive_equal)
   thus "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     using 2 assms path_halving_invariant_def by auto
   have 3: "regular ?pxy"
     using assms bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
   have "p \<sqinter> 1 = ?p \<sqinter> 1"
     using assms path_halving_invariant_def by auto
   also have "... = (?pxy \<sqinter> ?p2 \<sqinter> 1) \<squnion> (-?pxy \<sqinter> p0 \<sqinter> 1)"
     using comp_inf.semiring.distrib_right conv_involutive by auto
   also have "... = (?pxy \<sqinter> p0 \<sqinter> 1) \<squnion> (-?pxy \<sqinter> p0 \<sqinter> 1)"
     using assms acyclic_square path_halving_invariant_def inf.sup_monoid.add_assoc by auto
   also have "... = (?pxy \<squnion> -?pxy) \<sqinter> p0 \<sqinter> 1"
     using inf_sup_distrib2 by auto
   also have "... = p0 \<sqinter> 1"
     using 3 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show "p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   have "p \<le> p0\<^sup>+"
     by (metis assms path_halving_invariant_def update_square_ub_plus)
   hence 4: "fc p \<le> fc p0"
     using conv_plus_commute fc_isotone star.left_plus_circ by fastforce
   have "wcc p0 \<le> wcc ?p"
     by (meson assms wcc_below_wcc path_halving_invariant_aux_1 path_halving_invariant_def find_set_precondition_def)
   hence "fc p0 \<le> fc ?p"
     using assms find_set_precondition_def path_halving_invariant_def fc_wcc by auto
   thus "fc p = fc p0"
     using 4 assms path_halving_invariant_def by auto
 qed
 
 lemma path_halving_1:
   "find_set_precondition p0 x \<Longrightarrow> path_halving_invariant p0 x x p0"
 proof -
   assume 1: "find_set_precondition p0 x"
   show "path_halving_invariant p0 x x p0"
   proof (unfold path_halving_invariant_def, intro conjI)
     show "find_set_precondition p0 x"
       using 1 by simp
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def by auto
     show "x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     show "x \<le> (p0 * p0)\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     have "(p0 * p0)\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: conv_dist_comp mult_left_isotone star.circ_square)
     thus "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p0"
       by (smt (z3) inf.le_iff_sup inf_commute maddux_3_11_pp p_antitone_inf pseudo_complement)
     show "univalent p0" "total p0" "acyclic (p0 - 1)"
       using 1 find_set_precondition_def by auto
   qed
 qed
 
 lemma path_halving_2:
   "path_halving_invariant p x y p0 \<and> y \<noteq> p[[y]] \<Longrightarrow> path_halving_invariant (p[y\<longmapsto>p[[p[[y]]]]]) x ((p[y\<longmapsto>p[[p[[y]]]]])[[y]]) p0 \<and> ((p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * ((p[y\<longmapsto>p[[p[[y]]]]])[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
 proof -
   let ?py = "p[[y]]"
   let ?ppy = "p[[?py]]"
   let ?pyppy = "p[y\<longmapsto>?ppy]"
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "?p2ts * x"
   let ?py2 = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?pty = "p0\<^sup>T * y"
   let ?pt2y = "p0\<^sup>T * p0\<^sup>T * y"
   let ?pt2sy = "p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T * y"
   assume 1: "path_halving_invariant p x y p0 \<and> y \<noteq> ?py"
   have 2: "point ?pty \<and> point ?pt2y"
     using 1 by (smt (verit) comp_associative read_injective read_surjective path_halving_invariant_def)
   show "path_halving_invariant ?pyppy x (?pyppy[[y]]) p0 \<and> (?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
   proof
     show "path_halving_invariant ?pyppy x (?pyppy[[y]]) p0"
     proof (unfold path_halving_invariant_def, intro conjI)
       show 3: "find_set_precondition ?pyppy x"
       proof (unfold find_set_precondition_def, intro conjI)
         show "univalent ?pyppy"
           using 1 find_set_precondition_def read_injective update_univalent path_halving_invariant_def by auto
         show "total ?pyppy"
           using 1 bijective_regular find_set_precondition_def read_surjective update_total path_halving_invariant_def by force
         show "acyclic (?pyppy - 1)"
           apply (rule update_acyclic_3)
           using 1 find_set_precondition_def path_halving_invariant_def apply blast
           using 1 2 comp_associative path_halving_invariant_aux(2) apply force
           using 1 path_halving_invariant_def apply blast
           by (metis inf.order_lesseq_imp mult_isotone star.circ_increasing star.circ_square mult_assoc)
         show "vector x" "injective x" "surjective x"
           using 1 find_set_precondition_def path_halving_invariant_def by auto
       qed
       show "vector (?pyppy[[y]])"
         using 1 comp_associative path_halving_invariant_def by auto
       show "injective (?pyppy[[y]])"
         using 1 3 read_injective path_halving_invariant_def find_set_precondition_def by auto
       show "surjective (?pyppy[[y]])"
         using 1 3 read_surjective path_halving_invariant_def find_set_precondition_def by auto
       show "?pyppy[[y]] \<le> ?pyppy\<^sup>T\<^sup>\<star> * x"
       proof -
         have "y = (y \<sqinter> p\<^sup>T\<^sup>\<star>) * x"
           using 1 le_iff_inf vector_inf_comp path_halving_invariant_def by auto
         also have "... = ((y \<sqinter> 1) \<squnion> (y \<sqinter> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+)) * x"
           using 1 omit_redundant_points_3 path_halving_invariant_def by auto
         also have "... \<le> (1 \<squnion> (y \<sqinter> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+)) * x"
           using 1 sup_inf_distrib2 vector_inf_comp path_halving_invariant_def by auto
         also have "... \<le> (1 \<squnion> (p\<^sup>T \<sqinter> -y\<^sup>T)\<^sup>+) * x"
           by (simp add: inf.coboundedI2 mult_left_isotone)
         also have "... = (p \<sqinter> -y)\<^sup>T\<^sup>\<star> * x"
           by (simp add: conv_complement conv_dist_inf star_left_unfold_equal)
         also have "... \<le> ?pyppy\<^sup>T\<^sup>\<star> * x"
           by (simp add: conv_isotone inf.sup_monoid.add_commute mult_left_isotone star_isotone)
         finally show ?thesis
           by (metis mult_isotone star.circ_increasing star.circ_transitive_equal mult_assoc)
       qed
       show "?pyppy[[y]] \<le> ?px"
       proof -
         have "?pyppy[[y]] = p[[?py]]"
           using 1 put_get vector_mult_closed path_halving_invariant_def by force
         also have "... = p0[[p0[[y]]]]"
           using 1 path_halving_invariant_aux(2) by blast
         also have "... = ?p2t * y"
           by (simp add: conv_dist_comp mult_assoc)
         also have "... \<le> ?p2t * ?px"
           using 1 path_halving_invariant_def comp_associative mult_right_isotone by force
         also have "... \<le> ?px"
           by (metis comp_associative mult_left_isotone star.left_plus_below_circ)
         finally show ?thesis
           .
       qed
       show "p0[?px - p0\<^sup>T\<^sup>\<star> * (?pyppy[[y]])\<longmapsto>?p2t] = ?pyppy"
       proof -
         have "?px \<sqinter> ?pty = ?px \<sqinter> p0\<^sup>T * ?px \<sqinter> ?pty"
           using 1 inf.absorb2 inf.sup_monoid.add_assoc mult_right_isotone path_halving_invariant_def by force
         also have "... = (?p2ts \<sqinter> p0\<^sup>T * ?p2ts) * x \<sqinter> ?pty"
           using 3 comp_associative find_set_precondition_def injective_comp_right_dist_inf by auto
         also have "... = (1 \<sqinter> p0) * (?p2ts \<sqinter> p0\<^sup>T * ?p2ts) * x \<sqinter> ?pty"
           using 1 even_odd_root mapping_regular path_halving_invariant_def by auto
         also have "... \<le> (1 \<sqinter> p0) * top \<sqinter> ?pty"
           by (metis comp_associative comp_inf.mult_left_isotone comp_inf.star.circ_sub_dist_2 comp_left_subdist_inf dual_order.trans mult_right_isotone)
         also have 4: "... = (1 \<sqinter> p0\<^sup>T) * ?pty"
           using coreflexive_comp_top_inf one_inf_conv by auto
         also have "... \<le> ?pt2y"
           by (simp add: mult_assoc mult_left_isotone)
         finally have 5: "?px \<sqinter> ?pty \<le> ?pt2y"
           .
         have 6: "p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t] = p"
         proof (cases "?pty \<le> ?px \<sqinter> -?pt2sy")
           case True
           hence "?pty \<le> ?pt2y"
             using 5 conv_dist_comp inf.absorb2 by auto
           hence 7: "?pty = ?pt2y"
             using 2 epm_3 by fastforce
           have "p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t] = p[?pty\<longmapsto>?p2t]"
             using True inf.absorb2 by auto
           also have "... = p[?pty\<longmapsto>?p2[[?pty]]]"
             using 2 update_point_get by auto
           also have "... = p[?pty\<longmapsto>p0\<^sup>T * p0\<^sup>T * p0\<^sup>T * y]"
             using comp_associative conv_dist_comp by auto
           also have "... = p[?pty\<longmapsto>?pt2y]"
             using 7 mult_assoc by simp
           also have "... = p[?pty\<longmapsto>p[[?pty]]]"
             using 1 path_halving_invariant_aux(1,2) mult_assoc by force
           also have "... = p"
             using 2 get_put by auto
           finally show ?thesis
             .
         next
           case False
           have "mapping ?p2"
             using 1 mapping_mult_closed path_halving_invariant_def by blast
           hence 8: "regular (?px \<sqinter> -?pt2sy)"
             using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
           have "vector (?px \<sqinter> -?pt2sy)"
             using 1 find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_halving_invariant_def by force
           hence "?pty \<le> -(?px \<sqinter> -?pt2sy)"
             using 2 8 point_in_vector_or_complement False by blast
           hence "?px \<sqinter> -?pt2sy \<sqinter> ?pty = bot"
             by (simp add: p_antitone_iff pseudo_complement)
           thus ?thesis
             by simp
         qed
         have 9: "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = ?pyppy"
         proof (cases "y \<le> -?pt2sy")
           case True
           hence "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = p[y\<longmapsto>?p2t]"
             using 1 inf.absorb2 path_halving_invariant_def by auto
           also have "... = ?pyppy"
             using 1 by (metis comp_associative conv_dist_comp path_halving_invariant_aux(2) path_halving_invariant_def update_point_get)
           finally show ?thesis
             .
         next
           case False
           have "vector (-?pt2sy)"
             using 1 vector_complement_closed vector_mult_closed path_halving_invariant_def by blast
           hence 10: "y \<le> ?pt2sy"
             using 1 by (smt (verit, del_insts) False bijective_regular point_in_vector_or_complement regular_closed_star regular_mult_closed total_conv_surjective univalent_conv_injective path_halving_invariant_def)
           hence "?px \<sqinter> -?pt2sy \<sqinter> y = bot"
             by (simp add: inf.coboundedI2 p_antitone pseudo_complement)
           hence 11: "p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t] = p"
             by simp
           have "y \<le> p0\<^sup>T\<^sup>+ * y"
             using 10 by (metis mult_left_isotone order_lesseq_imp star.circ_plus_same star.left_plus_below_circ)
           hence 12: "y = root p0 y"
             using 1 loop_root_2 path_halving_invariant_def by blast
           have "?pyppy = p[y\<longmapsto>p0[[p0[[y]]]]]"
             using 1 path_halving_invariant_aux(2) by force
           also have "... = p[y\<longmapsto>p0[[y]]]"
             using 1 12 by (metis root_successor_loop path_halving_invariant_def)
           also have "... = p[y\<longmapsto>?py]"
             using 1 path_halving_invariant_aux(1) by force
           also have "... = p"
             using 1 get_put path_halving_invariant_def by blast
           finally show ?thesis
             using 11 by simp
         qed
         have 13: "-?pt2sy = -(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
         proof (rule order.antisym)
           have 14: "regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?pt2sy"
             using 1 by (metis order.antisym conv_complement conv_dist_comp conv_involutive conv_star_commute forest_components_increasing mapping_regular pp_dist_star regular_mult_closed top.extremum path_halving_invariant_def)
           have "p0\<^sup>T\<^sup>\<star> = p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T \<squnion> p0\<^sup>T \<squnion> 1"
             using star.circ_back_loop_fixpoint star.circ_plus_same star_left_unfold_equal sup_commute by auto
           hence "p0\<^sup>T\<^sup>\<star> * y \<le> ?pt2sy \<squnion> ?pty \<squnion> y"
             by (metis inf.eq_refl mult_1_left mult_right_dist_sup)
           also have "... = ?pt2sy \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> y"
             using 14 by (metis maddux_3_21_pp)
           also have "... = ?pt2sy \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using 14 by (smt (z3) maddux_3_21_pp sup.left_commute sup_assoc)
           hence "p0\<^sup>T\<^sup>\<star> * y \<sqinter> -?pt2sy \<le> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using calculation half_shunting sup_assoc sup_commute by auto
           thus "-?pt2sy \<le> -(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y)"
             using 14 by (smt (z3) inf.sup_monoid.add_commute shunting_var_p sup.left_commute sup_commute)
           have "-(p0\<^sup>T\<^sup>\<star> * y) \<le> -?pt2sy"
             by (meson mult_left_isotone order.trans p_antitone star.right_plus_below_circ)
           thus "-(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?pt2sy \<sqinter> ?pty) \<squnion> (-?pt2sy \<sqinter> y) \<le> -?pt2sy"
             by simp
         qed
         have "regular ?px" "regular ?pty" "regular y"
           using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def by auto
         hence 15: "regular (?px \<sqinter> -?pt2sy \<sqinter> ?pty)" "regular (?px \<sqinter> -?pt2sy \<sqinter> y)"
           by auto
         have "p0[?px - p0\<^sup>T\<^sup>\<star> * (?pyppy[[y]])\<longmapsto>?p2t] = p0[?px - p0\<^sup>T\<^sup>\<star> * (p[[?py]])\<longmapsto>?p2t]"
           using 1 put_get vector_mult_closed path_halving_invariant_def by auto
         also have "... = p0[?px - ?pt2sy\<longmapsto>?p2t]"
           using 1 comp_associative path_halving_invariant_aux(2) by force
         also have "... = p0[?pxy \<squnion> (?px \<sqinter> -?pt2sy \<sqinter> ?pty) \<squnion> (?px \<sqinter> -?pt2sy \<sqinter> y)\<longmapsto>?p2t]"
           using 13 by (metis comp_inf.semiring.distrib_left inf.sup_monoid.add_assoc)
         also have "... = (?p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t])[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 15 by (smt (z3) update_same_3 comp_inf.semiring.mult_not_zero inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
         also have "... = (p[?px \<sqinter> -?pt2sy \<sqinter> ?pty\<longmapsto>?p2t])[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 1 path_halving_invariant_def by auto
         also have "... = p[?px \<sqinter> -?pt2sy \<sqinter> y\<longmapsto>?p2t]"
           using 6 by simp
         also have "... = ?pyppy"
           using 9 by auto
         finally show ?thesis
           .
       qed
       show "univalent p0" "total p0" "acyclic (p0 - 1)"
         using 1 path_halving_invariant_def by auto
     qed
     let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
     let ?t = "{ z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) }"
     have "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) = ?pyppy\<^sup>T\<^sup>\<star> * (p[[?py]])"
       using 1 put_get vector_mult_closed path_halving_invariant_def by force
     also have "... \<le> p\<^sup>+\<^sup>T\<^sup>\<star> * (p[[?py]])"
       using 1 path_halving_invariant_def update_square_plus conv_order mult_left_isotone star_isotone by force
     also have "... = p\<^sup>T\<^sup>\<star> * p\<^sup>T * p\<^sup>T * y"
       by (simp add: conv_plus_commute star.left_plus_circ mult_assoc)
     also have "... \<le> p\<^sup>T\<^sup>+ * y"
       by (metis mult_left_isotone star.left_plus_below_circ star_plus)
     finally have 16: "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) \<le> p\<^sup>T\<^sup>+ * y"
       .
     hence "?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
       using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
     hence 17: "?t \<subseteq> ?s"
       using order_trans by auto
     have 18: "y \<in> ?s"
       using 1 bijective_regular path_compression_1b path_halving_invariant_def by force
     have 19: "\<not> y \<in> ?t"
     proof
       assume "y \<in> ?t"
       hence "y \<le> ?pyppy\<^sup>T\<^sup>\<star> * (?pyppy[[y]])"
         by simp
       hence "y \<le> p\<^sup>T\<^sup>+ * y"
         using 16 dual_order.trans by blast
       hence "y = root p y"
         using 1 find_set_precondition_def loop_root_2 path_halving_invariant_def by blast
       hence "y = ?py"
         using 1 by (metis find_set_precondition_def root_successor_loop path_halving_invariant_def)
       thus False
         using 1 by simp
     qed
     show "card ?t < card ?s"
       apply (rule psubset_card_mono)
       subgoal using finite_regular by simp
       subgoal using 17 18 19 by auto
       done
   qed
 qed
 
 lemma path_halving_3:
   "path_halving_invariant p x y p0 \<and> y = p[[y]] \<Longrightarrow> path_halving_postcondition p x y p0"
 proof -
   assume 1: "path_halving_invariant p x y p0 \<and> y = p[[y]]"
   show "path_halving_postcondition p x y p0"
-  proof (unfold path_halving_postcondition_def path_compression_precondition_def, intro conjI)
+  proof (unfold path_halving_postcondition_def, intro conjI)
     show "univalent p" "total p" "acyclic (p - 1)"
       using 1 find_set_precondition_def path_halving_invariant_def by blast+
-    show "vector x" "injective x" "surjective x"
-      using 1 find_set_precondition_def path_halving_invariant_def by blast+
-    show 2: "vector y" "injective y" "surjective y"
-      using 1 path_halving_invariant_def by blast+
     have "find_set_invariant p x y"
       using 1 find_set_invariant_def path_halving_invariant_def by blast
     thus "y = root p x"
       using 1 find_set_3 find_set_postcondition_def by blast
     show "p \<sqinter> 1 = p0 \<sqinter> 1"
       using 1 path_halving_invariant_aux(4) by blast
     show "fc p = fc p0"
       using 1 path_halving_invariant_aux(5) by blast
-    have 3: "y = p0[[y]]"
+    have 2: "y = p0[[y]]"
       using 1 path_halving_invariant_aux(1) by auto
     hence "p0\<^sup>T\<^sup>\<star> * y = y"
       using order.antisym path_compression_1b star_left_induct_mult_equal by auto
-    hence 4: "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
+    hence 3: "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
       using 1 path_halving_invariant_def by auto
     have "(p0 * p0)\<^sup>T * y = y"
-      using 3 mult_assoc conv_dist_comp by auto
+      using 2 mult_assoc conv_dist_comp by auto
     hence "y \<sqinter> p0 * p0 = y \<sqinter> p0"
-      using 2 3 by (metis update_postcondition)
-    hence 5: "y \<sqinter> p = y \<sqinter> p0 * p0"
-      using 1 2 3 by (smt update_postcondition)
+      using 1 2 by (smt path_halving_invariant_def update_postcondition)
+    hence 4: "y \<sqinter> p = y \<sqinter> p0 * p0"
+      using 1 2 by (smt path_halving_invariant_def update_postcondition)
     have "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = (p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T])[(p0 * p0)\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 1 bijective_regular path_halving_invariant_def update_split by blast
     also have "... = p[(p0 * p0)\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
-      using 4 by simp
+      using 3 by simp
     also have "... = p"
       apply (rule update_same_sub)
-      using 5 apply simp
+      using 4 apply simp
       apply simp
       using 1 bijective_regular inf.absorb2 path_halving_invariant_def by auto
     finally show "p0[(p0 * p0)\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
       .
   qed
 qed
 
 theorem find_path_halving:
   "VARS p y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { path_halving_invariant p x y p0 }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO p[y] := p[[p[[y]]]];
         y := p[[y]]
      OD
   [ path_halving_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_halving_1)
    apply (fact path_halving_2)
   by (fact path_halving_3)
 
 subsection \<open>Path Splitting\<close>
 
 text \<open>
 Path splitting is another variant of the path compression technique.
 We implement it again independently of find-set, using a second while-loop which iterates over the same path to the root.
 We prove that path splitting preserves the equivalence-relational semantics of the disjoint-set forest and also preserves the roots of the component trees.
 Additionally we prove the exact effect of path splitting, which is to replace every parent pointer with a pointer to the respective grandparent.
 \<close>
 
 definition "path_splitting_invariant p x y p0 \<equiv> 
   find_set_precondition p x \<and> point y \<and> y \<le> p0\<^sup>T\<^sup>\<star> * x \<and>
   p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T] = p \<and>
   disjoint_set_forest p0"
 definition "path_splitting_postcondition p x y p0 \<equiv> 
-  path_compression_precondition p x y \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
+  disjoint_set_forest p \<and> y = root p x \<and> p \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p = fc p0 \<and>
   p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
 
 lemma path_splitting_invariant_aux_1:
   assumes "point x"
       and "point y"
       and "disjoint_set_forest p0"
     shows "(p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T]) \<sqinter> 1 = p0 \<sqinter> 1"
       and "fc (p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * y\<longmapsto>(p0 * p0)\<^sup>T]) = fc p0"
       and "p0\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>\<star> * root p0 x"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?q1 = "?pxy \<sqinter> p0"
   let ?q2 = "-?pxy \<sqinter> p0"
   let ?q3 = "?pxy \<sqinter> ?p2"
   let ?q4 = "-?pxy \<sqinter> ?p2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?r0 = "root p0 x"
   let ?rp = "root ?p x"
   have 1: "regular ?px \<and> regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?pxy"
     using assms bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_halving_invariant_def regular_closed_inf by auto
   have 2: "vector x \<and> vector ?px \<and> vector ?py \<and> vector ?pxy"
     using assms(1,2) find_set_precondition_def vector_complement_closed vector_mult_closed path_halving_invariant_def vector_inf_closed by auto
   have 3: "?r0 \<le> p0 * ?r0"
     by (metis assms(3) dedekind_1 inf.le_iff_sup root_successor_loop top_greatest)
   hence "?pxy \<sqinter> p0 * ?r0 \<le> ?pxy \<sqinter> ?p2 * ?r0"
     by (metis comp_associative inf.eq_refl inf.sup_right_isotone mult_isotone)
   hence 4: "?q1 * ?r0 \<le> ?q3 * ?r0"
     using 2 by (simp add: vector_inf_comp)
   have 5: "?q1 * ?q2 \<le> ?q3"
     using 2 by (smt (z3) comp_isotone inf.cobounded1 inf.cobounded2 inf_greatest vector_export_comp)
   have "?q1 * ?q2\<^sup>\<star> * ?r0 = ?q1 * ?r0 \<squnion> ?q1 * ?q2 * ?q2\<^sup>\<star> * ?r0"
     by (metis comp_associative semiring.distrib_left star.circ_loop_fixpoint sup_commute)
   also have "... \<le> ?q1 * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 5 by (meson mult_left_isotone sup_right_isotone)
   also have "... \<le> ?q3 * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 4 sup_left_isotone by blast
   also have "... = ?q3 * ?q2\<^sup>\<star> * ?r0"
     by (smt (verit, del_insts) comp_associative semiring.distrib_left star.circ_loop_fixpoint star.circ_transitive_equal star_involutive sup_commute)
   finally have 6: "?q1 * ?q2\<^sup>\<star> * ?r0 \<le> ?q3 * ?q2\<^sup>\<star> * ?r0"
     .
   have "?q1 * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy \<le> (?px \<sqinter> p0) * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy"
     by (meson comp_inf.comp_left_subdist_inf inf.boundedE mult_left_isotone)
   also have "... \<le> (?px \<sqinter> p0) * (-?pxy \<sqinter> p0\<^sup>+) * ?py"
     by (simp add: mult_right_isotone)
   also have "... \<le> ?px\<^sup>T * (-?pxy \<sqinter> p0\<^sup>+) * ?py"
   proof -
     have "?px \<sqinter> p0 \<le> ?px\<^sup>T * p0"
       using 2 by (simp add: vector_restrict_comp_conv)
     also have "... \<le> ?px\<^sup>T"
       by (metis comp_associative conv_dist_comp conv_involutive conv_star_commute mult_right_isotone star.circ_increasing star.circ_transitive_equal)
     finally show ?thesis
       using mult_left_isotone by auto
   qed
   also have "... = top * (?px \<sqinter> -?pxy \<sqinter> p0\<^sup>+) * ?py"
     using 2 by (smt (z3) comp_inf.star_plus conv_dist_inf covector_inf_comp_3 inf_top.right_neutral vector_complement_closed vector_inf_closed)
   also have "... \<le> top * (-?py \<sqinter> p0\<^sup>+) * ?py"
     by (metis comp_inf.comp_isotone comp_isotone inf.cobounded2 inf.eq_refl inf_import_p)
   also have "... = top * (-?py \<sqinter> p0\<^sup>+ \<sqinter> ?py\<^sup>T) * top"
     using 2 by (simp add: comp_associative covector_inf_comp_3)
   also have "... = bot"
   proof -
     have "p0\<^sup>T\<^sup>\<star> * y - y\<^sup>T * p0\<^sup>\<star> = p0\<^sup>T\<^sup>\<star> * y * y\<^sup>T * -p0\<^sup>\<star>"
       using 2 by (metis assms(2) bijective_conv_mapping comp_mapping_complement vector_covector vector_export_comp vector_mult_closed)
     also have "... \<le> p0\<^sup>T\<^sup>\<star> * -p0\<^sup>\<star>"
       by (meson assms(2) mult_left_isotone order_refl shunt_bijective)
     also have "... \<le> -p0\<^sup>\<star>"
       by (simp add: conv_complement conv_star_commute pp_increasing schroeder_6_p star.circ_transitive_equal)
     also have "... \<le> -p0\<^sup>+"
       by (simp add: p_antitone star.left_plus_below_circ)
     finally have "-?py \<sqinter> p0\<^sup>+ \<sqinter> ?py\<^sup>T = bot"
       by (metis comp_inf.p_pp_comp conv_complement conv_dist_comp conv_involutive conv_star_commute p_shunting_swap pp_isotone pseudo_complement_pp regular_closed_p)
     thus ?thesis
       by simp
   qed
   finally have 7: "?q1 * (-?pxy \<sqinter> p0\<^sup>+) * ?pxy = bot"
     using le_bot by blast
   have "?q2\<^sup>+ \<le> -?pxy"
     using 2 by (smt (z3) comp_isotone complement_conv_sub inf.order_trans inf.sup_right_divisibility inf_commute symmetric_top_closed top_greatest)
   hence "?q2\<^sup>+ \<le> -?pxy \<sqinter> p0\<^sup>+"
     by (simp add: comp_isotone star_isotone)
   hence 8: "?q1 * ?q2\<^sup>+ * ?pxy = bot"
     using 7 mult_left_isotone mult_right_isotone le_bot by auto
   have "?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> = ?q1 * ?q2\<^sup>+ \<squnion> ?q1 * ?q2\<^sup>+ * ?q3\<^sup>+"
     by (smt (z3) comp_associative star.circ_back_loop_fixpoint star.circ_plus_same sup_commute)
   also have "... \<le> ?q1 * ?q2\<^sup>+ \<squnion> ?q1 * ?q2\<^sup>+ * ?pxy"
     using 2 by (smt (z3) inf.cobounded1 mult_right_isotone sup_right_isotone vector_inf_comp)
   finally have 9: "?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> \<le> ?q1 * ?q2\<^sup>+"
     using 8 by simp
   have 10: "?q1 * ?q4 * ?pxy = bot"
   proof -
     have "?p2 \<le> p0\<^sup>+"
       by (simp add: mult_right_isotone star.circ_increasing)
     thus ?thesis
       using 7 by (metis mult_left_isotone mult_right_isotone le_bot comp_inf.comp_isotone eq_refl)
   qed
   have 11: "?q1 * ?q2 * ?pxy = bot"
   proof -
     have "p0 \<le> p0\<^sup>+"
       by (simp add: star.circ_mult_increasing)
     thus ?thesis
       using 7 by (metis mult_left_isotone mult_right_isotone le_bot comp_inf.comp_isotone eq_refl)
   qed
   have 12: "?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, del_insts) conv_dist_comp conv_order conv_star_commute inf.coboundedI1 inf.orderE inf.sup_monoid.add_commute path_compression_1b)
   have "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> = ?q1 * p0 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 2 vector_inf_comp by auto
   also have "... = ?q1 * (?q3 \<squnion> ?q4) * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 1 by (smt (z3) comp_associative comp_inf.mult_right_dist_sup comp_inf.star_slide inf_top.right_neutral regular_complement_top)
   also have "... = ?q1 * ?q3 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using mult_left_dist_sup mult_right_dist_sup by auto
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (z3) mult_left_isotone mult_left_sub_dist_sup_right sup_left_isotone sup_right_divisibility mult_assoc star.left_plus_below_circ)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q3\<^sup>+ * ?q2\<^sup>\<star>"
     by (smt (z3) semiring.combine_common_factor star.circ_back_loop_fixpoint star_plus sup_monoid.add_commute mult_assoc)
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?pxy * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, ccfv_threshold) comp_isotone inf.sup_right_divisibility inf_commute order.refl semiring.add_left_mono mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q4 * ?q2\<^sup>\<star>"
     using 10 by simp
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * p0 * ?q2\<^sup>\<star>"
     using 2 by (smt vector_complement_closed vector_inf_comp mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * (?q2 \<squnion> ?q1) * ?q2\<^sup>\<star>"
     using 1 by (smt (z3) comp_associative comp_inf.mult_right_dist_sup comp_inf.star_slide inf_top.right_neutral regular_complement_top)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q1 * ?q2\<^sup>\<star>"
     using mult_left_dist_sup mult_right_dist_sup sup_commute sup_left_commute by auto
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?pxy * ?q2\<^sup>\<star>"
     by (smt (verit, ccfv_threshold) comp_isotone inf.sup_right_divisibility inf_commute order.refl semiring.add_left_mono mult_assoc)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2 * ?q2 * ?q2\<^sup>\<star>"
     using 11 by simp
   also have "... \<le> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q1 * ?q2\<^sup>\<star>"
     by (smt comp_associative comp_isotone mult_right_isotone star.circ_increasing star.circ_transitive_equal star.left_plus_below_circ sup_right_isotone)
   also have "... = ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (smt (verit, best) comp_associative semiring.distrib_left star.circ_loop_fixpoint star.circ_transitive_equal star_involutive)
   finally have 13: "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (meson inf.cobounded2 mult_left_isotone order_lesseq_imp)
   hence "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> \<squnion> ?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using 12 by simp
   hence "?q3\<^sup>\<star> * ?q2 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (simp add: star_left_induct mult_assoc)
   hence "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q1 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone)
   hence "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q3\<^sup>+ * ?q2\<^sup>\<star>"
     using 2 by (simp add: vector_inf_comp)
   hence 14: "?q1 * ?q3\<^sup>\<star> * ?q2 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star>"
     using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
   have "p0 * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (metis comp_associative mult_1_right mult_left_isotone mult_right_isotone reflexive_mult_closed star.circ_reflexive)
   hence 15: "?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 3 dual_order.trans by blast
   have "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 13 mult_left_isotone by blast
   hence "?q3 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 15 by simp
   hence "?q3\<^sup>\<star> * ?r0 \<le> p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: star_left_induct mult_assoc)
   hence "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q1 * p0 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative mult_right_isotone)
   hence "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>+ * ?q2\<^sup>\<star> * ?r0"
     using 2 by (simp add: vector_inf_comp)
   hence 16: "?q1 * ?q3\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
   have "?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 = ?q1 * ?q3\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>+ * ?r0"
     by (smt (z3) comp_associative mult_right_dist_sup star.circ_back_loop_fixpoint star.circ_plus_same sup_commute)
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>+ * ?r0"
     using 16 sup_left_isotone by blast
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 14 by (smt (z3) inf.eq_refl semiring.distrib_right star.circ_transitive_equal sup.absorb2 sup_monoid.add_commute mult_assoc)
   also have "... = ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative star.circ_transitive_equal)
   finally have 17: "?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     .
   have "?r0 \<le> ?q2\<^sup>\<star> * ?r0"
     using star.circ_loop_fixpoint sup_right_divisibility by auto
   also have "... \<le> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using comp_associative star.circ_loop_fixpoint sup_right_divisibility by force
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using comp_associative star.circ_loop_fixpoint sup_right_divisibility by force
   finally have 18: "?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     .
   have "p0 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 = (?q2 \<squnion> ?q1) * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 1 by (smt (z3) comp_inf.mult_right_dist_sup comp_inf.star_plus inf_top.right_neutral regular_complement_top)
   also have "... = ?q2 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using mult_right_dist_sup by auto
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_left_increasing_sup star.circ_loop_fixpoint sup_left_isotone mult_assoc)
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>+ * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) mult_left_dist_sup semiring.combine_common_factor star.circ_loop_fixpoint sup_monoid.add_commute mult_assoc)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>+ * ?q2\<^sup>\<star> * ?r0"
     using 9 mult_left_isotone sup_right_isotone by auto
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_associative comp_isotone inf.eq_refl semiring.add_right_mono star.circ_transitive_equal star.left_plus_below_circ sup_commute)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q1 * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 6 sup_right_isotone by blast
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3 * ?q2\<^sup>\<star> * ?r0"
     using 17 by (smt (z3) le_iff_sup semiring.combine_common_factor semiring.distrib_right star.circ_loop_fixpoint sup_monoid.add_commute)
   also have "... \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (meson mult_left_isotone star.circ_increasing sup_right_isotone)
   also have "... = ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (smt (z3) comp_associative star.circ_loop_fixpoint star.circ_transitive_equal star_involutive)
   finally have "p0 * ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0 \<squnion> ?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     using 18 sup.boundedI by blast
   hence "p0\<^sup>\<star> * ?r0 \<le> ?q2\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: comp_associative star_left_induct)
   also have "... \<le> ?p\<^sup>\<star> * ?q3\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (metis mult_left_isotone star.circ_sub_dist sup_commute)
   also have "... \<le> ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?q2\<^sup>\<star> * ?r0"
     by (simp add: mult_left_isotone mult_right_isotone star_isotone)
   also have "... \<le> ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?p\<^sup>\<star> * ?r0"
     by (metis mult_isotone order.refl star.circ_sub_dist sup_commute)
   finally have 19: "p0\<^sup>\<star> * ?r0 \<le> ?p\<^sup>\<star> * ?r0"
     by (simp add: star.circ_transitive_equal)
   have 20: "?p\<^sup>\<star> \<le> p0\<^sup>\<star>"
     by (metis star.left_plus_circ star_isotone update_square_ub_plus)
   hence 21: "p0\<^sup>\<star> * ?r0 = ?p\<^sup>\<star> * ?r0"
     using 19 order.antisym mult_left_isotone by auto
   have "?p \<sqinter> 1 = (?q3 \<sqinter> 1) \<squnion> (?q2 \<sqinter> 1)"
     using comp_inf.semiring.distrib_right conv_involutive by auto
   also have "... = (?q1 \<sqinter> 1) \<squnion> (?q2 \<sqinter> 1)"
     using assms(3) acyclic_square path_splitting_invariant_def inf.sup_monoid.add_assoc by auto
   also have "... = (?pxy \<squnion> -?pxy) \<sqinter> p0 \<sqinter> 1"
     using inf_sup_distrib2 by auto
   also have "... = p0 \<sqinter> 1"
     using 1 by (metis inf.sup_monoid.add_commute inf_sup_distrib1 maddux_3_11_pp)
   finally show 22: "?p \<sqinter> 1 = p0 \<sqinter> 1"
     .
   have "?p\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
     using 20 by (metis conv_isotone conv_star_commute mult_left_isotone)
   hence 23: "?rp \<le> ?r0"
     using 22 comp_inf.mult_left_isotone by auto
   have 24: "disjoint_set_forest ?p"
     using 1 2 assms(3) disjoint_set_forest_update_square by blast
   hence 25: "point ?rp"
     using root_point assms(1) by auto
   have "?r0 * ?rp\<^sup>T = ?r0 * x\<^sup>T * ?p\<^sup>\<star> * (?p \<sqinter> 1)"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf.sup_monoid.add_commute one_inf_conv root_var star_one star_sup_one wcc_one)
   also have "... \<le> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * 1 * ?p\<^sup>\<star> * (?p \<sqinter> 1)"
     by (smt (z3) assms(1) comp_associative mult_left_isotone mult_right_isotone root_var)
   also have "... \<le> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     using 20 22 comp_isotone by force
   also have "... = (p0 \<sqinter> 1) * p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (simp add: assms(3) cancel_separate_eq sup_monoid.add_commute mult_assoc mult_left_dist_sup semiring.distrib_right)
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     using univalent_root_successors assms(3) by simp
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1) * ((p0 \<sqinter> 1) * p0\<^sup>\<star>)\<^sup>T"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_star_commute inf.sup_monoid.add_commute one_inf_conv star_one star_sup_one wcc_one)
   also have "... = (p0 \<sqinter> 1) * (p0 \<sqinter> 1)"
     by (metis univalent_root_successors assms(3) conv_dist_inf inf.sup_monoid.add_commute one_inf_conv sup_idem symmetric_one_closed)
   also have "... \<le> 1"
     by (simp add: coreflexive_mult_closed)
   finally have "?r0 * ?rp\<^sup>T \<le> 1"
     .
   hence "?r0 \<le> 1 * ?rp"
     using 25 shunt_bijective by blast
   hence 26: "?r0 = ?rp"
     using 23 order.antisym by simp
   have "?px * ?r0\<^sup>T = ?px * x\<^sup>T * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (smt (z3) comp_associative conv_dist_comp conv_dist_inf conv_involutive conv_star_commute inf.sup_monoid.add_commute one_inf_conv root_var star_one star_sup_one wcc_one)
   also have "... \<le> p0\<^sup>T\<^sup>\<star> * 1 * p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (smt (z3) assms(1) comp_associative mult_left_isotone mult_right_isotone root_var)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> p0\<^sup>T\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (simp add: assms(3) cancel_separate_eq sup_monoid.add_commute mult_right_dist_sup)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> ((p0 \<sqinter> 1) * p0\<^sup>\<star>)\<^sup>T"
     by (smt (z3) conv_dist_comp conv_dist_inf conv_star_commute inf.sup_monoid.add_commute one_inf_conv star_one star_sup_one wcc_one)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1) \<squnion> (p0 \<sqinter> 1)"
     by (metis univalent_root_successors assms(3) conv_dist_inf inf.sup_monoid.add_commute one_inf_conv symmetric_one_closed)
   also have "... = p0\<^sup>\<star> * (p0 \<sqinter> 1)"
     by (metis conv_involutive path_compression_1b sup.absorb2 sup_commute)
   also have "... \<le> p0\<^sup>\<star>"
     by (simp add: inf.coboundedI1 star.circ_increasing star.circ_mult_upper_bound)
   finally have 27: "?px * ?r0\<^sup>T \<le> p0\<^sup>\<star>"
     .
   thus 28: "?px \<le> p0\<^sup>\<star> * ?r0"
     by (simp add: assms(1,3) root_point shunt_bijective)
   have 29: "point ?r0"
     using root_point assms(1,3) by auto
   hence 30: "mapping (?r0\<^sup>T)"
     using bijective_conv_mapping by blast
   have "?r0 * (?px \<sqinter> p0) = ?r0 * top * (?px \<sqinter> p0)"
     using 29 by force
   also have "... = ?r0 * ?px\<^sup>T * p0"
     using 29 by (metis assms(1) covector_inf_comp_3 vector_covector vector_mult_closed)
   also have "... = ?r0 * x\<^sup>T * p0\<^sup>\<star> * p0"
     using comp_associative conv_dist_comp conv_star_commute by auto
   also have "... \<le> ?r0 * x\<^sup>T * p0\<^sup>\<star>"
     by (simp add: comp_associative mult_right_isotone star.circ_plus_same star.left_plus_below_circ)
   also have "... = ?r0 * ?px\<^sup>T"
     by (simp add: comp_associative conv_dist_comp conv_star_commute)
   also have "... = (?px * ?r0\<^sup>T)\<^sup>T"
     by (simp add: conv_dist_comp)
   also have "... \<le> p0\<^sup>T\<^sup>\<star>"
     using 27 conv_isotone conv_star_commute by fastforce
   finally have "?r0 * (?px \<sqinter> p0) \<le> p0\<^sup>T\<^sup>\<star>"
     .
   hence "?px \<sqinter> p0 \<le> ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 30 shunt_mapping by auto
   hence "?px \<sqinter> p0 \<le> p0\<^sup>\<star> * ?r0 \<sqinter> ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 28 inf.coboundedI2 inf.sup_monoid.add_commute by fastforce
   also have "... = p0\<^sup>\<star> * ?r0 * ?r0\<^sup>T * p0\<^sup>T\<^sup>\<star>"
     using 29 by (smt (z3) vector_covector vector_inf_comp vector_mult_closed)
   also have "... = ?p\<^sup>\<star> * ?r0 * ?r0\<^sup>T * ?p\<^sup>T\<^sup>\<star>"
     using 21 by (smt comp_associative conv_dist_comp conv_star_commute)
   also have "... = ?p\<^sup>\<star> * ?rp * ?rp\<^sup>T * ?p\<^sup>T\<^sup>\<star>"
     using 26 by auto
   also have "... \<le> ?p\<^sup>\<star> * 1 * ?p\<^sup>T\<^sup>\<star>"
     using 25 by (smt (z3) comp_associative mult_left_isotone mult_right_isotone)
   finally have 31: "?px \<sqinter> p0 \<le> fc ?p"
     by auto
   have "-?px \<sqinter> p0 \<le> ?p"
     by (simp add: inf.sup_monoid.add_commute le_supI1 sup_commute)
   also have "... \<le> fc ?p"
     using fc_increasing by auto
   finally have "p0 \<le> fc ?p"
     using 1 31 by (smt (z3) inf.sup_monoid.add_commute maddux_3_11_pp semiring.add_left_mono sup.orderE sup_commute)
   also have "... \<le> wcc ?p"
     using star.circ_sub_dist_3 by auto
   finally have 32: "wcc p0 \<le> wcc ?p"
     using wcc_below_wcc by blast
   have "?p \<le> wcc p0"
     by (simp add: inf.coboundedI1 inf.sup_monoid.add_commute star.circ_mult_upper_bound star.circ_sub_dist_1)
   hence "wcc ?p \<le> wcc p0"
     using wcc_below_wcc by blast
   hence "wcc ?p = wcc p0"
     using 32 order.antisym by blast
   thus "fc ?p = fc p0"
     using 24 assms(3) fc_wcc by auto
 qed
 
 lemma path_splitting_invariant_aux:
   assumes "path_splitting_invariant p x y p0"
   shows "p[[y]] = p0[[y]]"
     and "p[[p[[y]]]] = p0[[p0[[y]]]]"
     and "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     and "p \<sqinter> 1 = p0 \<sqinter> 1"
     and "fc p = fc p0"
 proof -
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   have "?p[[y]] = p0[[y]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (meson inf.cobounded2 order_lesseq_imp p_antitone_iff path_compression_1b)
   thus 1: "p[[y]] = p0[[y]]"
     using assms path_splitting_invariant_def by auto
   have "?p[[p0[[y]]]] = p0[[p0[[y]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (metis comp_isotone inf.boundedE inf.coboundedI2 inf.eq_refl p_antitone_iff selection_closed_id star.circ_increasing)
   thus 2: "p[[p[[y]]]] = p0[[p0[[y]]]]"
     using 1 assms path_splitting_invariant_def by auto
   have "?p[[p0[[p0[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     apply (rule put_get_different_vector)
     using assms find_set_precondition_def vector_complement_closed vector_inf_closed vector_mult_closed path_splitting_invariant_def apply force
     by (metis comp_associative comp_isotone conv_dist_comp conv_involutive conv_order inf.coboundedI2 inf.le_iff_sup mult_left_isotone p_antitone_iff p_antitone_inf star.circ_increasing star.circ_transitive_equal)
   thus "p[[p[[p[[y]]]]]] = p0[[p0[[p0[[y]]]]]]"
     using 2 assms path_splitting_invariant_def by auto
   show "p \<sqinter> 1 = p0 \<sqinter> 1"
     using assms path_splitting_invariant_aux_1(1) path_splitting_invariant_def find_set_precondition_def by auto
   show "fc p = fc p0"
     using assms path_splitting_invariant_aux_1(2) path_splitting_invariant_def find_set_precondition_def by auto
 qed
 
 lemma path_splitting_1:
   "find_set_precondition p0 x \<Longrightarrow> path_splitting_invariant p0 x x p0"
 proof -
   assume 1: "find_set_precondition p0 x"
   show "path_splitting_invariant p0 x x p0"
   proof (unfold path_splitting_invariant_def, intro conjI)
     show "find_set_precondition p0 x"
       using 1 by simp
     show "vector x" "injective x" "surjective x"
       using 1 find_set_precondition_def by auto
     show "x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: path_compression_1b)
     have "(p0 * p0)\<^sup>T\<^sup>\<star> * x \<le> p0\<^sup>T\<^sup>\<star> * x"
       by (simp add: conv_dist_comp mult_left_isotone star.circ_square)
     thus "p0[p0\<^sup>T\<^sup>\<star> * x - p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p0"
       by (smt (z3) inf.le_iff_sup inf_commute maddux_3_11_pp p_antitone_inf pseudo_complement)
     show "univalent p0" "total p0" "acyclic (p0 - 1)"
       using 1 find_set_precondition_def by auto
   qed
 qed
 
 lemma path_splitting_2:
   "path_splitting_invariant p x y p0 \<and> y \<noteq> p[[y]] \<Longrightarrow> path_splitting_invariant (p[y\<longmapsto>p[[p[[y]]]]]) x (p[[y]]) p0 \<and> ((p[y\<longmapsto>p[[p[[y]]]]])\<^sup>T\<^sup>\<star> * (p[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
 proof -
   let ?py = "p[[y]]"
   let ?ppy = "p[[?py]]"
   let ?pyppy = "p[y\<longmapsto>?ppy]"
   let ?p2 = "p0 * p0"
   let ?p2t = "?p2\<^sup>T"
   let ?p2ts = "?p2t\<^sup>\<star>"
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   let ?py2 = "-(p0\<^sup>T\<^sup>\<star> * y)"
   let ?pxy = "?px \<sqinter> ?py2"
   let ?p = "p0[?pxy\<longmapsto>?p2t]"
   let ?pty = "p0\<^sup>T * y"
   let ?pt2y = "p0\<^sup>T * p0\<^sup>T * y"
   let ?pt2sy = "p0\<^sup>T\<^sup>\<star> * p0\<^sup>T * p0\<^sup>T * y"
   let ?ptpy = "p0\<^sup>T\<^sup>+ * y"
   assume 1: "path_splitting_invariant p x y p0 \<and> y \<noteq> ?py"
   have 2: "point ?pty \<and> point ?pt2y"
     using 1 by (smt (verit) comp_associative read_injective read_surjective path_splitting_invariant_def)
   show "path_splitting_invariant ?pyppy x (p[[y]]) p0 \<and> (?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]))\<down> < (p\<^sup>T\<^sup>\<star> * y)\<down>"
   proof
     show "path_splitting_invariant ?pyppy x (p[[y]]) p0"
     proof (unfold path_splitting_invariant_def, intro conjI)
       show 3: "find_set_precondition ?pyppy x"
       proof (unfold find_set_precondition_def, intro conjI)
         show "univalent ?pyppy"
           using 1 find_set_precondition_def read_injective update_univalent path_splitting_invariant_def by auto
         show "total ?pyppy"
           using 1 bijective_regular find_set_precondition_def read_surjective update_total path_splitting_invariant_def by force
         show "acyclic (?pyppy - 1)"
           apply (rule update_acyclic_3)
           using 1 find_set_precondition_def path_splitting_invariant_def apply blast
           using 1 2 comp_associative path_splitting_invariant_aux(2) apply force
           using 1 path_splitting_invariant_def apply blast
           by (metis inf.order_lesseq_imp mult_isotone star.circ_increasing star.circ_square mult_assoc)
         show "vector x" "injective x" "surjective x"
           using 1 find_set_precondition_def path_splitting_invariant_def by auto
       qed
       show "vector (p[[y]])"
         using 1 comp_associative path_splitting_invariant_def by auto
       show "injective (p[[y]])"
         using 1 3 read_injective path_splitting_invariant_def find_set_precondition_def by auto
       show "surjective (p[[y]])"
         using 1 3 read_surjective path_splitting_invariant_def find_set_precondition_def by auto
       show "p[[y]] \<le> ?px"
       proof -
         have "p[[y]] = p0[[y]]"
           using 1 path_splitting_invariant_aux(1) by blast
         also have "... \<le> p0\<^sup>T * ?px"
           using 1 path_splitting_invariant_def mult_right_isotone by force
         also have "... \<le> ?px"
           by (metis comp_associative mult_left_isotone star.left_plus_below_circ)
         finally show ?thesis
           .
       qed
       show "p0[?px - p0\<^sup>T\<^sup>\<star> * (p[[y]])\<longmapsto>?p2t] = ?pyppy"
       proof -
         have 4: "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = ?pyppy"
         proof (cases "y \<le> -?ptpy")
           case True
           hence "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = p[y\<longmapsto>?p2t]"
             using 1 inf.absorb2 path_splitting_invariant_def by auto
           also have "... = ?pyppy"
             using 1 by (metis comp_associative conv_dist_comp path_splitting_invariant_aux(2) path_splitting_invariant_def update_point_get)
           finally show ?thesis
             .
         next
           case False
           have "vector (-?ptpy)"
             using 1 vector_complement_closed vector_mult_closed path_splitting_invariant_def by blast
           hence 5: "y \<le> ?ptpy"
             using 1 by (smt (verit, del_insts) False bijective_regular point_in_vector_or_complement regular_closed_star regular_mult_closed total_conv_surjective univalent_conv_injective path_splitting_invariant_def)
           hence "?px \<sqinter> -?ptpy \<sqinter> y = bot"
             by (simp add: inf.coboundedI2 p_antitone pseudo_complement)
           hence 6: "p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t] = p"
             by simp
           have 7: "y = root p0 y"
             using 1 5 loop_root_2 path_splitting_invariant_def by blast
           have "?pyppy = p[y\<longmapsto>p0[[p0[[y]]]]]"
             using 1 path_splitting_invariant_aux(2) by force
           also have "... = p[y\<longmapsto>p0[[y]]]"
             using 1 7 by (metis root_successor_loop path_splitting_invariant_def)
           also have "... = p[y\<longmapsto>?py]"
             using 1 path_splitting_invariant_aux(1) by force
           also have "... = p"
             using 1 get_put path_splitting_invariant_def by blast
           finally show ?thesis
             using 6 by simp
         qed
         have 8: "-?ptpy = ?py2 \<squnion> (-?ptpy \<sqinter> y)"
         proof (rule order.antisym)
           have 9: "regular (p0\<^sup>T\<^sup>\<star> * y) \<and> regular ?ptpy"
             using 1 bijective_regular mapping_conv_bijective pp_dist_star regular_mult_closed path_splitting_invariant_def by auto
           have "p0\<^sup>T\<^sup>\<star> * y \<le> ?ptpy \<squnion> y"
             by (simp add: star.circ_loop_fixpoint mult_assoc)
           also have "... = ?ptpy \<squnion> (-?ptpy \<sqinter> y)"
             using 9 by (metis maddux_3_21_pp)
           hence "p0\<^sup>T\<^sup>\<star> * y \<sqinter> -?ptpy \<le> -?ptpy \<sqinter> y"
             using calculation half_shunting sup_commute by auto
           thus "-?ptpy \<le> ?py2 \<squnion> (-?ptpy \<sqinter> y)"
             using 9 by (smt (z3) inf.sup_monoid.add_commute shunting_var_p sup.left_commute sup_commute)
           have "-(p0\<^sup>T\<^sup>\<star> * y) \<le> -?ptpy"
             by (simp add: comp_isotone p_antitone star.left_plus_below_circ)
           thus "-(p0\<^sup>T\<^sup>\<star> * y) \<squnion> (-?ptpy \<sqinter> y) \<le> -?ptpy"
             by simp
         qed
         have "regular ?px" "regular y"
           using 1 bijective_regular find_set_precondition_def mapping_regular pp_dist_comp regular_closed_star regular_conv_closed path_splitting_invariant_def by auto
         hence 10: "regular (?px \<sqinter> -?ptpy \<sqinter> y)"
           by auto
         have "p0[?px \<sqinter> -(p0\<^sup>T\<^sup>\<star> * (p[[y]]))\<longmapsto>?p2t] = p0[?px \<sqinter> -?ptpy\<longmapsto>?p2t]"
           using 1 by (smt comp_associative path_splitting_invariant_aux(1) star_plus)
         also have "... = p0[?pxy \<squnion> (?px \<sqinter> -?ptpy \<sqinter> y)\<longmapsto>?p2t]"
           using 8 by (metis comp_inf.semiring.distrib_left inf.sup_monoid.add_assoc)
         also have "... = ?p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t]"
           using 10 by (smt (z3) update_same comp_inf.semiring.mult_not_zero inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
         also have "... = p[?px \<sqinter> -?ptpy \<sqinter> y\<longmapsto>?p2t]"
           using 1 path_splitting_invariant_def by auto
         also have "... = ?pyppy"
           using 4 by auto
         finally show ?thesis
           .
       qed
       show "univalent p0" "total p0" "acyclic (p0 - 1)"
         using 1 path_splitting_invariant_def by auto
     qed
     let ?s = "{ z . regular z \<and> z \<le> p\<^sup>T\<^sup>\<star> * y }"
     let ?t = "{ z . regular z \<and> z \<le> ?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) }"
     have "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>+\<^sup>T\<^sup>\<star> * (p[[y]])"
       using 1 path_splitting_invariant_def update_square_plus conv_order mult_left_isotone star_isotone by force
     also have "... = p\<^sup>T\<^sup>\<star> * p\<^sup>T * y"
       by (simp add: conv_plus_commute star.left_plus_circ mult_assoc)
     also have "... = p\<^sup>T\<^sup>+ * y"
       by (simp add: star_plus)
     finally have 11: "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>+ * y"
       .
     hence "?pyppy\<^sup>T\<^sup>\<star> * (p[[y]]) \<le> p\<^sup>T\<^sup>\<star> * y"
       using mult_left_isotone order_lesseq_imp star.left_plus_below_circ by blast
     hence 12: "?t \<subseteq> ?s"
       using order_trans by auto
     have 13: "y \<in> ?s"
       using 1 bijective_regular path_compression_1b path_splitting_invariant_def by force
     have 14: "\<not> y \<in> ?t"
     proof
       assume "y \<in> ?t"
       hence "y \<le> ?pyppy\<^sup>T\<^sup>\<star> * (p[[y]])"
         by simp
       hence "y \<le> p\<^sup>T\<^sup>+ * y"
         using 11 dual_order.trans by blast
       hence "y = root p y"
         using 1 find_set_precondition_def loop_root_2 path_splitting_invariant_def by blast
       hence "y = ?py"
         using 1 by (metis find_set_precondition_def root_successor_loop path_splitting_invariant_def)
       thus False
         using 1 by simp
     qed
     show "card ?t < card ?s"
       apply (rule psubset_card_mono)
       subgoal using finite_regular by simp
       subgoal using 12 13 14 by auto
       done
   qed
 qed
 
 lemma path_splitting_3:
   "path_splitting_invariant p x y p0 \<and> y = p[[y]] \<Longrightarrow> path_splitting_postcondition p x y p0"
 proof -
   assume 1: "path_splitting_invariant p x y p0 \<and> y = p[[y]]"
   show "path_splitting_postcondition p x y p0"
-  proof (unfold path_splitting_postcondition_def path_compression_precondition_def, intro conjI)
+  proof (unfold path_splitting_postcondition_def, intro conjI)
     show "univalent p" "total p" "acyclic (p - 1)"
       using 1 find_set_precondition_def path_splitting_invariant_def by blast+
-    show "vector x" "injective x" "surjective x"
-      using 1 find_set_precondition_def path_splitting_invariant_def by blast+
-    show 2: "vector y" "injective y" "surjective y"
-      using 1 path_splitting_invariant_def by blast+
-    show 3: "p \<sqinter> 1 = p0 \<sqinter> 1"
+    show 2: "p \<sqinter> 1 = p0 \<sqinter> 1"
       using 1 path_splitting_invariant_aux(4) by blast
-    show 4: "fc p = fc p0"
+    show 3: "fc p = fc p0"
       using 1 path_splitting_invariant_aux(5) by blast
     have "y \<le> p0\<^sup>T\<^sup>\<star> * x"
       using 1 path_splitting_invariant_def by simp
-    hence 5: "y * x\<^sup>T \<le> fc p0"
+    hence 4: "y * x\<^sup>T \<le> fc p0"
       using 1 by (metis dual_order.trans fc_wcc find_set_precondition_def shunt_bijective star.circ_decompose_11 star_decompose_1 star_outer_increasing path_splitting_invariant_def)
-    have 6: "y = p0[[y]]"
+    have 5: "y = p0[[y]]"
       using 1 path_splitting_invariant_aux(1) by auto
     hence "y = root p0 y"
-      using 2 loop_root by auto
+      using 1 path_splitting_invariant_def loop_root by auto
     also have "... = root p0 x"
-      using 1 2 5 find_set_precondition_def path_splitting_invariant_def same_component_same_root by auto
+      using 1 4 find_set_precondition_def path_splitting_invariant_def same_component_same_root by auto
     also have "... = root p x"
-      using 1 3 4 by (metis find_set_precondition_def path_splitting_invariant_def same_root)
+      using 1 2 3 by (metis find_set_precondition_def path_splitting_invariant_def same_root)
     finally show "y = root p x"
       .
     have "p0\<^sup>T\<^sup>\<star> * y = y"
-      using 6 order.antisym path_compression_1b star_left_induct_mult_equal by auto
-    hence 7: "p0[p0\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
+      using 5 order.antisym path_compression_1b star_left_induct_mult_equal by auto
+    hence 6: "p0[p0\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T] = p"
       using 1 path_splitting_invariant_def by auto
     have "(p0 * p0)\<^sup>T * y = y"
-      using 6 mult_assoc conv_dist_comp by auto
+      using 5 mult_assoc conv_dist_comp by auto
     hence "y \<sqinter> p0 * p0 = y \<sqinter> p0"
-      using 2 6 by (metis update_postcondition)
-    hence 8: "y \<sqinter> p = y \<sqinter> p0 * p0"
-      using 1 2 6 by (smt update_postcondition)
+      using 1 5 by (smt path_splitting_invariant_def update_postcondition)
+    hence 7: "y \<sqinter> p = y \<sqinter> p0 * p0"
+      using 1 5 by (smt path_splitting_invariant_def update_postcondition)
     have "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = (p0[p0\<^sup>T\<^sup>\<star> * x - y\<longmapsto>(p0 * p0)\<^sup>T])[p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
       using 1 bijective_regular path_splitting_invariant_def update_split by blast
     also have "... = p[p0\<^sup>T\<^sup>\<star> * x \<sqinter> y\<longmapsto>(p0 * p0)\<^sup>T]"
-      using 7 by simp
+      using 6 by simp
     also have "... = p"
       apply (rule update_same_sub)
-      using 8 apply simp
+      using 7 apply simp
       apply simp
       using 1 bijective_regular inf.absorb2 path_splitting_invariant_def by auto
     finally show "p0[p0\<^sup>T\<^sup>\<star> * x\<longmapsto>(p0 * p0)\<^sup>T] = p"
       .
   qed
 qed
 
 theorem find_path_splitting:
   "VARS p t y
   [ find_set_precondition p x \<and> p0 = p ]
   y := x;
   WHILE y \<noteq> p[[y]]
     INV { path_splitting_invariant p x y p0 }
     VAR { (p\<^sup>T\<^sup>\<star> * y)\<down> }
      DO t := p[[y]];
         p[y] := p[[p[[y]]]];
         y := t
      OD
   [ path_splitting_postcondition p x y p0 ]"
   apply vcg_tc_simp
     apply (fact path_splitting_1)
    apply (fact path_splitting_2)
   by (fact path_splitting_3)
 
 end
 
 section \<open>Verifying Union by Rank\<close>
 
 text \<open>
 In this section we verify the union-by-rank operation of disjoint-set forests.
 The rank of a node is an upper bound of the height of the subtree rooted at that node.
 The rank array of a disjoint-set forest maps each node to its rank.
 This can be represented as a homogeneous relation since the possible rank values are $0, \dots, n-1$ where $n$ is the number of nodes of the disjoint-set forest.
 \<close>
 
 subsection \<open>Peano structures\<close>
 
 text \<open>
 Since ranks are natural numbers we start by introducing basic Peano arithmetic.
 Numbers are represented as (relational) points.
 Constant \<open>Z\<close> represents the number $0$.
 Constant \<open>S\<close> represents the successor function.
 The successor of a number $x$ is obtained by the relational composition \<open>S\<^sup>T * x\<close>.
 The composition \<open>S * x\<close> results in the predecessor of $x$.
 \<close>
 
 class peano_signature =
   fixes Z :: "'a"
   fixes S :: "'a"
 
 text \<open>
 The numbers will be used in arrays, which are represented by homogeneous finite relations.
 Such relations can only represent finitely many numbers.
 This means that we weaken the Peano axioms, which are usually used to obtain (infinitely many) natural numbers.
 Axiom \<open>Z_point\<close> specifies that $0$ is a number.
 Axiom \<open>S_univalent\<close> specifies that every number has at most one `successor'.
 Together with axiom \<open>S_total\<close>, which is added later, this means that every number has exactly one `successor'.
 Axiom \<open>S_injective\<close> specifies that numbers with the same successor are equal.
 Axiom \<open>S_star_Z_top\<close> specifies that every number can be obtained from $0$ by finitely many applications of the successor.
 We omit the Peano axiom \<open>S * Z = bot\<close> which would specify that $0$ is not the successor of any number.
 Since only finitely many numbers will be represented, the remaining axioms will model successor modulo $m$ for some $m$ depending on the carrier of the algebra.
 That is, the algebra will be able to represent numbers $0, \dots, m-1$ where the successor of $m-1$ is $0$.
 \<close>
 
 class skra_peano_1 = stone_kleene_relation_algebra_tarski_consistent + peano_signature +
   assumes Z_point: "point Z"
   assumes S_univalent: "univalent S"
   assumes S_injective: "injective S"
   assumes S_star_Z_top: "S\<^sup>T\<^sup>\<star> * Z = top"
 begin
 
 lemma conv_Z_Z:
   "Z\<^sup>T * Z = top"
   by (simp add: Z_point point_conv_comp)
 
 lemma Z_below_S_star:
   "Z \<le> S\<^sup>\<star>"
 proof -
   have "top * Z\<^sup>T \<le> S\<^sup>T\<^sup>\<star>"
     using S_star_Z_top Z_point shunt_bijective by blast
   thus ?thesis
     using Z_point conv_order conv_star_commute vector_conv_covector by force
 qed
 
 lemma S_connected:
   "S\<^sup>T\<^sup>\<star> * S\<^sup>\<star> = top"
   by (metis Z_below_S_star S_star_Z_top mult_left_dist_sup sup.orderE sup_commute top.extremum)
 
 lemma S_star_connex:
   "S\<^sup>\<star> \<squnion> S\<^sup>T\<^sup>\<star> = top"
   using S_connected S_univalent cancel_separate_eq sup_commute by auto
 
 lemma Z_sup_conv_S_top:
   "Z \<squnion> S\<^sup>T * top = top"
   using S_star_Z_top star.circ_loop_fixpoint sup_commute by auto
 
 lemma top_S_sup_conv_Z:
   "top * S \<squnion> Z\<^sup>T = top"
   by (metis S_star_Z_top conv_dist_comp conv_involutive conv_star_commute star.circ_back_loop_fixpoint symmetric_top_closed)
 
 lemma S_inf_1_below_Z:
   "S \<sqinter> 1 \<le> Z"
 proof -
   have "(S \<sqinter> 1) * S\<^sup>T \<le> S \<sqinter> 1"
     by (metis S_injective conv_dist_comp coreflexive_symmetric inf.boundedI inf.cobounded1 inf.cobounded2 injective_codomain)
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> \<le> S \<sqinter> 1"
     using star_right_induct_mult by blast
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> * Z \<le> (S \<sqinter> 1) * Z"
     by (simp add: mult_left_isotone)
   also have "... \<le> Z"
     by (metis comp_left_subdist_inf inf.boundedE mult_1_left)
   finally show ?thesis
     using S_star_Z_top inf.order_trans top_right_mult_increasing mult_assoc by auto
 qed
 
 lemma S_inf_1_below_conv_Z:
   "S \<sqinter> 1 \<le> Z\<^sup>T"
   using S_inf_1_below_Z conv_order coreflexive_symmetric by fastforce
 
 text \<open>
 The successor operation provides a convenient way to compare two natural numbers.
 Namely, $k < m$ if $m$ can be reached from $k$ by finitely many applications of the successor, formally \<open>m \<le> S\<^sup>T\<^sup>\<star> * k\<close> or \<open>k \<le> S\<^sup>\<star> * m\<close>.
 This does not work for numbers modulo $m$ since comparison depends on the chosen representative.
 We therefore work with a modified successor relation \<open>S'\<close>, which is a partial function that computes the successor for all numbers except $m-1$.
 If $S$ is surjective, the point \<open>M\<close> representing the greatest number $m-1$ is the predecessor of $0$ under \<open>S\<close>.
 If $S$ is not surjective (like for the set of all natural numbers), \<open>M = bot\<close>.
 \<close>
 
 abbreviation "S' \<equiv> S - Z\<^sup>T"
 abbreviation "M \<equiv> S * Z"
 
 lemma M_point_iff_S_surjective:
   "point M \<longleftrightarrow> surjective S"
 proof
   assume 1: "point M"
   hence "1 \<le> Z\<^sup>T * S\<^sup>T * S * Z"
     using comp_associative conv_dist_comp surjective_var by auto
   hence "Z \<le> S\<^sup>T * S * Z"
     using 1 Z_point bijective_reverse mult_assoc by auto
   also have "... \<le> S\<^sup>T * top"
     by (simp add: comp_isotone mult_assoc)
   finally have "S\<^sup>T * S\<^sup>T * top \<squnion> Z \<le> S\<^sup>T * top"
     using mult_isotone mult_assoc by force
   hence "S\<^sup>T\<^sup>\<star> * Z \<le> S\<^sup>T * top"
     by (simp add: star_left_induct mult_assoc)
   thus "surjective S"
     by (simp add: S_star_Z_top order.antisym surjective_conv_total)
 next
   assume "surjective S"
   thus "point M"
     by (metis S_injective Z_point comp_associative injective_mult_closed)
 qed
 
 lemma S'_univalent:
   "univalent S'"
   by (simp add: S_univalent univalent_inf_closed)
 
 lemma S'_injective:
   "injective S'"
   by (simp add: S_injective injective_inf_closed)
 
 lemma S'_Z:
   "S' * Z = bot"
   by (simp add: Z_point covector_vector_comp injective_comp_right_dist_inf)
 
 lemma S'_irreflexive:
   "irreflexive S'"
   using S_inf_1_below_conv_Z order_lesseq_imp p_shunting_swap pp_increasing by blast
 
 end
 
 class skra_peano_2 = skra_peano_1 +
   assumes S_total: "total S"
 begin
 
 lemma S_mapping:
   "mapping S"
   by (simp add: S_total S_univalent)
 
 lemma M_bot_iff_S_not_surjective:
   "M \<noteq> bot \<longleftrightarrow> surjective S"
 proof
   assume "M \<noteq> bot"
   hence "top * S * Z = top"
     by (metis S_mapping Z_point bijective_regular comp_associative mapping_regular regular_mult_closed tarski)
   hence "Z\<^sup>T \<le> top * S"
     using M_point_iff_S_surjective S_injective Z_point comp_associative injective_mult_closed by auto
   thus "surjective S"
     using sup.orderE top_S_sup_conv_Z by fastforce
 next
   assume "surjective S"
   thus "M \<noteq> bot"
     using M_point_iff_S_surjective consistent covector_bot_closed by force
 qed
 
 lemma M_point_or_bot:
   "point M \<or> M = bot"
   using M_bot_iff_S_not_surjective M_point_iff_S_surjective by blast
 
 text \<open>Alternative way to express \<open>S'\<close>\<close>
 
 lemma S'_var:
   "S' = S - M"
 proof -
   have "S' = S * (1 - Z\<^sup>T)"
     by (simp add: Z_point covector_comp_inf vector_conv_compl)
   also have "... = S * (1 - Z)"
     by (metis conv_complement one_inf_conv)
   also have "... = S * 1 \<sqinter> S * -Z"
     by (simp add: S_mapping univalent_comp_left_dist_inf)
   also have "... = S - M"
     by (simp add: comp_mapping_complement S_mapping)
   finally show ?thesis
     .
 qed
 
 text \<open>Special case of just $1$ number\<close>
 
 lemma M_is_Z_iff_1_is_top:
   "M = Z \<longleftrightarrow> 1 = top"
 proof
   assume "M = Z"
   hence "Z = S\<^sup>T * Z"
     by (metis S_mapping Z_point order.antisym bijective_reverse inf.eq_refl shunt_mapping)
   thus "1 = top"
     by (metis S_star_Z_top Z_point inf.eq_refl star_left_induct sup.absorb2 symmetric_top_closed top_le)
 next
   assume "1 = top"
   thus "M = Z"
     using S_mapping comp_right_one mult_1_left by auto
 qed
 
 lemma S_irreflexive:
   assumes "M \<noteq> Z"
   shows "irreflexive S"
 proof -
   have "(S \<sqinter> 1) * S\<^sup>T \<le> S \<sqinter> 1"
     by (smt (z3) S_injective S_mapping coreflexive_comp_top_inf dual_order.eq_iff inf.cobounded1 inf.sup_monoid.add_commute inf.sup_same_context mult_left_isotone one_inf_conv top_right_mult_increasing total_var)
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> \<le> S \<sqinter> 1"
     using star_right_induct_mult by blast
   hence "(S \<sqinter> 1) * S\<^sup>T\<^sup>\<star> * Z \<le> (S \<sqinter> 1) * Z"
     by (simp add: mult_left_isotone)
   also have "... = M \<sqinter> Z"
     by (simp add: Z_point injective_comp_right_dist_inf)
   also have "... = bot"
     by (smt (verit, ccfv_threshold) M_point_or_bot assms Z_point bijective_one_closed bijective_regular comp_associative conv_complement coreflexive_comp_top_inf epm_3 inf.sup_monoid.add_commute one_inf_conv regular_mult_closed star.circ_increasing star.circ_zero tarski vector_conv_covector vector_export_comp_unit)
   finally have "S \<sqinter> 1 \<le> bot"
     using S_star_Z_top comp_associative le_bot top_right_mult_increasing by fastforce
   thus ?thesis
     using le_bot pseudo_complement by blast
 qed
 
 text \<open>
 We show that \<open>S'\<close> satisfies most properties of \<open>S\<close>.
 \<close>
 
 lemma M_regular:
   "regular M"
   using S_mapping Z_point bijective_regular mapping_regular regular_mult_closed by blast
 
 lemma S'_regular:
   "regular S'"
   using S_mapping mapping_regular by auto
 
 lemma S'_star_Z_top:
   "S'\<^sup>T\<^sup>\<star> * Z = top"
 proof -
   have "S\<^sup>T\<^sup>\<star> * Z = (S' \<squnion> (S \<sqinter> M))\<^sup>T\<^sup>\<star> * Z"
     by (metis M_regular maddux_3_11_pp S'_var)
   also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z"
   proof (cases "M = bot")
     case True
     thus ?thesis
       by simp
   next
     case False
     hence "point M"
       using M_point_or_bot by auto
     hence "arc (S \<sqinter> M)"
       using S_mapping mapping_inf_point_arc by blast
     hence 1: "arc ((S \<sqinter> M)\<^sup>T)"
       using conv_involutive by auto
     have 2: "S \<sqinter> M \<le> Z\<^sup>T"
       by (metis S'_var Z_point bijective_regular conv_complement inf.cobounded2 p_shunting_swap)
     have "(S' \<squnion> (S \<sqinter> M))\<^sup>T\<^sup>\<star> * Z = (S'\<^sup>T \<squnion> (S \<sqinter> M)\<^sup>T)\<^sup>\<star> * Z"
       by (simp add: S'_var conv_dist_sup)
     also have "... = (S'\<^sup>T\<^sup>\<star> * (S \<sqinter> M)\<^sup>T * S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>T\<^sup>\<star>) * Z"
       using 1 star_arc_decompose sup_commute by auto
     also have "... = S'\<^sup>T\<^sup>\<star> * (S \<sqinter> M)\<^sup>T * S'\<^sup>T\<^sup>\<star> * Z \<squnion> S'\<^sup>T\<^sup>\<star> * Z"
       using mult_right_dist_sup by auto
     also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z\<^sup>T\<^sup>T * S'\<^sup>T\<^sup>\<star> * Z \<squnion> S'\<^sup>T\<^sup>\<star> * Z"
       using 2 by (meson comp_isotone conv_isotone inf.eq_refl semiring.add_mono)
     also have "... \<le> S'\<^sup>T\<^sup>\<star> * Z"
       by (metis Z_point comp_associative conv_involutive le_supI mult_right_isotone top.extremum)
     finally show ?thesis
       .
   qed
   finally show ?thesis
     using S_star_Z_top top_le by auto
 qed
 
 lemma Z_below_S'_star:
   "Z \<le> S'\<^sup>\<star>"
   by (metis S'_star_Z_top Z_point comp_associative comp_right_one conv_order conv_star_commute mult_right_isotone vector_conv_covector)
 
 lemma S'_connected:
   "S'\<^sup>T\<^sup>\<star> * S'\<^sup>\<star> = top"
   by (metis Z_below_S'_star S'_star_Z_top mult_left_dist_sup sup.orderE sup_commute top.extremum)
 
 lemma S'_star_connex:
   "S'\<^sup>\<star> \<squnion> S'\<^sup>T\<^sup>\<star> = top"
   using S'_connected S'_univalent cancel_separate_eq sup_commute by auto
 
 lemma Z_sup_conv_S'_top:
   "Z \<squnion> S'\<^sup>T * top = top"
   using S'_star_Z_top star.circ_loop_fixpoint sup_commute by auto
 
 lemma top_S'_sup_conv_Z:
   "top * S' \<squnion> Z\<^sup>T = top"
   by (metis S'_star_Z_top conv_dist_comp conv_involutive conv_star_commute star.circ_back_loop_fixpoint symmetric_top_closed)
 
 lemma S_power_point_or_bot:
   assumes "regular S'"
   shows "point (S'\<^sup>T ^ n * Z) \<or> S'\<^sup>T ^ n * Z = bot"
 proof -
   have 1: "regular (S'\<^sup>T ^ n * Z)"
     using assms Z_point bijective_regular regular_conv_closed regular_mult_closed regular_power_closed by auto
   have "injective (S'\<^sup>T ^ n)"
     by (simp add: injective_power_closed S'_univalent)
   hence "injective (S'\<^sup>T ^ n * Z)"
     using Z_point injective_mult_closed by blast
   thus ?thesis
     using 1 Z_point comp_associative tarski by force
 qed
 
 end
 
 subsection \<open>Initialising Ranks\<close>
 
 text \<open>
 We show that the rank array satisfies three properties which are established/preserved by the union-find operations.
 First, every node has a rank, that is, the rank array is a mapping.
 Second, the rank of a node is strictly smaller than the rank of its parent, except if the node is a root.
 This implies that the rank of a node is an upper bound on the height of its subtree.
 Third, the number of roots in the disjoint-set forest (the number of disjoint sets) is not larger than $m-k$ where $m$ is the total number of nodes and $k$ is the maximum rank of any node.
 The third property is useful to show that ranks never overflow (exceed $m-1$).
 To compare the number of roots and $m-k$ we use the existence of an injective univalent relation between the set of roots and the set of $m-k$ largest numbers, both represented as vectors.
 The three properties are captured in \<open>rank_property\<close>.
 \<close>
 
 class skra_peano_3 = stone_kleene_relation_algebra_tarski_finite_regular + skra_peano_2
 begin
 
 definition "card_less_eq v w \<equiv> \<exists>i . injective i \<and> univalent i \<and> regular i \<and> v \<le> i * w"
 definition "rank_property p rank \<equiv> mapping rank \<and> (p - 1) * rank \<le> rank * S'\<^sup>+ \<and> card_less_eq (roots p) (-(S'\<^sup>+ * rank\<^sup>T * top))"
 
 end
 
 class skra_peano_4 = stone_kleene_relation_algebra_choose_point_finite_regular + skra_peano_2
 begin
 
 subclass skra_peano_3 ..
 
 text \<open>
 The initialisation loop is augmented by setting the rank of each node to $0$.
 The resulting rank array satisfies the desired properties explained above.
 \<close>
 
 theorem init_ranks:
   "VARS h p x rank
   [ True ]
   FOREACH x
     USING h
       INV { p - h = 1 - h \<and> rank - h = Z\<^sup>T - h }
        DO p := make_set p x;
           rank[x] := Z
        OD
   [ p = 1 \<and> disjoint_set_forest p \<and> rank = Z\<^sup>T \<and> rank_property p rank \<and> h = bot ]"
 proof vcg_tc_simp
   fix h p rank
   let ?x = "choose_point h"
   let ?m = "make_set p ?x"
   let ?rank = "rank[?x\<longmapsto>Z]"
   assume 1: "regular h \<and> vector h \<and> p - h = 1 - h \<and> rank - h = Z\<^sup>T - h \<and> h \<noteq> bot"
   show "vector (-?x \<sqinter> h) \<and>
         ?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h) \<and>
         ?rank \<sqinter> (--?x \<squnion> -h) = Z\<^sup>T \<sqinter> (--?x \<squnion> -h) \<and>
         card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
   proof (intro conjI)
     show "vector (-?x \<sqinter> h)"
       using 1 choose_point_point vector_complement_closed vector_inf_closed by blast
     have 2: "point ?x \<and> regular ?x"
       using 1 bijective_regular choose_point_point by blast
     have 3: "-h \<le> -?x"
       using choose_point_decreasing p_antitone_iff by auto
     have 4: "?x \<sqinter> ?m = ?x * ?x\<^sup>T \<and> -?x \<sqinter> ?m = -?x \<sqinter> p"
       using 1 choose_point_point make_set_function make_set_postcondition_def by auto
     have "?m \<sqinter> (--?x \<squnion> -h) = (?m \<sqinter> ?x) \<squnion> (?m - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = ?x * ?x\<^sup>T \<squnion> (?m \<sqinter> -?x \<sqinter> -h)"
       using 3 4 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = ?x * ?x\<^sup>T \<squnion> (1 - h)"
       using 1 3 4 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = (1 \<sqinter> ?x) \<squnion> (1 - h)"
       using 2 by (metis inf.cobounded2 inf.sup_same_context one_inf_conv vector_covector)
     also have "... = 1 \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?m \<sqinter> (--?x \<squnion> -h) = 1 \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "?x \<sqinter> ?rank = ?x \<sqinter> Z\<^sup>T \<and> -?x \<sqinter> ?rank = -?x \<sqinter> rank"
       by (smt (z3) inf_commute order_refl update_inf_different update_inf_same)
     have "?rank \<sqinter> (--?x \<squnion> -h) = (?rank \<sqinter> ?x) \<squnion> (?rank - h)"
       using 2 comp_inf.comp_left_dist_sup by auto
     also have "... = (?x \<sqinter> Z\<^sup>T) \<squnion> (?rank \<sqinter> -?x \<sqinter> -h)"
       using 3 5 by (smt (z3) inf_absorb2 inf_assoc inf_commute)
     also have "... = (Z\<^sup>T \<sqinter> ?x) \<squnion> (Z\<^sup>T - h)"
       using 1 3 5 inf.absorb2 inf.sup_monoid.add_assoc inf_commute by auto
     also have "... = Z\<^sup>T \<sqinter> (--?x \<squnion> -h)"
       using 2 comp_inf.semiring.distrib_left by auto
     finally show "?rank \<sqinter> (--?x \<squnion> -h) = Z\<^sup>T \<sqinter> (--?x \<squnion> -h)"
       .
     have 5: "\<not> ?x \<le> -?x"
       using 1 2 by (metis comp_commute_below_diversity conv_order inf.cobounded2 inf_absorb2 pseudo_complement strict_order_var top.extremum)
     have 6: "?x \<le> h"
       using 1 by (metis choose_point_decreasing)
     show "card { x . regular x \<and> x \<le> -?x \<and> x \<le> h } < h\<down>"
       apply (rule psubset_card_mono)
       using finite_regular apply simp
       using 2 5 6 by auto
   qed
 next
   show "rank_property 1 (Z\<^sup>T)"
   proof (unfold rank_property_def, intro conjI)
     show "univalent (Z\<^sup>T)" "total (Z\<^sup>T)"
       using Z_point surjective_conv_total by auto
     show "(1 - 1) * (Z\<^sup>T) \<le> (Z\<^sup>T) * S'\<^sup>+"
       by simp
     have "top \<le> 1 * -(S'\<^sup>+ * Z * top)"
       by (simp add: S'_Z comp_associative star_simulation_right_equal)
     thus "card_less_eq (roots 1) (-(S'\<^sup>+ * Z\<^sup>T\<^sup>T * top))"
       by (metis conv_involutive inf.idem mapping_one_closed regular_one_closed card_less_eq_def bijective_one_closed)
   qed
 qed
 
 end
 
 subsection \<open>Union by Rank\<close>
 
 text \<open>
 We show that path compression and union-by-rank preserve the rank property.
 \<close>
 
 context stone_kleene_relation_algebra_tarski_finite_regular
 begin
 
 lemma union_sets_1_swap:
   assumes "union_sets_precondition p0 x y"
     and "path_compression_postcondition p1 x r p0"
     and "path_compression_postcondition p2 y s p1"
   shows "union_sets_postcondition (p2[s\<longmapsto>r]) x y p0"
 proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
   let ?p = "p2[s\<longmapsto>r]"
   have 1: "disjoint_set_forest p1 \<and> point r \<and> r = root p1 x \<and> p1 \<sqinter> 1 = p0 \<sqinter> 1 \<and> fc p1 = fc p0"
-    using assms(2) path_compression_precondition_def path_compression_postcondition_def by auto
+    by (smt assms(1,2) union_sets_precondition_def path_compression_postcondition_def root_point)
   have 2: "disjoint_set_forest p2 \<and> point s \<and> s = root p2 y \<and> p2 \<sqinter> 1 = p1 \<sqinter> 1 \<and> fc p2 = fc p1"
-    using assms(3) path_compression_precondition_def path_compression_postcondition_def by auto
+    by (smt assms(1,3) union_sets_precondition_def path_compression_postcondition_def root_point)
   hence 3: "fc p2 = fc p0"
     using 1 by simp
   show 4: "univalent ?p"
     using 1 2 update_univalent by blast
   show "total ?p"
     using 1 2 bijective_regular update_total by blast
   show "acyclic (?p - 1)"
   proof (cases "r = s")
     case True
     thus ?thesis
       using 2 update_acyclic_5 by fastforce
   next
     case False
     hence "bot = s \<sqinter> r"
       using 1 2 distinct_points inf_commute by blast
     also have "... = s \<sqinter> p1\<^sup>T\<^sup>\<star> * r"
       using 1 by (smt root_transitive_successor_loop)
     also have "... = s \<sqinter> p2\<^sup>T\<^sup>\<star> * r"
       using 1 2 by (smt (z3) inf_assoc inf_commute same_root)
     finally have "r \<sqinter> p2\<^sup>\<star> * s = bot"
       using schroeder_1 conv_star_commute inf.sup_monoid.add_commute by fastforce
     thus ?thesis
       using 1 2 update_acyclic_4 by blast
   qed
-  show "vector x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "injective x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "surjective x"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "vector y"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "injective y"
-    using assms(1) by (simp add: union_sets_precondition_def)
-  show "surjective y"
-    using assms(1) by (simp add: union_sets_precondition_def)
   show "fc ?p = wcc (p0 \<squnion> x * y\<^sup>T)"
   proof (rule order.antisym)
     have "s = p2[[s]]"
       using 2 by (metis root_successor_loop)
     hence "s * s\<^sup>T \<le> p2\<^sup>T"
       using 2 eq_refl shunt_bijective by blast
     hence "s * s\<^sup>T \<le> p2"
       using 2 conv_order coreflexive_symmetric by fastforce
     hence "s \<le> p2 * s"
       using 2 shunt_bijective by blast
     hence 5: "p2[[s]] \<le> s"
       using 2 shunt_mapping by blast
     have "s \<sqinter> p2 \<le> s * (top \<sqinter> s\<^sup>T * p2)"
       using 2 by (metis dedekind_1)
     also have "... = s * s\<^sup>T * p2"
       by (simp add: mult_assoc)
     also have "... \<le> s * s\<^sup>T"
       using 5 by (metis comp_associative conv_dist_comp conv_involutive conv_order mult_right_isotone)
     also have "... \<le> 1"
       using 2 by blast
     finally have 6: "s \<sqinter> p2 \<le> 1"
       by simp
     have "p0 \<le> wcc p0"
       by (simp add: star.circ_sub_dist_1)
     also have "... = wcc p2"
       using 3 by (simp add: star_decompose_1)
     also have 7: "... \<le> wcc ?p"
     proof -
       have "wcc p2 = wcc ((-s \<sqinter> p2) \<squnion> (s \<sqinter> p2))"
         using 2 by (metis bijective_regular inf.sup_monoid.add_commute maddux_3_11_pp)
       also have "... \<le> wcc ((-s \<sqinter> p2) \<squnion> 1)"
         using 6 wcc_isotone sup_right_isotone by simp
       also have "... = wcc (-s \<sqinter> p2)"
         using wcc_with_loops by simp
       also have "... \<le> wcc ?p"
         using wcc_isotone sup_ge2 by blast
       finally show ?thesis
         by simp
     qed
     finally have 8: "p0 \<le> wcc ?p"
       by force
     have "s \<le> p2\<^sup>T\<^sup>\<star> * y"
       using 2 by (metis inf_le1)
     hence 9: "s * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "y * s\<^sup>T \<le> p2\<^sup>\<star>"
       using conv_dist_comp conv_order conv_star_commute by force
     also have "... \<le> wcc p2"
       by (simp add: star.circ_sub_dist)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 10: "y * s\<^sup>T \<le> wcc ?p"
       by simp
     have 11: "s * r\<^sup>T \<le> wcc ?p"
       using 1 2 star.circ_sub_dist_1 sup_assoc vector_covector by auto
     have "r \<le> p1\<^sup>T\<^sup>\<star> * x"
       using 1 by (metis inf_le1)
     hence 12: "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     also have "... \<le> wcc p1"
       using star_isotone sup_ge2 by blast
     also have "... = wcc p2"
       using 2 by (simp add: star_decompose_1)
     also have "... \<le> wcc ?p"
       using 7 by simp
     finally have 13: "r * x\<^sup>T \<le> wcc ?p"
       by simp
     have "x \<le> x * r\<^sup>T * r \<and> y \<le> y * s\<^sup>T * s"
       using 1 2 shunt_bijective by blast
     hence "y * x\<^sup>T \<le> y * s\<^sup>T * s * (x * r\<^sup>T * r)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = y * s\<^sup>T * s * r\<^sup>T * r * x\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc ?p * (s * r\<^sup>T) * (r * x\<^sup>T)"
       using 10 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc ?p * wcc ?p * (r * x\<^sup>T)"
       using 11 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc ?p * wcc ?p * wcc ?p"
       using 13 by (metis mult_right_isotone)
     also have "... = wcc ?p"
       by (simp add: star.circ_transitive_equal)
     finally have "x * y\<^sup>T \<le> wcc ?p"
       by (metis conv_dist_comp conv_involutive conv_order wcc_equivalence)
     hence "p0 \<squnion> x * y\<^sup>T \<le> wcc ?p"
       using 8 by simp
     hence "wcc (p0 \<squnion> x * y\<^sup>T) \<le> wcc ?p"
       using wcc_below_wcc by simp
     thus "wcc (p0 \<squnion> x * y\<^sup>T) \<le> fc ?p"
       using 4 fc_wcc by simp
     have "-s \<sqinter> p2 \<le> wcc p2"
       by (simp add: inf.coboundedI2 star.circ_sub_dist_1)
     also have "... = wcc p0"
       using 3 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 14: "-s \<sqinter> p2 \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have "s * y\<^sup>T \<le> wcc p2"
       using 9 inf.order_trans star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 1 2 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 15: "s * y\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have 16: "y * x\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using le_supE star.circ_sub_dist_1 by blast
     have "x * r\<^sup>T \<le> p1\<^sup>\<star>"
       using 12 conv_dist_comp conv_order conv_star_commute by fastforce
     also have "... \<le> wcc p1"
       using star.circ_sub_dist sup_commute by fastforce
     also have "... = wcc p0"
       using 1 by (simp add: star_decompose_1)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: wcc_isotone)
     finally have 17: "x * r\<^sup>T \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       by simp
     have "r \<le> r * x\<^sup>T * x \<and> s \<le> s * y\<^sup>T * y"
       using assms(1) shunt_bijective union_sets_precondition_def by blast
     hence "s * r\<^sup>T \<le> s * y\<^sup>T * y * (r * x\<^sup>T * x)\<^sup>T"
       using comp_isotone conv_isotone by blast
     also have "... = s * y\<^sup>T * y * x\<^sup>T * x * r\<^sup>T"
       by (simp add: comp_associative conv_dist_comp)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * (y * x\<^sup>T) * (x * r\<^sup>T)"
       using 15 by (metis mult_left_isotone mult_assoc)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T) * (x * r\<^sup>T)"
       using 16 by (metis mult_left_isotone mult_right_isotone)
     also have "... \<le> wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T) * wcc (p0 \<squnion> y * x\<^sup>T)"
       using 17 by (metis mult_right_isotone)
     also have "... = wcc (p0 \<squnion> y * x\<^sup>T)"
       by (simp add: star.circ_transitive_equal)
     finally have "?p \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using 1 2 14 vector_covector by auto
     hence "wcc ?p \<le> wcc (p0 \<squnion> y * x\<^sup>T)"
       using wcc_below_wcc by blast
     also have "... = wcc (p0 \<squnion> x * y\<^sup>T)"
       using conv_dist_comp conv_dist_sup sup_assoc sup_commute by auto
     finally show "fc ?p \<le> wcc (p0 \<squnion> x * y\<^sup>T)"
       using 4 fc_wcc by simp
   qed
 qed
 
 lemma union_sets_1_skip:
   assumes "union_sets_precondition p0 x y"
     and "path_compression_postcondition p1 x r p0"
     and "path_compression_postcondition p2 y r p1"
   shows "union_sets_postcondition p2 x y p0"
 proof (unfold union_sets_postcondition_def union_sets_precondition_def, intro conjI)
   have 1: "point r \<and> r = root p1 x \<and> fc p1 = fc p0 \<and> disjoint_set_forest p2 \<and> r = root p2 y \<and> fc p2 = fc p1"
-    using assms(2,3) path_compression_precondition_def path_compression_postcondition_def by auto
+    by (smt assms(1-3) union_sets_precondition_def path_compression_postcondition_def root_point)
   thus "univalent p2" "total p2" "acyclic (p2 - 1)"
     by auto
-  show "vector x" "injective x" "surjective x" "vector y" "injective y" "surjective y"
-    using assms(1) union_sets_precondition_def by auto
   have "r \<le> p1\<^sup>T\<^sup>\<star> * x"
     using 1 by (metis inf_le1)
   hence "r * x\<^sup>T \<le> p1\<^sup>T\<^sup>\<star>"
     using assms(1) shunt_bijective union_sets_precondition_def by blast
   hence 2: "x * r\<^sup>T \<le> p1\<^sup>\<star>"
     using conv_dist_comp conv_order conv_star_commute by force
   have "r \<le> p2\<^sup>T\<^sup>\<star> * y"
     using 1 by (metis inf_le1)
   hence 3: "r * y\<^sup>T \<le> p2\<^sup>T\<^sup>\<star>"
     using assms(1) shunt_bijective union_sets_precondition_def by blast
   have "x * y\<^sup>T \<le> x * r\<^sup>T * r * y\<^sup>T"
     using 1 mult_left_isotone shunt_bijective by blast
   also have "... \<le> p1\<^sup>\<star> * p2\<^sup>T\<^sup>\<star>"
     using 2 3 by (metis comp_associative comp_isotone)
   also have "... \<le> wcc p0"
     using 1 by (metis star.circ_mult_upper_bound star_decompose_1 star_isotone sup_ge2 star.circ_sub_dist)
   finally show "fc p2 = wcc (p0 \<squnion> x * y\<^sup>T)"
     using 1 by (smt (z3) fc_star star_decompose_1 sup_absorb1 wcc_sup_wcc star.circ_sub_dist_3 sup_commute wcc_equivalence)
 qed
 
 end
 
 syntax
   "_Cond1" :: "'bexp \<Rightarrow> 'com \<Rightarrow> 'com"  ("(1IF _/ THEN _/ FI)" [0,0] 61)
 translations "IF b THEN c FI" == "IF b THEN c ELSE SKIP FI"
 
 context skra_peano_3
 begin
 
 lemma path_compression_preserves_rank_property:
   assumes "path_compression_postcondition p x y p0"
+      and "point x"
       and "disjoint_set_forest p0"
       and "rank_property p0 rank"
     shows "rank_property p rank"
 proof (unfold rank_property_def, intro conjI)
   let ?px = "p0\<^sup>T\<^sup>\<star> * x"
   have 1: "point y"
-    using assms(1,2) path_compression_postcondition_def path_compression_precondition_def root_point by auto
+    by (smt assms(1,2) path_compression_postcondition_def root_point)
   have 2: "vector ?px"
-    using assms(1) comp_associative path_compression_postcondition_def path_compression_precondition_def by auto
+    using assms(1,2) comp_associative path_compression_postcondition_def by auto
   have "root p0 x = root p x"
-    by (smt (verit) assms(1,2) path_compression_postcondition_def path_compression_precondition_def same_root)
+    by (smt (verit) assms(1,3) path_compression_postcondition_def same_root)
   hence "root p0 x = y"
-    using assms(1) path_compression_postcondition_def path_compression_precondition_def by auto
+    using assms(1) path_compression_postcondition_def by auto
   hence "?px \<le> p0\<^sup>\<star> * y"
-    by (meson assms(1,2) path_splitting_invariant_aux_1(3) path_compression_precondition_def path_compression_postcondition_def)
+    by (meson assms(2,3) path_splitting_invariant_aux_1(3))
   hence "?px * y\<^sup>T \<le> p0\<^sup>\<star>"
     using 1 shunt_bijective by blast
   hence "?px \<sqinter> y\<^sup>T \<le> p0\<^sup>\<star>"
     using 1 2 by (simp add: vector_covector)
   also have "... = (p0 - 1)\<^sup>+ \<squnion> 1"
     using reachable_without_loops star_left_unfold_equal sup_commute by fastforce
   finally have 3: "?px \<sqinter> y\<^sup>T \<sqinter> -1 \<le> (p0 - 1)\<^sup>+"
     using half_shunting by blast
   have "p0[?px\<longmapsto>y] = p"
-    using assms(1) path_compression_postcondition_def by simp
+    using assms(1) path_compression_postcondition_def by auto
   hence "(p - 1) * rank = (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> (-?px \<sqinter> p0 \<sqinter> -1) * rank"
     using inf_sup_distrib2 mult_right_dist_sup by force
   also have "... \<le> (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> (p0 - 1) * rank"
     by (meson comp_inf.mult_semi_associative le_infE mult_left_isotone sup_right_isotone)
   also have "... \<le> (?px \<sqinter> y\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
-    using assms(3) rank_property_def sup_right_isotone by auto
+    using assms(4) rank_property_def sup_right_isotone by auto
   also have "... \<le> (p0 - 1)\<^sup>+ * rank \<squnion> rank * S'\<^sup>+"
     using 3 mult_left_isotone sup_left_isotone by blast
   also have "... \<le> rank * S'\<^sup>+"
   proof -
     have "(p0 - 1)\<^sup>\<star> * rank \<le> rank * S'\<^sup>\<star>"
-      using assms(3) rank_property_def star_simulation_left star.left_plus_circ by fastforce
+      using assms(4) rank_property_def star_simulation_left star.left_plus_circ by fastforce
     hence "(p0 - 1)\<^sup>+ * rank \<le> (p0 - 1) * rank * S'\<^sup>\<star>"
       by (simp add: comp_associative mult_right_isotone)
     also have "... \<le> rank * S'\<^sup>+"
-      by (smt (z3) assms(3) rank_property_def comp_associative comp_left_subdist_inf inf.boundedE inf.sup_right_divisibility star.circ_transitive_equal)
+      by (smt (z3) assms(4) rank_property_def comp_associative comp_left_subdist_inf inf.boundedE inf.sup_right_divisibility star.circ_transitive_equal)
     finally show ?thesis
       by simp
   qed
   finally show "(p - 1) * rank \<le> rank * S'\<^sup>+"
     .
   show "univalent rank" "total rank"
-    using rank_property_def assms(3) by auto
+    using rank_property_def assms(4) by auto
   show "card_less_eq (roots p) (-(S'\<^sup>+ * rank\<^sup>T * top))"
-    using assms(1,3) path_compression_postcondition_def rank_property_def by auto
+    using assms(1,4) path_compression_postcondition_def rank_property_def by auto
 qed
 
 theorem union_sets_by_rank:
   "VARS p r s rank
   [ union_sets_precondition p x y \<and> rank_property p rank \<and> p0 = p ]
   r := find_set p x;
   p := path_compression p x r;
   s := find_set p y;
   p := path_compression p y s;
   IF r \<noteq> s THEN
     IF rank[[r]] \<le> S'\<^sup>+ * (rank[[s]]) THEN
       p[r] := s
     ELSE
       p[s] := r;
       IF rank[[r]] = rank[[s]] THEN
         rank[r] := S'\<^sup>T * (rank[[r]])
       FI
     FI
   FI
   [ union_sets_postcondition p x y p0 \<and> rank_property p rank ]"
 proof vcg_tc_simp
   fix rank
   let ?r = "find_set p0 x"
   let ?p1 = "path_compression p0 x ?r"
   let ?s = "find_set ?p1 y"
   let ?p2 = "path_compression ?p1 y ?s"
   let ?p5 = "path_compression ?p1 y ?r"
   let ?rr = "rank[[?r]]"
   let ?rs = "rank[[?s]]"
   let ?rank = "rank[?r\<longmapsto>S'\<^sup>T * ?rs]"
   let ?p3 = "?p2[?r\<longmapsto>?s]"
   let ?p4 = "?p2[?s\<longmapsto>?r]"
   assume 1: "union_sets_precondition p0 x y \<and> rank_property p0 rank"
   hence 2: "path_compression_postcondition ?p1 x ?r p0"
     using find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def by auto
   hence 3: "path_compression_postcondition ?p2 y ?s ?p1"
     using 1 find_set_function find_set_postcondition_def find_set_precondition_def path_compression_function path_compression_precondition_def union_sets_precondition_def path_compression_postcondition_def by meson
   have "rank_property ?p1 rank"
     using 1 2 path_compression_preserves_rank_property union_sets_precondition_def by blast
   hence 4: "rank_property ?p2 rank"
-    using 1 2 3 by (meson path_compression_preserves_rank_property path_compression_postcondition_def path_compression_precondition_def)
+    using 1 2 3 by (meson path_compression_preserves_rank_property path_compression_postcondition_def union_sets_precondition_def)
   have 5: "point ?r" "point ?s"
-    using 2 3 path_compression_postcondition_def path_compression_precondition_def by auto
+    using 1 2 3 by (smt path_compression_postcondition_def union_sets_precondition_def root_point)+
   hence 6: "point ?rr" "point ?rs"
     using 1 comp_associative read_injective read_surjective rank_property_def by auto
   have "top \<le> S'\<^sup>\<star> \<squnion> S'\<^sup>+\<^sup>T"
     by (metis S'_star_connex conv_dist_comp conv_star_commute eq_refl star.circ_reflexive star_left_unfold_equal star_simulation_right_equal sup.orderE sup_monoid.add_assoc)
   hence 7: "-S'\<^sup>+\<^sup>T \<le> S'\<^sup>\<star>"
     by (metis comp_inf.case_split_left comp_inf.star.circ_plus_one comp_inf.star.circ_sup_2 half_shunting)
   show "(?r \<noteq> ?s \<longrightarrow> (?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
                       (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                               (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))) \<and>
         (?r = ?s \<longrightarrow> union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank)"
   proof
     show "?r \<noteq> ?s \<longrightarrow> (?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
                       (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                               (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))"
     proof
       assume 8: "?r \<noteq> ?s"
       show "(?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank) \<and>
             (\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                     (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank)))"
       proof
         show "?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank"
         proof
           assume 9: "?rr \<le> S'\<^sup>+ * ?rs"
           show "union_sets_postcondition ?p3 x y p0 \<and> rank_property ?p3 rank"
           proof
             show "union_sets_postcondition ?p3 x y p0"
               using 1 2 3 by (simp add: union_sets_1)
             show "rank_property ?p3 rank"
             proof (unfold rank_property_def, intro conjI)
               show "univalent rank" "total rank"
                 using 1 rank_property_def by auto
               have "?s \<le> -?r"
                 using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
               hence "?r \<sqinter> ?s\<^sup>T \<sqinter> 1 = bot"
                 by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
               hence "?p3 \<sqinter> 1 \<le> ?p2"
                 by (smt half_shunting inf.cobounded2 pseudo_complement regular_one_closed semiring.add_mono sup_commute)
               hence "roots ?p3 \<le> roots ?p2"
                 by (simp add: mult_left_isotone)
               thus "card_less_eq (roots ?p3) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                 using 4 by (meson rank_property_def card_less_eq_def order_trans)
               have "(?p3 - 1) * rank = (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> (-?r \<sqinter> ?p2 \<sqinter> -1) * rank"
                 using comp_inf.semiring.distrib_right mult_right_dist_sup by auto
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> (?p2 - 1) * rank"
                 using comp_inf.mult_semi_associative mult_left_isotone sup_right_isotone by auto
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
                 using 4 sup_right_isotone rank_property_def by blast
               also have "... \<le> (?r \<sqinter> ?s\<^sup>T) * rank \<squnion> rank * S'\<^sup>+"
                 using inf_le1 mult_left_isotone sup_left_isotone by blast
               also have "... = ?r * ?s\<^sup>T * rank \<squnion> rank * S'\<^sup>+"
                 using 5 by (simp add: vector_covector)
               also have "... = rank * S'\<^sup>+"
               proof -
                 have "rank\<^sup>T * ?r \<le> S'\<^sup>+ * rank\<^sup>T * ?s"
                   using 9 comp_associative by auto
                 hence "?r \<le> rank * S'\<^sup>+ * rank\<^sup>T * ?s"
                   using 4 shunt_mapping comp_associative rank_property_def by auto
                 hence "?r * ?s\<^sup>T \<le> rank * S'\<^sup>+ * rank\<^sup>T"
                   using 5 shunt_bijective by blast
                 hence "?r * ?s\<^sup>T * rank \<le> rank * S'\<^sup>+"
                   using 4 shunt_bijective rank_property_def mapping_conv_bijective by auto
                 thus ?thesis
                   using sup_absorb2 by blast
               qed
               finally show "(?p3 - 1) * rank \<le> rank * S'\<^sup>+"
                 .
             qed
           qed
         qed
         show "\<not> ?rr \<le> S'\<^sup>+ * ?rs \<longrightarrow> ((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                                      (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank))"
         proof
           assume "\<not> ?rr \<le> S'\<^sup>+ * ?rs"
           hence "?rr \<le> -(S'\<^sup>+ * ?rs)"
             using 6 by (meson point_in_vector_or_complement S'_regular bijective_regular regular_closed_star regular_mult_closed vector_mult_closed)
           also have "... = -S'\<^sup>+ * ?rs"
             using 6 comp_bijective_complement by simp
           finally have "?rs \<le> -S'\<^sup>+\<^sup>T * ?rr"
             using 6 by (metis bijective_reverse conv_complement)
           also have "... \<le> S'\<^sup>\<star> * ?rr"
             using 7 by (simp add: mult_left_isotone)
           also have "... = S'\<^sup>+ * ?rr \<squnion> ?rr"
             using star.circ_loop_fixpoint mult_assoc by auto
           finally have 10: "?rs - ?rr \<le> S'\<^sup>+ * ?rr"
             using half_shunting by blast
           show "((?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank) \<and>
                  (?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank))"
           proof
             show "?rr = ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank"
             proof
               assume 11: "?rr = ?rs"
               show "union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 ?rank"
               proof
                 show "union_sets_postcondition ?p4 x y p0"
                   using 1 2 3 by (simp add: union_sets_1_swap)
                 show "rank_property ?p4 ?rank"
                 proof (unfold rank_property_def, intro conjI)
                   show "univalent ?rank"
                     using 4 5 6 by (meson S'_univalent read_injective update_univalent rank_property_def)
                   have "card_less_eq (roots ?p2) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                     using 4 rank_property_def by blast
                   from this obtain i where 12: "injective i \<and> univalent i \<and> regular i \<and> roots ?p2 \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using card_less_eq_def by blast
                   let ?i = "(i[?s\<longmapsto>i[[i * ?rr]]])[i * ?rr\<longmapsto>i[[?s]]]"
                   have 13: "?i = (i * ?rr \<sqinter> ?s\<^sup>T * i) \<squnion> (-(i * ?rr) \<sqinter> ?s \<sqinter> ?rr\<^sup>T * i\<^sup>T * i) \<squnion> (-(i * ?rr) \<sqinter> -?s \<sqinter> i)"
                     by (smt (z3) conv_dist_comp conv_involutive inf.sup_monoid.add_assoc inf_sup_distrib1 sup_assoc)
                   have 14: "injective ?i"
                     apply (rule update_injective_swap)
                     subgoal using 12 by simp
                     subgoal using 5 by simp
                     subgoal using 6 12 injective_mult_closed by simp
                     subgoal using 5 comp_associative by simp
                     done
                   have 15: "univalent ?i"
                     apply (rule update_univalent_swap)
                     subgoal using 12 by simp
                     subgoal using 5 by simp
                     subgoal using 5 by simp
                     subgoal using 6 12 injective_mult_closed by simp
                     subgoal using 5 comp_associative by simp
                     done
                   have 16: "regular ?i"
                     using 5 6 12 by (smt (z3) bijective_regular p_dist_inf p_dist_sup pp_dist_comp regular_closed_inf regular_conv_closed)
                   have 17: "regular (i * ?rr)"
                     using 6 12 bijective_regular regular_mult_closed by blast
                   have 18: "find_set_precondition ?p1 y"
-                    using 2 3 find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def by blast
+                    using 1 2 find_set_precondition_def path_compression_postcondition_def union_sets_precondition_def by blast
                   hence "?s = root ?p1 y"
                     by (meson find_set_function find_set_postcondition_def)
                   also have "... = root ?p2 y"
-                    using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
+                    using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def same_root)
                   also have "... \<le> roots ?p2"
                     by simp
                   also have "... \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 12 by simp
                   finally have 19: "?s \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     .
                   have "roots ?p4 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                   proof -
                     have "?r \<le> -?s"
                       using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
                     hence "?s \<sqinter> ?r\<^sup>T \<sqinter> 1 = bot"
                       by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
                     hence "?p4 \<sqinter> 1 \<le> -?s \<sqinter> ?p2"
                       by (smt (z3) bot_least comp_inf.semiring.distrib_left inf.cobounded2 inf.sup_monoid.add_commute le_supI)
                     hence "roots ?p4 \<le> roots (-?s \<sqinter> ?p2)"
                       by (simp add: mult_left_isotone)
                     also have "... = -?s \<sqinter> roots ?p2"
                       using 5 inf_assoc vector_complement_closed vector_inf_comp by auto
                     also have "... = (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<squnion> (-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2)"
                       using 17 by (smt (z3) comp_inf.star_plus inf_sup_distrib2 inf_top.right_neutral regular_complement_top)
                     also have "... \<le> ?i * (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                     proof (rule sup_least)
                       have "?rank\<^sup>T * top = (?r \<sqinter> (S'\<^sup>T * ?rs)\<^sup>T)\<^sup>T * top \<squnion> (-?r \<sqinter> rank)\<^sup>T * top"
                         using conv_dist_sup mult_right_dist_sup by auto
                       also have "... = (?r\<^sup>T \<sqinter> S'\<^sup>T * ?rs) * top \<squnion> (-?r\<^sup>T \<sqinter> rank\<^sup>T) * top"
                         using conv_complement conv_dist_inf conv_involutive by auto
                       also have "... = S'\<^sup>T * ?rs * (?r \<sqinter> top) \<squnion> (-?r\<^sup>T \<sqinter> rank\<^sup>T) * top"
                         using 5 by (smt (z3) covector_inf_comp_3 inf_commute)
                       also have "... = S'\<^sup>T * ?rs * (?r \<sqinter> top) \<squnion> rank\<^sup>T * (-?r \<sqinter> top)"
                         using 5 by (smt (z3) conv_complement vector_complement_closed covector_inf_comp_3 inf_commute)
                       also have "... = S'\<^sup>T * ?rs * ?r \<squnion> rank\<^sup>T * -?r"
                         by simp
                       also have "... \<le> S'\<^sup>T * ?rs * ?r \<squnion> rank\<^sup>T * top"
                         using mult_right_isotone sup_right_isotone by force
                       also have "... \<le> S'\<^sup>T * ?rs \<squnion> rank\<^sup>T * top"
                         using 5 6 by (metis inf.eq_refl mult_assoc)
                       finally have "S'\<^sup>+ * ?rank\<^sup>T * top \<le> S'\<^sup>+ * S'\<^sup>T * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt comp_associative mult_left_dist_sup mult_right_isotone)
                       also have "... = S'\<^sup>\<star> * (S' * S'\<^sup>T) * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt star_plus mult_assoc)
                       also have "... \<le> S'\<^sup>\<star> * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (metis S'_injective comp_right_one mult_left_isotone mult_right_isotone sup_left_isotone)
                       also have "... = ?rs \<squnion> S'\<^sup>+ * ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         using comp_associative star.circ_loop_fixpoint sup_commute by fastforce
                       also have "... = ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         by (smt (verit, del_insts) comp_associative mult_left_dist_sup sup.orderE sup_assoc sup_commute top.extremum)
                       finally have 20: "S'\<^sup>+ * ?rank\<^sup>T * top \<le> ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                         .
                       have "?s * ?s\<^sup>T = (?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)) * ?s\<^sup>T"
                         using 19 inf.orderE by fastforce
                       also have "... = (?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)) * top \<sqinter> ?s\<^sup>T"
                         using 5 by (smt (z3) covector_comp_inf vector_conv_covector vector_covector vector_top_closed)
                       also have "... = ?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) * top \<sqinter> ?s\<^sup>T"
                         using 5 vector_inf_comp by auto
                       also have "... \<le> 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) * top"
                         using 5 by (smt (verit, ccfv_SIG) inf.cobounded1 inf.cobounded2 inf_greatest order_trans vector_covector)
                       also have "... = 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using comp_associative vector_complement_closed vector_top_closed by auto
                       also have "... \<le> 1 \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T)"
                         by (meson comp_inf.mult_right_isotone mult_right_isotone p_antitone top_right_mult_increasing)
                       also have "... \<le> 1 \<sqinter> i * S'\<^sup>\<star>\<^sup>T * rank\<^sup>T"
                       proof -
                         have "S'\<^sup>\<star>\<^sup>T * rank\<^sup>T \<squnion> S'\<^sup>+ * rank\<^sup>T = (S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>+) * rank\<^sup>T"
                           by (simp add: conv_star_commute mult_right_dist_sup)
                         also have "... = (S'\<^sup>T\<^sup>\<star> \<squnion> S'\<^sup>\<star>) * rank\<^sup>T"
                           by (smt (z3) comp_associative semiring.distrib_right star.circ_loop_fixpoint sup.left_commute sup_commute sup_idem)
                         also have "... = top * rank\<^sup>T"
                           by (simp add: S'_star_connex sup_commute)
                         also have "... = top"
                           using 4 rank_property_def total_conv_surjective by blast
                         finally have "-(S'\<^sup>+ * rank\<^sup>T) \<le> S'\<^sup>\<star>\<^sup>T * rank\<^sup>T"
                           by (metis half_shunting inf.idem top_greatest)
                         thus ?thesis
                           using comp_associative inf.sup_right_isotone mult_right_isotone by auto
                       qed
                       also have "... = 1 \<sqinter> rank * S'\<^sup>\<star> * i\<^sup>T"
                         by (metis comp_associative conv_dist_comp conv_involutive one_inf_conv)
                       also have "... \<le> rank * S'\<^sup>\<star> * i\<^sup>T"
                         by simp
                       finally have "?s \<le> rank * S'\<^sup>\<star> * i\<^sup>T * ?s"
                         using 5 shunt_bijective by auto
                       hence "?rs \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                         using 4 shunt_mapping comp_associative rank_property_def by auto
                       hence "?s * (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<le> ?s * (i * S'\<^sup>\<star> * i\<^sup>T * ?s \<sqinter> -?s \<sqinter> roots ?p2)"
                         using 11 comp_associative comp_inf.mult_left_isotone comp_isotone inf.eq_refl by auto
                       also have "... = ?s * ((i * S'\<^sup>+ * i\<^sup>T * ?s \<squnion> i * i\<^sup>T * ?s) \<sqinter> -?s \<sqinter> roots ?p2)"
                         by (metis comp_associative mult_left_dist_sup star.circ_loop_fixpoint)
                       also have "... \<le> ?s * ((i * S'\<^sup>+ * i\<^sup>T * ?s \<squnion> 1 * ?s) \<sqinter> -?s \<sqinter> roots ?p2)"
                         using 12 by (metis mult_left_isotone sup_right_isotone comp_inf.mult_left_isotone mult_right_isotone)
                       also have "... = ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> -?s \<sqinter> roots ?p2)"
                         using comp_inf.comp_right_dist_sup by simp
                       also have "... \<le> ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> roots ?p2)"
                         using comp_inf.mult_left_isotone inf.cobounded1 mult_right_isotone by blast
                       also have "... \<le> ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top))"
                         using 12 comp_inf.mult_right_isotone mult_right_isotone by auto
                       also have "... = ?s * (i * S'\<^sup>+ * i\<^sup>T * ?s \<sqinter> i) * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 by (simp add: comp_associative vector_inf_comp)
                       also have "... = (?s \<sqinter> (i * S'\<^sup>+ * i\<^sup>T * ?s)\<^sup>T) * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 covector_inf_comp_3 mult_assoc by auto
                       also have "... = (?s \<sqinter> ?s\<^sup>T * i * S'\<^sup>+\<^sup>T * i\<^sup>T) * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using conv_dist_comp conv_involutive mult_assoc by auto
                       also have "... = (?s \<sqinter> ?s\<^sup>T) * i * S'\<^sup>+\<^sup>T * i\<^sup>T * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 vector_inf_comp by auto
                       also have "... \<le> i * S'\<^sup>+\<^sup>T * i\<^sup>T * i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 5 by (metis point_antisymmetric mult_left_isotone mult_left_one)
                       also have "... \<le> i * S'\<^sup>+\<^sup>T * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 12 by (smt mult_left_isotone mult_right_isotone mult_assoc comp_right_one)
                       also have "... \<le> i * -(S'\<^sup>\<star> * rank\<^sup>T * top)"
                       proof -
                         have "S'\<^sup>+ * S'\<^sup>\<star> * rank\<^sup>T * top \<le> S'\<^sup>+ * rank\<^sup>T * top"
                           by (simp add: comp_associative star.circ_transitive_equal)
                         hence "S'\<^sup>+\<^sup>T * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> -(S'\<^sup>\<star> * rank\<^sup>T * top)"
                           by (smt (verit, ccfv_SIG) comp_associative conv_complement_sub_leq mult_right_isotone order.trans p_antitone)
                         thus ?thesis
                           by (simp add: comp_associative mult_right_isotone)
                       qed
                       also have "... \<le> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                       proof -
                         have "S'\<^sup>+ * ?rank\<^sup>T * top \<le> ?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                           using 20 by simp
                         also have "... \<le> rank\<^sup>T * top \<squnion> S'\<^sup>+ * rank\<^sup>T * top"
                           using mult_right_isotone sup_left_isotone top.extremum by blast
                         also have "... = S'\<^sup>\<star> * rank\<^sup>T * top"
                           using comp_associative star.circ_loop_fixpoint sup_commute by auto
                         finally show ?thesis
                           using mult_right_isotone p_antitone by blast
                       qed
                       finally have "?s * (i * ?rr \<sqinter> -?s \<sqinter> roots ?p2) \<le> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                       hence "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?s\<^sup>T * i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 5 shunt_mapping bijective_conv_mapping mult_assoc by auto
                       hence "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> i * ?rr \<sqinter> ?s\<^sup>T * i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         by (simp add: inf.sup_monoid.add_assoc)
                       also have "... = (i * ?rr \<sqinter> ?s\<^sup>T * i) * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 6 vector_inf_comp vector_mult_closed by simp
                       also have "... \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 13 comp_left_increasing_sup sup_assoc by auto
                       finally show "i * ?rr \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                       have "-(i * ?rr) \<sqinter> roots ?p2 \<le> -(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                         using 12 inf.sup_right_isotone by auto
                       also have "... \<le> -(i * ?rr) \<sqinter> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                       proof -
                         have 21: "regular (?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                           using 4 6 rank_property_def mapping_regular S'_regular pp_dist_star regular_conv_closed regular_mult_closed bijective_regular regular_closed_sup by auto
                         have "?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top \<le> S'\<^sup>+ * rank\<^sup>T * top \<squnion> ?rr"
                           using 11 by simp
                         hence "(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) - S'\<^sup>+ * rank\<^sup>T * top \<le> ?rr"
                           using half_shunting sup_commute by auto
                         hence "-(S'\<^sup>+ * rank\<^sup>T * top) \<le> -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) \<squnion> ?rr"
                           using 21 by (metis inf.sup_monoid.add_commute shunting_var_p sup_commute)
                         hence "i * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top) \<squnion> i * ?rr"
                           by (metis mult_left_dist_sup mult_right_isotone)
                         hence "-(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * rank\<^sup>T * top) \<le> i * -(?rs \<squnion> S'\<^sup>+ * rank\<^sup>T * top)"
                           using half_shunting inf.sup_monoid.add_commute by fastforce
                         thus ?thesis
                           using inf.le_sup_iff by blast
                       qed
                       also have "... \<le> -(i * ?rr) \<sqinter> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         using 20 by (meson comp_inf.mult_right_isotone mult_right_isotone p_antitone)
                       finally have "-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2 \<le> -(i * ?rr) \<sqinter> -?s \<sqinter> i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         by (smt (z3) inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_assoc inf.sup_monoid.add_commute)
                       also have "... \<le> ?i * (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                         using 5 6 13 by (smt (z3) sup_commute vector_complement_closed vector_inf_comp vector_mult_closed comp_left_increasing_sup)
                       finally show "-(i * ?rr) \<sqinter> -?s \<sqinter> roots ?p2 \<le> ?i * -(S'\<^sup>+ * ?rank\<^sup>T * top)"
                         .
                     qed
                     finally show ?thesis
                       .
                   qed
                   thus "card_less_eq (roots ?p4) (-(S'\<^sup>+ * ?rank\<^sup>T * top))"
                     using 14 15 16 card_less_eq_def by auto
                   have "?s \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 19 by simp
                   also have "... \<le> i * -(S'\<^sup>+ * ?rr)"
                     using mult_right_isotone p_antitone top.extremum mult_assoc by auto
                   also have "... = i * -S'\<^sup>+ * ?rr"
                     using 6 comp_bijective_complement mult_assoc by fastforce
                   finally have "?rr \<le> -S'\<^sup>T\<^sup>+ * i\<^sup>T * ?s"
                     using 5 6 by (metis conv_complement conv_dist_comp conv_plus_commute bijective_reverse)
                   also have "... \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     using 7 conv_plus_commute mult_left_isotone by auto
                   finally have 22: "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     .
                   have "?r = root ?p1 x"
-                    using 2 path_compression_postcondition_def path_compression_precondition_def by blast
+                    using 2 path_compression_postcondition_def by blast
                   also have "... = root ?p2 x"
-                    using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
+                    using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def same_root)
                   also have "... \<le> roots ?p2"
                     by simp
                   also have "... \<le> i * -(S'\<^sup>+ * rank\<^sup>T * top)"
                     using 12 by simp
                   also have "... \<le> i * -(S'\<^sup>+ * ?rr)"
                     using mult_right_isotone p_antitone top.extremum mult_assoc by auto
                   also have "... = i * -S'\<^sup>+ * ?rr"
                     using 6 comp_bijective_complement mult_assoc by fastforce
                   finally have "?rr \<le> -S'\<^sup>T\<^sup>+ * i\<^sup>T * ?r"
                     using 5 6 by (metis conv_complement conv_dist_comp conv_plus_commute bijective_reverse)
                   also have "... \<le> S'\<^sup>\<star> * i\<^sup>T * ?r"
                     using 7 conv_plus_commute mult_left_isotone by auto
                   finally have "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?r"
                     .
                   hence "?rr \<le> S'\<^sup>\<star> * i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     using 22 inf.boundedI by blast
                   also have "... = (S'\<^sup>+ * i\<^sup>T * ?r \<squnion> i\<^sup>T * ?r) \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s"
                     by (simp add: star.circ_loop_fixpoint mult_assoc)
                   also have "... \<le> S'\<^sup>+ * i\<^sup>T * ?r \<squnion> (i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s)"
                     by (metis comp_inf.mult_right_dist_sup eq_refl inf.cobounded1 semiring.add_mono)
                   also have "... \<le> S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> S'\<^sup>\<star> * i\<^sup>T * ?s)"
                     using comp_associative mult_right_isotone sup_left_isotone top.extremum by auto
                   also have "... = S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> (S'\<^sup>+ * i\<^sup>T * ?s \<squnion> i\<^sup>T * ?s))"
                     by (simp add: star.circ_loop_fixpoint mult_assoc)
                   also have "... \<le> S' * top \<squnion> S'\<^sup>+ * i\<^sup>T * ?s \<squnion> (i\<^sup>T * ?r \<sqinter> i\<^sup>T * ?s)"
                     by (smt (z3) comp_inf.semiring.distrib_left inf.sup_right_divisibility star.circ_loop_fixpoint sup_assoc sup_commute sup_inf_distrib1)
                   also have "... \<le> S' * top \<squnion> (i\<^sup>T * ?r \<sqinter> i\<^sup>T * ?s)"
                     by (metis comp_associative mult_right_isotone order.refl sup.orderE top.extremum)
                   also have "... = S' * top \<squnion> i\<^sup>T * (?r \<sqinter> ?s)"
                     using 12 conv_involutive univalent_comp_left_dist_inf by auto
                   also have "... = S' * top"
                     using 5 8 distinct_points by auto
                   finally have "top \<le> ?rr\<^sup>T * S' * top"
                     using 6 by (smt conv_involutive shunt_mapping bijective_conv_mapping mult_assoc)
                   hence "surjective (S'\<^sup>T * ?rs)"
                     using 6 11 by (smt conv_dist_comp conv_involutive point_conv_comp top_le)
                   thus "total ?rank"
                     using 4 5 bijective_regular update_total rank_property_def by blast
                   show "(?p4 - 1) * ?rank \<le> ?rank * S'\<^sup>+"
                   proof -
                     have 23: "univalent ?p2"
-                      using 3 path_compression_postcondition_def path_compression_precondition_def by blast
+                      using 3 path_compression_postcondition_def by blast
                     have 24: "?r \<sqinter> (?p4 - 1) * ?rank \<le> ?s\<^sup>T * rank * S' * S'\<^sup>+"
                     proof -
                       have "?r \<sqinter> (?p4 - 1) * ?rank = (?r \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 vector_complement_closed vector_inf_comp inf_assoc by auto
                       also have "... = (?r \<sqinter> -?s \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                           using 5 8 by (smt (z3) order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2 inf_absorb1)
                       also have "... = (?r \<sqinter> -?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         by (simp add: inf.left_commute inf.sup_monoid.add_commute inf_sup_distrib1 inf_assoc)
                       also have "... \<le> (?r \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         using inf.sup_left_isotone inf_le1 mult_left_isotone by blast
                       also have "... = bot"
                       proof -
                         have "?r = root ?p1 x"
-                          using 2 path_compression_postcondition_def path_compression_precondition_def by blast
+                          using 2 path_compression_postcondition_def by blast
                         also have "... = root ?p2 x"
-                          using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def path_compression_precondition_def same_root)
+                          using 3 18 by (smt (z3) find_set_precondition_def path_compression_postcondition_def same_root)
                         also have "... \<le> roots ?p2"
                           by simp
                         finally have "?r \<sqinter> ?p2 \<le> roots ?p2 \<sqinter> ?p2"
                           using inf.sup_left_isotone by blast
                         also have "... \<le> (?p2 \<sqinter> 1) * (?p2 \<sqinter> 1)\<^sup>T * ?p2"
                           by (smt (z3) comp_associative comp_inf.star_plus dedekind_1 inf_top_right order_lesseq_imp)
                         also have "... = (?p2 \<sqinter> 1) * (?p2 \<sqinter> 1) * ?p2"
                           using coreflexive_symmetric by force
                         also have "... \<le> (?p2 \<sqinter> 1) * ?p2"
                           by (metis coreflexive_comp_top_inf inf.cobounded2 mult_left_isotone)
                         also have "... \<le> ?p2 \<sqinter> 1"
                           by (smt 23 comp_inf.mult_semi_associative conv_dist_comp conv_dist_inf conv_order equivalence_one_closed inf.absorb1 inf.sup_monoid.add_assoc injective_codomain)
                         also have "... \<le> 1"
                           by simp
                         finally have "?r \<sqinter> ?p2 \<le> 1"
                           .
                         thus ?thesis
                           by (metis pseudo_complement regular_one_closed semiring.mult_not_zero)
                       qed
                       finally show ?thesis
                         using bot_least le_bot by blast
                     qed
                     have 25: "-?r \<sqinter> (?p4 - 1) * ?rank \<le> rank * S'\<^sup>+"
                     proof -
                       have "-?r \<sqinter> (?p4 - 1) * ?rank = (-?r \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 vector_complement_closed vector_inf_comp inf_assoc by auto
                       also have "... = (-?r \<sqinter> (?s \<squnion> -?s) \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         using 5 bijective_regular inf_top_right regular_complement_top by auto
                       also have "... = (-?r \<sqinter> ?s \<sqinter> ?p4 \<sqinter> -1) * ?rank \<squnion> (-?r \<sqinter> -?s \<sqinter> ?p4 \<sqinter> -1) * ?rank"
                         by (smt (z3) inf_sup_distrib1 inf_sup_distrib2 mult_right_dist_sup)
                       also have "... = (-?r \<sqinter> ?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * ?rank \<squnion> (-?r \<sqinter> -?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         using 5 by (smt (z3) bijective_regular comp_inf.comp_left_dist_sup inf_assoc inf_commute inf_top_right mult_right_dist_sup regular_complement_top)
                       also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * ?rank \<squnion> (-?s \<sqinter> ?p2 \<sqinter> -1) * ?rank"
                         by (smt (z3) comp_inf.semiring.distrib_left inf.cobounded2 inf.sup_monoid.add_assoc mult_left_isotone mult_right_dist_sup)
                       also have "... \<le> (?s \<sqinter> ?r\<^sup>T) * ?rank \<squnion> (?p2 - 1) * ?rank"
                         by (smt (z3) inf.cobounded1 inf.cobounded2 inf.sup_monoid.add_assoc mult_left_isotone semiring.add_mono)
                       also have "... = ?s * (?r \<sqinter> ?rank) \<squnion> (?p2 - 1) * ?rank"
                         using 5 by (simp add: covector_inf_comp_3)
                       also have "... = ?s * (?r \<sqinter> (S'\<^sup>T * ?rs)\<^sup>T) \<squnion> (?p2 - 1) * ?rank"
                         using inf_commute update_inf_same mult_assoc by force
                       also have "... = ?s * (?r \<sqinter> ?s\<^sup>T * rank * S') \<squnion> (?p2 - 1) * ?rank"
                         using comp_associative conv_dist_comp conv_involutive by auto
                       also have "... \<le> ?s * ?s\<^sup>T * rank * S' \<squnion> (?p2 - 1) * ?rank"
                         using comp_associative inf.cobounded2 mult_right_isotone semiring.add_right_mono by auto
                       also have "... \<le> 1 * rank * S' \<squnion> (?p2 - 1) * ?rank"
                         using 5 by (meson mult_left_isotone order.refl semiring.add_mono)
                       also have "... = rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> (S'\<^sup>T * ?rr)\<^sup>T) \<squnion> (?p2 - 1) * (-?r \<sqinter> rank)"
                         using 11 comp_associative mult_1_left mult_left_dist_sup sup_assoc by auto
                       also have "... \<le> rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> ?r\<^sup>T * rank * S') \<squnion> (?p2 - 1) * rank"
                         using comp_associative conv_dist_comp conv_involutive inf.cobounded1 inf.sup_monoid.add_commute mult_right_isotone semiring.add_left_mono by auto
                       also have "... = rank * S' \<squnion> (?p2 - 1) * (?r \<sqinter> ?r\<^sup>T) * rank * S' \<squnion> (?p2 - 1) * rank"
                         using 5 comp_associative vector_inf_comp by auto
                       also have "... \<le> rank * S' \<squnion> (?p2 - 1) * rank * S' \<squnion> (?p2 - 1) * rank"
                         using 5 by (metis point_antisymmetric mult_left_isotone mult_right_isotone sup_left_isotone sup_right_isotone comp_right_one)
                       also have "... \<le> rank * S' \<squnion> rank * S'\<^sup>+ * S' \<squnion> (?p2 - 1) * rank"
                         using 4 by (metis rank_property_def mult_left_isotone sup_left_isotone sup_right_isotone)
                       also have "... \<le> rank * S' \<squnion> rank * S'\<^sup>+ * S' \<squnion> rank * S'\<^sup>+"
                         using 4 by (metis rank_property_def sup_right_isotone)
                       also have "... \<le> rank * S'\<^sup>+"
                         using comp_associative eq_refl le_sup_iff mult_right_isotone star.circ_mult_increasing star.circ_plus_same star.left_plus_below_circ by auto
                       finally show ?thesis
                         .
                     qed
                     have "(?p4 - 1) * ?rank = (?r \<sqinter> (?p4 - 1) * ?rank) \<squnion> (-?r \<sqinter> (?p4 - 1) * ?rank)"
                       using 5 by (smt (verit, ccfv_threshold) bijective_regular inf_commute inf_sup_distrib2 inf_top_right regular_complement_top)
                     also have "... \<le> (?r \<sqinter> ?s\<^sup>T * rank * S' * S'\<^sup>+) \<squnion> (-?r \<sqinter> rank * S'\<^sup>+)"
                       using 24 25 by (meson inf.boundedI inf.cobounded1 semiring.add_mono)
                     also have "... = (?r \<sqinter> ?s\<^sup>T * rank * S') * S'\<^sup>+ \<squnion> (-?r \<sqinter> rank) * S'\<^sup>+"
                       using 5 vector_complement_closed vector_inf_comp by auto
                     also have "... = ?rank * S'\<^sup>+"
                       using conv_dist_comp mult_right_dist_sup by auto
                     finally show ?thesis
                       .
                   qed
                 qed
               qed
             qed
             show "?rr \<noteq> ?rs \<longrightarrow> union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank"
             proof
               assume "?rr \<noteq> ?rs"
               hence "?rs \<sqinter> ?rr = bot"
                 using 6 by (meson bijective_regular dual_order.eq_iff point_in_vector_or_complement point_in_vector_or_complement_2 pseudo_complement)
               hence 26: "?rs \<le> S'\<^sup>+ * ?rr"
                 using 10 le_iff_inf pseudo_complement by auto
               show "union_sets_postcondition ?p4 x y p0 \<and> rank_property ?p4 rank"
               proof
                 show "union_sets_postcondition ?p4 x y p0"
                   using 1 2 3 by (simp add: union_sets_1_swap)
                 show "rank_property ?p4 rank"
                 proof (unfold rank_property_def, intro conjI)
                   show "univalent rank" "total rank"
                     using 1 rank_property_def by auto
                   have "?r \<le> -?s"
                     using 5 8 by (meson order.antisym bijective_regular point_in_vector_or_complement point_in_vector_or_complement_2)
                   hence "?s \<sqinter> ?r\<^sup>T \<sqinter> 1 = bot"
                     by (metis (full_types) bot_least inf.left_commute inf.sup_monoid.add_commute one_inf_conv pseudo_complement)
                   hence "?p4 \<sqinter> 1 \<le> ?p2"
                     by (smt half_shunting inf.cobounded2 pseudo_complement regular_one_closed semiring.add_mono sup_commute)
                   hence "roots ?p4 \<le> roots ?p2"
                     by (simp add: mult_left_isotone)
                   thus "card_less_eq (roots ?p4) (-(S'\<^sup>+ * rank\<^sup>T * top))"
                     using 4 by (meson rank_property_def card_less_eq_def order_trans)
                   have "(?p4 - 1) * rank = (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> (-?s \<sqinter> ?p2 \<sqinter> -1) * rank"
                     using comp_inf.semiring.distrib_right mult_right_dist_sup by auto
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> (?p2 - 1) * rank"
                     using comp_inf.mult_semi_associative mult_left_isotone sup_right_isotone by auto
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T \<sqinter> -1) * rank \<squnion> rank * S'\<^sup>+"
                     using 4 sup_right_isotone rank_property_def by blast
                   also have "... \<le> (?s \<sqinter> ?r\<^sup>T) * rank \<squnion> rank * S'\<^sup>+"
                     using inf_le1 mult_left_isotone sup_left_isotone by blast
                   also have "... = ?s * ?r\<^sup>T * rank \<squnion> rank * S'\<^sup>+"
                     using 5 by (simp add: vector_covector)
                   also have "... = rank * S'\<^sup>+"
                   proof -
                     have "rank\<^sup>T * ?s \<le> S'\<^sup>+ * rank\<^sup>T * ?r"
                       using 26 comp_associative by auto
                     hence "?s \<le> rank * S'\<^sup>+ * rank\<^sup>T * ?r"
                       using 4 shunt_mapping comp_associative rank_property_def by auto
                     hence "?s * ?r\<^sup>T \<le> rank * S'\<^sup>+ * rank\<^sup>T"
                       using 5 shunt_bijective by blast
                     hence "?s * ?r\<^sup>T * rank \<le> rank * S'\<^sup>+"
                       using 4 shunt_bijective rank_property_def mapping_conv_bijective by auto
                     thus ?thesis
                       using sup_absorb2 by blast
                   qed
                   finally show "(?p4 - 1) * rank \<le> rank * S'\<^sup>+"
                     .
                 qed
               qed
             qed
           qed
         qed
       qed
     qed
     show "?r = ?s \<longrightarrow> union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank"
     proof
       assume 27: "?r = ?s"
       show "union_sets_postcondition ?p5 x y p0 \<and> rank_property ?p5 rank"
       proof
         show "union_sets_postcondition ?p5 x y p0"
           using 1 2 3 27 by (simp add: union_sets_1_skip)
         show "rank_property ?p5 rank"
           using 4 27 by simp
       qed
     qed
   qed
 qed
 
 end
 
 end
 
diff --git a/thys/Simpl/hoare_syntax.ML b/thys/Simpl/hoare_syntax.ML
--- a/thys/Simpl/hoare_syntax.ML
+++ b/thys/Simpl/hoare_syntax.ML
@@ -1,1625 +1,1625 @@
 (*  Title:      hoare_syntax.ML
     Author:     Norbert Schirmer, TU Muenchen
 
 Copyright (C) 2004-2007 Norbert Schirmer
 
 This library is free software; you can redistribute it and/or modify
 it under the terms of the GNU Lesser General Public License as
 published by the Free Software Foundation; either version 2.1 of the
 License, or (at your option) any later version.
 
 This library is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 Lesser General Public License for more details.
 
 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
 USA
 *)
 
 (* FIXME: Adapt guard generation to new syntax of op + etc. *)
 
 signature HOARE_SYNTAX =
 sig
   val antiquoteCur: string
   val antiquoteOld: string
   val antiquoteOld_tr: Proof.context -> term list -> term
   val antiquote_applied_only_to: (term -> bool) -> term -> bool
   val antiquote_varname_tr: string -> term list -> term
   val app_quote_tr': Proof.context -> term -> term list -> term
   val assert_tr': Proof.context -> term list -> term
   val assign_tr': Proof.context -> term list -> term
   val assign_tr: Proof.context -> term list -> term
   val basic_assigns_tr: Proof.context -> term list -> term
   val basic_tr': Proof.context -> term list -> term
   val basic_tr: Proof.context -> term list -> term
   val bexp_tr': string -> Proof.context -> term list -> term
   val bind_tr': Proof.context -> term list -> term
   val call_ass_tr: bool -> bool -> Proof.context -> term list -> term
   val call_tr': Proof.context -> term list -> term
   val call_tr: bool -> bool -> Proof.context -> term list -> term
   val dyn_call_tr': Proof.context -> term list -> term
   val fcall_tr': Proof.context -> term list -> term
   val fcall_tr: Proof.context -> term list -> term
   val guarded_Assign_tr: Proof.context -> term list -> term
   val guarded_Cond_tr: Proof.context -> term list -> term
   val guarded_NNew_tr: Proof.context -> term list -> term
   val guarded_New_tr: Proof.context -> term list -> term
   val guarded_WhileFix_tr: Proof.context -> term list -> term
   val guarded_While_tr: Proof.context -> term list -> term
   val guards_tr': Proof.context -> term list -> term
   val hide_guards: bool Config.T
   val init_tr': Proof.context -> term list -> term
   val init_tr: Proof.context -> term list -> term
   val loc_tr': Proof.context -> term list -> term
   val loc_tr: Proof.context -> term list -> term
   val new_tr : Proof.context -> term list -> term
   val new_tr': Proof.context -> term list -> term
   val nnew_tr : Proof.context -> term list -> term
   val nnew_tr': Proof.context -> term list -> term
   val proc_ass_tr: Proof.context -> term list -> term
   val proc_tr': Proof.context -> term list -> term
   val proc_tr: Proof.context -> term list -> term
   val quote_mult_tr': Proof.context -> (term -> bool) -> string -> string -> term -> term
   val quote_tr': Proof.context -> string -> term -> term
   val quote_tr: Proof.context -> string -> term -> term
   val raise_tr': Proof.context -> term list -> term
   val raise_tr: Proof.context -> term list -> term
   val switch_tr': Proof.context -> term list -> term
   val update_comp: Proof.context -> string list -> bool -> bool -> xstring -> term -> term -> term
   val use_call_tr': bool Config.T
   val whileAnnoGFix_tr': Proof.context -> term list -> term
   val whileAnnoG_tr': Proof.context -> term list -> term
 end;
 
 structure Hoare_Syntax: HOARE_SYNTAX =
 struct
 
 val use_call_tr' = Attrib.setup_config_bool @{binding hoare_use_call_tr'} (K true);
 val hide_guards = Attrib.setup_config_bool @{binding hoare_hide_guards} (K false);
 
 val globalsN = "globals";
 val localsN = "locals";
 val globals_updateN = suffix Record.updateN globalsN;
 val locals_updateN = suffix Record.updateN localsN;
 val upd_globalsN = "upd_globals";   (* FIXME authentic syntax !? *)
 val allocN = "alloc_'";
 val freeN = "free_'";
 
 val Null = Syntax.free "Simpl_Heap.Null";   (* FIXME ?? *)
 
 
 (** utils **)
 
 (* transpose [[a,b],[c,d],[e,f]] = [[a,c,d],[b,d,f]] *)
 fun transpose [[]] = [[]]
   | transpose ([]::xs) = []
   | transpose ((y::ys)::xs) = (y::map hd xs)::transpose (ys::map tl xs)
 
 fun maxprefix eq ([], ys) = []
   | maxprefix eq (xs, []) = []
   | maxprefix eq ((x::xs),(y::ys)) = if eq (x,y)
                                      then x::maxprefix eq (xs,ys)
                                      else []
 
 fun maxprefixs eq [] = []
   | maxprefixs eq [[]] = []
   | maxprefixs eq xss = foldr1 (maxprefix eq) xss;
 
 fun mk_list [] = Syntax.const @{const_syntax Nil}
   | mk_list (x::xs) = Syntax.const @{const_syntax Cons} $ x $ mk_list xs;
 
 (* convert Fail to Match, useful for print translations *)
 fun unsuffix' sfx a = unsuffix sfx a handle Fail _ => raise Match;
 fun unsuffixI sfx a = unsuffix sfx a handle Fail _ => a;
 
 fun is_prefix_or_suffix s t =
   can (unprefix s) t orelse can (unsuffix s) t;
 
 
 (** hoare data **)
 
 fun is_global_comp ctxt name =
   (case StateSpace.get_comp (Context.Proof ctxt) name of
     SOME (_, ln) => is_prefix_or_suffix "globals" (Long_Name.base_name ln)
   | NONE => false);
 
 
 (** parsing and printing **)
 
 (* quote/antiquote *)
 
 val antiquoteCur = @{syntax_const "_antiquoteCur"};
 val antiquoteOld = @{syntax_const "_antiquoteOld"};
 
 fun intern_const_syntax consts =
   Consts.intern_syntax consts #> perhaps Long_Name.dest_hidden;
 
 fun is_global ctxt name =
   let
     val thy = Proof_Context.theory_of ctxt;
     val consts = Proof_Context.consts_of ctxt;
   in
     (case Sign.const_type thy (intern_const_syntax consts name) of
       NONE => is_global_comp ctxt name
     | SOME T => String.isPrefix globalsN (Long_Name.base_name (fst (dest_Type (domain_type T)))))
     handle Match => false
   end;
 
 exception UNDEFINED of string
 
 (* FIXME: if is_state_var etc. is reimplemented, rethink about when adding the deco to
    the records *)
 
 fun first_successful_tr _ [] = raise TERM ("first_successful_tr: no success",[])
   | first_successful_tr f [x] = f x
   | first_successful_tr f (x::xs) = f x handle TERM _ => first_successful_tr f xs;
 
 fun statespace_lookup_tr ctxt ps s n =
   let
     val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt));
     val procs = ps @ cn;
     val names =
       n :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs;
   in first_successful_tr (StateSpace.gen_lookup_tr ctxt s) names
   end;
 
 fun statespace_update_tr ctxt ps id n v s =
   let
     val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt));
     val procs = ps @ cn;
     val names =
       n :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs;
   in first_successful_tr (fn n => StateSpace.gen_update_tr id ctxt n v s) names
   end;
 
 local
   fun is_record_sel ctxt nm =
     let
       val consts = Proof_Context.consts_of ctxt;
-      val exists_const = can (Consts.the_const consts) o intern_const_syntax consts;
+      val exists_const = can (Consts.the_const_type consts) o intern_const_syntax consts;
       val exists_abbrev = can (Consts.the_abbreviation consts) o intern_const_syntax consts;
     in (exists_const nm) orelse (exists_abbrev nm) end;
 in
 
 fun lookup_comp ctxt ps name =
   if is_record_sel ctxt name
   then
     if is_global ctxt name
     then (fn s => Syntax.free name $ (Syntax.free "globals" $ s))
     else (fn s => Syntax.free name $ s)
   else
     let
       val sel = Syntax.const (if is_global_comp ctxt name then "globals" else "locals");
     in (fn s => statespace_lookup_tr ctxt ps (sel $ s) name) end;
 
 (*
 FIXME:
 update of global and local components:
 One should generally provide functions:
 glob_upd:: ('g => 'g) => 's => 's
 loc_upd:: ('l => 'l) => 's => 's
 so that global and local updates can nicely be composed.
 loc_upd for the record implementation is vacuous.
 Right now for example an assignment of NEW to a global variable returns
 a funny repeated update of global components...
 
 This would make the composition more straightforward...
 Basically one wants the map on a component rather then the update. Maps can
 be composed nicer...
 *)
 fun K_rec_syntax v = Abs ("_", dummyT, incr_boundvars 1 v);
 
 fun update_comp ctxt ps atomic id name value =
   if is_record_sel ctxt name
   then
     let
       val upd = Syntax.free (suffix Record.updateN name) $ K_rec_syntax value;
     in
       if atomic andalso is_global ctxt name
       then (fn s =>
         Syntax.free globals_updateN $ (K_rec_syntax (upd $ (Syntax.free globalsN $ s))) $ s)
       else (fn s => upd $ s)
     end
   else
     let
       val reg = if is_global_comp ctxt name then "globals" else "locals";
       val upd = Syntax.free (reg ^ Record.updateN);
       val sel = Syntax.free reg;
     in
       fn s =>
         if atomic then
           upd $ (K_rec_syntax (statespace_update_tr ctxt ps id name value (sel $ s))) $ s
         else statespace_update_tr ctxt ps id name value s
     end;
 
 end;
 
 fun antiquote_global_tr ctxt off i t =
   let
     fun mk n t = lookup_comp ctxt [] n (Bound (i + off n));
      (*if is_global ctxt n then t$(Free ("globals",dummyT)$Bound (i + off n))
        else t$Bound (i + off n)*)
   in
     (case t of
       Free  (n, _) => mk n t
     | Const (n, _) => mk n t
     | _ => t $ Bound i)
   end;
 
 
 fun antiquote_off_tr offset ctxt name =
   let
     fun tr i ((t as Const (c, _)) $ u) =
           if c = name then antiquote_global_tr ctxt offset i (tr i u)
           else tr i t $ tr i u
       | tr i (t $ u) = tr i t $ tr i u
       | tr i (Abs (x, T, t)) = Abs (x, T, tr (i + 1) t)
       | tr _ a = a;
   in tr 0 end;
 
 
 val antiquote_tr = antiquote_off_tr (K 0)
 
 fun quote_tr ctxt name t = Abs ("s", dummyT, antiquote_tr ctxt name (Term.incr_boundvars 1 t));
 
 fun antiquoteCur_tr ctxt t = antiquote_tr ctxt antiquoteCur (Term.incr_boundvars 1 t);
 
 
 fun antiquote_varname_tr anti [n] =
   (case n of
     Free (v, T) => Syntax.const anti $ Free (Hoare.varname v, T)
   | Const (c, T) => Syntax.const anti $ Const (Hoare.varname c, T)
   | _ => Syntax.const anti $ n);
 
 
 
 fun antiquoteOld_tr ctxt [s, n] =
   (case n of
     Free (v, T) => lookup_comp ctxt [] (Hoare.varname v) s
   | Const (c, T) => lookup_comp ctxt [] (Hoare.varname c) s
   | _ => n $ s);
 
 fun antiquote_tr' ctxt name =
   let
     fun is_state i t =
       (case t of
         Bound j => i = j
       | Const (g,_) $ Bound j =>
           i = j andalso member (op =) [globalsN, localsN] (Long_Name.base_name g)
       | _ => false);
     fun tr' i (t $ u) =
        if is_state i u then Syntax.const name $ tr' i (Hoare.undeco ctxt t)
        else tr' i t $ tr' i u
       | tr' i (Abs (x, T, t)) = Abs (x, T, tr' (i + 1) t)
       | tr' i a = if a = Bound i then raise Match else a;
   in tr' 0 end;
 
 fun quote_tr' ctxt name (Abs (_, _, t)) = Term.incr_boundvars ~1 (antiquote_tr' ctxt name t)
   | quote_tr' ctxt name (t as (Const _)) (* eta contracted *) =
       Syntax.const name $ Hoare.undeco ctxt t
   | quote_tr' _ _ _ = raise Match;
 
 
 
 local
 fun state_test (t as Const (g,_) $ u) f  =
       if member (op =) [localsN, globalsN] (Long_Name.base_name g) then f u else f t
   | state_test u f = f u;
 in
 
 fun antiquote_applied_only_to P =
   let
      fun test i (t $ u) =
        state_test u
          (fn Bound j =>
                if j=i then  P t
                else test i t andalso test i u
            | u => test i t andalso test i u)
        | test i (Abs (x, T, t)) = test (i + 1) t
        | test i _ = true;
   in test 0 end;
 
 
 fun antiquote_mult_tr' ctxt is_selector current old  =
   let
     fun tr' i (t $ u) =
           state_test u
             (fn Bound j =>
                   if j = i then Syntax.const current $ tr' i (Hoare.undeco ctxt t)
                   else if is_selector t (* other quantified states *)
                   then Syntax.const old $ Bound j $ tr' i (Hoare.undeco ctxt t)
                   else  tr' i t $ tr' i u
               | pre as ((Const (m,_) $ Free _)) (* pre state *) =>
                   if (m = @{syntax_const "_bound"} orelse m = @{syntax_const "_free"})
                     andalso is_selector t
                   then Syntax.const old $ pre $ tr' i (Hoare.undeco ctxt t)
                   else tr' i t $ pre
               | pre as ((Const (m,_) $ Var _)) (* pre state *) =>
                   if m = @{syntax_const "_var"} andalso is_selector t
                   then Syntax.const old $ pre $ tr' i (Hoare.undeco ctxt t)
                   else tr' i t $ pre
               | u => tr' i t $ tr' i u)
       | tr' i (Abs (x, T, t)) = Abs (x, T, tr' (i + 1) t)
       | tr' i a = if a = Bound i then raise Match else a;
   in tr' 0 end;
 end;
 
 fun quote_mult_tr' ctxt is_selector current old  (Abs (_, _, t)) =
       Term.incr_boundvars ~1 (antiquote_mult_tr' ctxt is_selector current old t)
   | quote_mult_tr' _ _ _ _ _ = raise Match;
 
 fun app_quote_tr' ctxt f (t :: ts) =
       Term.list_comb (f $ quote_tr' ctxt antiquoteCur t, ts)
   | app_quote_tr' _ _ _ = raise Match;
 
 fun app_quote_mult_tr' ctxt is_selector f (t :: ts) =
       Term.list_comb (f $ quote_mult_tr' ctxt is_selector antiquoteCur antiquoteOld  t, ts)
   | app_quote_mult_tr' _ _ _ _ = raise Match;
 
 
 fun atomic_var_tr ctxt ps name value =
   update_comp ctxt ps true false name value;
 
 
 fun heap_var_tr ctxt hp p value =
   let
     fun upd s =
       update_comp ctxt [] true false hp
         (Syntax.const @{const_syntax fun_upd} $ lookup_comp ctxt [] hp s $ p $ value) s;
   in upd end;
 
 fun get_arr_var (Const (@{const_syntax List.nth},_) $ arr $ i) =
       (case get_arr_var arr of
          SOME (name,p,is) => SOME (name,p,i::is)
        | NONE => NONE)
   | get_arr_var (Const (@{syntax_const "_antiquoteCur"},_) $ Free (var,_)) =
      if Hoare.is_state_var var then SOME (var,NONE,[]) else NONE
   | get_arr_var (Const (@{syntax_const "_antiquoteCur"},_) $ Const (var,_)) =
      if Hoare.is_state_var var then SOME (var,NONE,[]) else NONE
   | get_arr_var ((Const (@{syntax_const "_antiquoteCur"},_) $ Free (hp,_)) $ p) =
      if Hoare.is_state_var hp then SOME (hp,SOME p,[]) else NONE
   | get_arr_var ((Const (@{syntax_const "_antiquoteCur"},_) $ Const (hp,_)) $ p) =
      if Hoare.is_state_var hp then SOME (hp,SOME p,[]) else NONE
   | get_arr_var _ = NONE
 
 
 fun arr_var_tr ctxt ps name arr pos value idxs  =
   let
     fun sel_tr [] = arr
       | sel_tr (i::is) = Syntax.const @{const_syntax nth} $ sel_tr is $ i;
 
     fun lupd_tr value [] _ = value
       | lupd_tr value (i::is) idxs  =
           Syntax.const @{const_syntax list_update} $ sel_tr idxs $ i $ lupd_tr value is (i::idxs);
 
 
     val value' = lupd_tr value idxs [];
   in case pos of
        NONE   => atomic_var_tr ctxt ps name value'
      | SOME p => heap_var_tr ctxt name p value'
   end;
 
 fun get_arr_mult_var (Const (@{syntax_const "_antiquoteCur"},_) $ Free (var,_)) =
      if Hoare.is_state_var var then SOME (var,NONE) else NONE
   | get_arr_mult_var (Const (@{syntax_const "_antiquoteCur"},_) $ Const (var,_)) =
      if Hoare.is_state_var var then SOME (var,NONE) else NONE
   | get_arr_mult_var ((Const (@{syntax_const "_antiquoteCur"},_) $ Free (hp,_)) $ p) =
      if Hoare.is_state_var hp then SOME (hp,SOME p) else NONE
   | get_arr_mult_var ((Const (@{syntax_const "_antiquoteCur"},_) $ Const (hp,_)) $ p) =
      if Hoare.is_state_var hp then SOME (hp,SOME p) else NONE
   | get_arr_mult_var _ = NONE
 
 fun arr_mult_var_tr ctxt ps name arr pos vals idxs  =
   let
     val value' = Syntax.const @{const_syntax list_multupd} $ arr $ idxs $ vals;
   in
     case pos of
       NONE => atomic_var_tr ctxt ps name value'
     | SOME p => heap_var_tr ctxt name p value'
   end;
 
 fun update_tr ctxt ps off_var off_val e
         (v as Const (@{syntax_const "_antiquoteCur"},_) $ Free (var,_)) =
       if Hoare.is_state_var var then atomic_var_tr ctxt ps var e
       else raise TERM ("no proper lvalue", [v])
   | update_tr ctxt ps off_var off_val e
         ((v as Const (@{syntax_const "_antiquoteCur"},_) $ Free (hp, _)) $ p) =
       if Hoare.is_state_var hp
       then heap_var_tr ctxt hp (antiquote_off_tr off_val ctxt antiquoteCur p) e
       else raise TERM ("no proper lvalue",[v])
   | update_tr ctxt ps off_var off_val e
         (v as Const (@{const_syntax list_multsel}, _) $ arr $ idxs) =
       (case get_arr_mult_var arr of
          SOME (var, pos) =>
             let
               val pos' = Option.map (antiquote_off_tr off_val ctxt antiquoteCur) pos;
               val var' = lookup_comp ctxt ps var (Bound (off_var var));
               val arr' = case pos' of NONE => var' | SOME p => var' $ p;
               val idxs' = antiquote_off_tr off_val ctxt antiquoteCur idxs;
             in arr_mult_var_tr ctxt ps var arr' pos' e idxs' end
        | NONE =>  raise TERM ("no proper lvalue", [v]))
   | update_tr ctxt ps off_var off_val e v =
       (case get_arr_var v of
         SOME (var,pos,idxs) =>
           let
             val pos' = Option.map (antiquote_off_tr off_val ctxt antiquoteCur) pos;
             val var' = lookup_comp ctxt ps var (Bound (off_var var));
             val arr' = case pos' of NONE => var' | SOME p => var' $ p;
             val idxs' = rev (map (antiquote_off_tr off_val ctxt antiquoteCur) idxs);
           in arr_var_tr ctxt ps var arr' pos' e idxs' end
       | NONE => raise TERM ("no proper lvalue", [v]))
   | update_tr _ _ _ _ e t = raise TERM ("update_tr", [t])
 
 
 fun app_assign_tr f ctxt [v, e] =
       let
         fun offset _ = 0;
       in f $ Abs ("s", dummyT, update_tr ctxt [] offset offset (antiquoteCur_tr ctxt e) v (Bound 0))
       end
   | app_assign_tr _ _ ts = raise TERM ("assign_tr", ts);
 
 
 val assign_tr = app_assign_tr (Syntax.const @{const_syntax Basic});
 val raise_tr = app_assign_tr (Syntax.const @{const_syntax raise});
 
 
 fun basic_assign_tr ctxt (ts as [v, e]) =
       let
         fun offset v = 0;
       in update_tr ctxt [] offset offset (antiquoteCur_tr ctxt e) v
       end
   | basic_assign_tr _ ts = raise TERM ("basic_assign_tr", ts);
 
 fun basic_assigns_tr ctxt [t] =
       let
         fun dest_basic (Const (@{syntax_const "_BAssign"}, _) $ v $ e) =
               basic_assign_tr ctxt [v,e]
           | dest_basic _ = raise Match;
 
         fun dest_basics (Const (@{syntax_const "_basics"}, _) $ x $ xs) =
               dest_basic x :: dest_basics xs
           | dest_basics (t as Const (@{syntax_const "_BAssign"}, _) $_ $ _) =
               [dest_basic t]
           | dest_basics _ = []
         val upds = dest_basics t;
       in Abs ("s", dummyT, fold (fn upd => fn s => upd s) upds (Bound 0))
       end
   | basic_assigns_tr _ ts = raise TERM ("basic_assigns_tr", ts);
 
 fun basic_tr ctxt [t] =
   Syntax.const @{const_syntax Basic} $
     (Abs ("s", dummyT,
       antiquote_tr ctxt @{syntax_const "_antiquoteCur"} (Term.incr_boundvars 1 t) $ Bound 0));
 
 fun init_tr ctxt [Const (var,_),comp,value] =
       let
         fun dest_set (Const (@{const_syntax Set.empty}, _)) = []
           | dest_set (Const (@{const_syntax insert}, _) $ x $ xs) = x :: dest_set xs;
 
         fun dest_list (Const (@{const_syntax Nil}, _)) = []
           | dest_list (Const (@{const_syntax Cons}, _) $ Free (x, _) $ xs) = x :: dest_list xs;
 
         fun dest_val_list (Const (@{const_syntax Nil}, _)) = []
           | dest_val_list (Const (@{const_syntax Cons},_) $ x $ xs) =
               dest_set x :: dest_val_list xs
           | dest_val_list t = [dest_set t];
 
         val values =
           (case value of
             Const (@{const_syntax Cons}, _) $ _ $ _ =>
               map mk_list (transpose (dest_val_list value))
           | Const (@{const_syntax insert}, _) $ _ $ _ =>
               dest_set value
           | _ => raise TERM ("unknown variable initialization", []))
         val comps = dest_list comp;
         fun mk_upd var c v =
           Syntax.free (suffix Record.updateN (Hoare.varname (suffix ("_" ^ c) var))) $ v;
         val upds = map2 (mk_upd var) comps values;
         val app_upds = fold (fn upd => fn s => upd $ s) upds;
         val upd =
           if is_global ctxt (Hoare.varname (suffix ("_" ^ hd comps) var)) then
             Syntax.free (suffix Record.updateN globalsN) $
               app_upds (Syntax.free globalsN $ Bound 0) $ Bound 0
           else app_upds (Bound 0)
       in
         Syntax.const @{const_syntax Basic} $ Abs ("s", dummyT, upd)
       end
   | init_tr _ _ = raise Match;
 
 
 fun new_tr ctxt (ts as [var,size,init]) =
       let
         fun offset v = 0;
         fun dest_init (Const (@{syntax_const "_newinit"}, _) $ Const (var, _) $ v) = (var, v)
           | dest_init _ = raise Match;
 
         fun dest_inits (Const (@{syntax_const "_newinits"}, _) $ x $ xs) =
               dest_init x :: dest_inits xs
           | dest_inits (t as (Const (@{syntax_const "_newinit"}, _) $_ $ _)) = [dest_init t]
           | dest_inits _ = raise Match;
 
         val g = Syntax.free globalsN $ Bound 0;
         val alloc = lookup_comp ctxt [] allocN (Bound 0);
         val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc);  (* FIXME new !? *)
 
         fun mk_upd (var,v) =
           let
             val varn = Hoare.varname var;
             val var' = lookup_comp ctxt [] varn (Bound 0);
           in
             update_comp ctxt [] false false varn
               (Syntax.const @{const_syntax fun_upd} $ var' $ new $ v)
           end;
 
         val inits = map mk_upd (dest_inits init);
         val free = lookup_comp ctxt [] freeN (Bound 0);
         val freetest = Syntax.const @{const_syntax Orderings.less_eq} $ size $ free;
 
         val alloc_upd =
           update_comp ctxt [] false false allocN
             (Syntax.const @{const_syntax Cons} $ new $ alloc);
         val free_upd =
           update_comp ctxt [] false false freeN
             (Syntax.const @{const_syntax Groups.minus} $ free $ size);
 
         val g' =
           Syntax.free (suffix Record.updateN globalsN) $
             K_rec_syntax (fold (fn upd => fn s => upd s) (alloc_upd :: free_upd :: inits) g) $
             Bound 0;
         val cond =
           Syntax.const @{const_syntax If} $ freetest $
             update_tr ctxt [] offset offset new var g' $
             update_tr ctxt [] offset offset Null var (Bound 0);
 
       in Syntax.const @{const_syntax Basic} $ Abs ("s", dummyT, cond)
       end
   | new_tr _ ts = raise TERM ("new_tr",ts);
 
 fun nnew_tr ctxt (ts as [var,size,init]) =
       let
         fun offset v = 0;
         fun dest_init (Const (@{syntax_const "_newinit"}, _) $ Const (var, _) $ v) = (var, v)
           | dest_init _ = raise Match;
 
         fun dest_inits (Const (@{syntax_const "_newinits"}, _) $ x $ xs) =
               dest_init x :: dest_inits xs
           | dest_inits (t as (Const (@{syntax_const "_newinit"}, _) $ _ $ _)) =
               [dest_init t]
           | dest_inits _ = raise Match;
 
         val g = Syntax.free globalsN $ Bound 0;
         val alloc = lookup_comp ctxt [] allocN (Bound 0);
         val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc);  (* FIXME new !? *)
 
         fun mk_upd (var,v) =
           let
             val varn = Hoare.varname var;
             val var' = lookup_comp ctxt [] varn (Bound 0);
           in
             update_comp ctxt [] false false varn
               (Syntax.const @{const_syntax fun_upd} $ var' $ new $ v)
           end;
 
         val inits = map mk_upd (dest_inits init);
         val free = lookup_comp ctxt [] freeN (Bound 0);
         val freetest = Syntax.const @{const_syntax Orderings.less_eq} $ size $ free;
 
         val alloc_upd =
           update_comp ctxt [] false false allocN
             (Syntax.const @{const_syntax Cons} $ new $ alloc);
         val free_upd =
           update_comp ctxt [] false false freeN
             (Syntax.const @{const_syntax Groups.minus} $ free $ size);
 
         val g' =
           Syntax.free (suffix Record.updateN globalsN) $
             K_rec_syntax (fold (fn upd => fn s => upd s) (alloc_upd :: inits @ [free_upd]) g) $
             Bound 0;
         val cond =
           Syntax.const @{const_syntax if_rel} $ Abs ("s", dummyT, freetest) $
             Abs ("s", dummyT, update_tr ctxt [] offset offset new var g') $
             Abs ("s", dummyT, update_tr ctxt [] offset offset Null var (Bound 0)) $
             Abs ("s", dummyT, update_tr ctxt [] offset offset new var g');
 
       in Syntax.const @{const_syntax Spec} $ cond
       end
   | nnew_tr _ ts = raise TERM ("nnew_tr", ts);
 
 fun loc_tr ctxt (ts as [init, bdy]) =
   let
     fun dest_init (Const (@{syntax_const "_locinit"}, _) $ Const (var,_) $ v) = (var, v)
       | dest_init (Const (@{syntax_const "_locnoinit"}, _) $ Const (var, _)) =
            (var, Syntax.const antiquoteCur $ Syntax.free (Hoare.varname var))
            (* FIXME could skip this dummy initialisation v := v s and
               derive non init variables in the print translation from
               the return function instead the init function *)
       | dest_init _ = raise Match;
 
     fun dest_inits (Const (@{syntax_const "_locinits"}, _) $ x $ xs) = dest_init x :: dest_inits xs
       | dest_inits (t as (Const (@{syntax_const "_locinit"}, _) $ _ $ _)) = [dest_init t]
       | dest_inits (t as (Const (@{syntax_const "_locnoinit"}, _) $ _)) = [dest_init t]
       | dest_inits _ = raise Match;
 
     fun mk_init_upd (var, v) =
       update_comp ctxt [] true false var (antiquoteCur_tr ctxt v);
 
     fun mk_ret_upd var =
       update_comp ctxt [] true false var (lookup_comp ctxt [] var (Bound 1));
 
     val var_vals = map (apfst Hoare.varname) (dest_inits init);
     val ini = Abs ("s", dummyT, fold mk_init_upd var_vals (Bound 0));
     val ret = Abs ("s",dummyT, Abs ("t",dummyT, fold (mk_ret_upd o fst) var_vals (Bound 0)));
     val c = Abs ("i", dummyT, Abs ("t", dummyT, Syntax.const @{const_syntax Skip}));
 
   in Syntax.const @{const_syntax block} $ ini $ bdy $ ret $ c end
 
 infixr 9 &;
 
 fun (NONE & NONE) = NONE
   | ((SOME x) & NONE) = SOME x
   | (NONE & (SOME x)) = SOME x
   | ((SOME x) & (SOME y)) = SOME (Syntax.const @{const_syntax HOL.conj} $ x $ y);
 
 fun mk_imp (l,SOME r) = SOME (HOLogic.mk_imp (l, r))
   | mk_imp (l,NONE) = NONE;
 
 
 local
 
 fun le l r =
   Syntax.const @{const_syntax Orderings.less} $ l $ r;
 
 fun in_range t = Syntax.free "in_range" $ t;   (* FIXME ?? *)
 
 fun not_zero t =
   Syntax.const @{const_syntax Not} $
     (Syntax.const @{const_syntax HOL.eq} $ t $ Syntax.const @{const_syntax Groups.zero});
 
 fun not_Null t =
   Syntax.const @{const_syntax Not} $
     (Syntax.const @{const_syntax HOL.eq} $ t $ Syntax.free "Simpl_Heap.Null");   (* FIXME ?? *)
 
 fun in_length i l =
   Syntax.const @{const_syntax Orderings.less} $ i $
     (Syntax.const @{const_syntax size} $ l);
 
 fun is_pos t =
   Syntax.const @{const_syntax Orderings.less_eq} $ Syntax.const @{const_syntax Groups.zero} $ t;
 
 
 fun infer_type ctxt t =
   Syntax.check_term ctxt (Exn.release (#2 (Syntax_Phases.decode_term ctxt ([], Exn.Res t))));
 
 
 (* NOTE: operations on actual terms *)
 
 fun is_arr (Const (@{const_name List.nth},_) $ l $ e) = is_arr l
   | is_arr (Const (a, _) $ Bound 0) = Hoare.is_state_var a
   | is_arr (Const (a,_) $ (Const (globals,_) $ Bound 0)) = Hoare.is_state_var a
   | is_arr ((Const (hp,_) $ (Const (globals,_) $ Bound 0)) $ p) = Hoare.is_state_var hp
   | is_arr _ = false;
 
 fun dummyfyT (TFree x) = TFree x
   | dummyfyT (TVar x) = dummyT
   | dummyfyT (Type (c, Ts)) =
      let
        val Ts' = map dummyfyT Ts;
      in if exists (fn T => T = dummyT) Ts' then dummyT else Type (c, Ts') end;
 
 fun guard ctxt Ts (add as (Const (@{const_name Groups.plus},_) $ l $ r)) =
       guard ctxt Ts l & guard ctxt Ts r & SOME (in_range add)
   | guard ctxt Ts (sub as (Const (@{const_name Groups.minus},_) $ l $ r)) =
       let
         val g =
           (if fastype_of1 (Ts,sub) = HOLogic.natT then le r l else in_range sub)
             handle TERM _ => error ("guard generation, cannot determine type of: " ^
               Syntax.string_of_term ctxt sub);
       in guard ctxt Ts l & guard ctxt Ts r & SOME g end
   | guard ctxt Ts (mul as (Const (@{const_name Groups.times},_) $ l $r)) =
       guard ctxt Ts l & guard ctxt Ts r & SOME (in_range mul)
   | guard ctxt Ts (Const (@{const_name HOL.conj},_) $ l $ r) =
       guard ctxt Ts l & mk_imp (l,guard ctxt Ts r)
   | guard ctxt Ts (Const (@{const_name HOL.disj},_) $ l $ r) =
       guard ctxt Ts l & mk_imp (HOLogic.Not $ l,guard ctxt Ts r)
   | guard ctxt Ts (dv as (Const (@{const_name Rings.divide},_) $ l $ r)) =
       guard ctxt Ts l & guard ctxt Ts r & SOME (not_zero r) & SOME (in_range dv) (* FIXME: Make more concrete guard...*)
   | guard ctxt Ts (Const (@{const_name Rings.modulo},_) $ l $ r) =
       guard ctxt Ts l & guard ctxt Ts r & SOME (not_zero r)
   | guard ctxt Ts (un as (Const (@{const_name Groups.uminus},_) $ n)) =
       guard ctxt Ts n & SOME (in_range un)
   | guard ctxt Ts (Const (@{const_name Int.nat},_) $ i) =
       guard ctxt Ts i & SOME (is_pos i)
   | guard ctxt Ts (i as (Const (@{const_abbrev Int.int},_) $ n)) =
       guard ctxt Ts n & SOME (in_range i)
   | guard ctxt Ts (Const (@{const_name List.nth},_) $ l $ e) =
       if is_arr l then guard ctxt Ts l & guard ctxt Ts e & SOME (in_length e l)
       else NONE (*oder default?*)
   | guard ctxt Ts (Const (hp,_) $ (Const (globals,_) $ Bound 0) $ p) =
       if Hoare.is_state_var hp then guard ctxt Ts p & SOME (not_Null p)(*& SOME (in_alloc p)*)
       else guard ctxt Ts p
 
 (*  | guard (Const (@{const_name "list_update"},_)$l$i$e) =
       if is_arr l then guard i & SOME (in_length i l) & guard e else NONE*) (* oder default?*)
 (*  | guard (Const (upd,_)$e$s) = for procedure parameters,like default but left to right
       if is_some (try (unsuffix updateN) upd) then guard s & guard e else guard e & guard s *)
   | guard ctxt Ts t =
       fold_rev (fn l => fn r => guard ctxt Ts l & r) (snd (strip_comb t)) NONE (* default *)
   | guard _ _ _ = NONE;
 
 in
 
  fun mk_guard ctxt t =
    let
       (* We apply type inference first, so that we can generate different guards,
          depending on the type, e.g. int vs. nat *)
       val Abs (_, T, t') = map_types dummyfyT (infer_type ctxt (Abs ("s", dummyT, t)));
    in guard ctxt [T] t' end;
 
 end;
 (* FIXME: make guard function a parameter of all parse-translations that need it.*)
 
 val _ = Theory.setup (Context.theory_map (Hoare.install_generate_guard mk_guard));
 
 
 fun mk_singleton_guard f g =
   Syntax.const @{const_syntax Cons} $
     (Syntax.const @{const_syntax Pair} $ Syntax.const f $
       (Syntax.const @{const_syntax Collect} $ Abs ("s", dummyT, g))) $
     Syntax.const @{const_syntax Nil};
 
 fun guarded_Assign_tr ctxt (ts as [v, e]) =
       let
         val ass = assign_tr ctxt [v, e];
         val guard = Hoare.generate_guard ctxt;
         (* By the artificial "=" between left and right-hand side we get a bigger term and thus
            more information for type-inference *)
       in
         case guard (Syntax.const @{const_syntax HOL.eq} $
             antiquoteCur_tr ctxt v $ antiquoteCur_tr ctxt e) of
           NONE => ass
         | SOME g =>
             Syntax.const @{const_syntax guards} $ mk_singleton_guard @{const_syntax False} g $ ass
       end
   | guarded_Assign_tr _ ts = raise Match;
 
 fun guarded_New_tr ctxt (ts as [var, size, init]) =
       let
         val new = new_tr ctxt [var, size, init];
         val guard = Hoare.generate_guard ctxt;
       in
         case guard (antiquoteCur_tr ctxt var) of
           NONE => new
         | SOME g =>
             Syntax.const @{const_syntax guards} $ mk_singleton_guard @{const_syntax False} g $ new
       end
   | guarded_New_tr _ ts = raise TERM ("guarded_New_tr", ts);
 
 fun guarded_NNew_tr ctxt (ts as [var, size, init]) =
       let
         val new = nnew_tr ctxt [var, size, init];
         val guard = Hoare.generate_guard ctxt;
       in
         case guard (antiquoteCur_tr ctxt var) of
           NONE => new
         | SOME g =>
             Syntax.const @{const_syntax guards} $ mk_singleton_guard @{const_syntax False} g $ new
       end
   | guarded_NNew_tr _ ts = raise TERM ("guarded_NNew_tr", ts);
 
 
 fun guarded_While_tr ctxt (ts as [b,I,V,c]) =
       let
         val guard = Hoare.generate_guard ctxt;
         val cnd as Abs (_, _, b') = quote_tr ctxt antiquoteCur b;
         val b'' = Syntax.const @{const_syntax Collect} $ cnd;
       in
         case guard b' of
           NONE => Syntax.const @{const_syntax whileAnno} $ b'' $ I $ V $ c
         | SOME g =>
             Syntax.const @{const_syntax whileAnnoG} $
               mk_singleton_guard @{const_syntax False} g $ b'' $ I $ V $ c
       end
   | guarded_While_tr _ ts = raise Match;
 
 fun guarded_WhileFix_tr ctxt (ts as [b as (_ $ Abs (_, _, b')), I, V, c]) =
       let
         val guard = Hoare.generate_guard ctxt;
       in
         case guard b' of
           NONE => Syntax.const @{const_syntax whileAnnoFix} $ b $ I $ V $ c
         | SOME g =>
             Syntax.const @{const_syntax whileAnnoGFix} $
               mk_singleton_guard @{const_syntax False} g $ b $ I $ V $ c
       end
   | guarded_WhileFix_tr _ ts = raise Match;
 
 fun guarded_Cond_tr ctxt (ts as [b, c, d]) =
       let
         val guard = Hoare.generate_guard ctxt;
         val cnd as Abs (_, _, b') = quote_tr ctxt @{syntax_const "_antiquoteCur"} b;
         val cond =
           Syntax.const @{const_syntax Cond} $ (Syntax.const @{const_syntax Collect} $ cnd) $ c $ d;
       in
         case guard b' of
           NONE => cond
         | SOME g =>
             Syntax.const @{const_syntax guards} $ mk_singleton_guard @{const_syntax False} g $ cond
       end
   | guarded_Cond_tr _ ts = raise Match;
 
 
 (* parsing procedure calls *)
 
 fun dest_pars (Const (@{syntax_const "_par"}, _) $ p) = [p]
   | dest_pars (Const (@{syntax_const "_pars"}, _) $ p $ ps) = dest_pars p @ dest_pars ps
   | dest_pars t = raise TERM ("dest_pars", [t]);
 
 fun dest_actuals (Const (@{syntax_const "_actuals_empty"}, _)) = []
   | dest_actuals (Const (@{syntax_const "_actuals"}, _) $ pars) = dest_pars pars
   | dest_actuals t = raise TERM ("dest_actuals", [t]);
 
 
 fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont =
   let
     val fcall = cont <> NONE;
     val state_kind =
       the_default (Hoare.get_default_state_kind ctxt)
         (Hoare.get_state_kind pn ctxt);
     fun init_par_tr name arg =
       update_comp ctxt [] false false name (antiquoteCur_tr ctxt arg);
 
     fun result_par_tr name arg =
       let
         fun offset_old n = 2;
         fun offset n = if is_global ctxt n then 0 else 2;
       in
         update_tr ctxt [pn] offset offset_old
           (lookup_comp ctxt [] name (Bound 1)) arg
       end;
 
     val _ = if not (Config.get ctxt StateSpace.silent) andalso
                ((not fcall andalso length formals <> length actuals)
                  orelse
                 (fcall andalso length formals <> length actuals + 1))
             then raise
                 TERM ("call_tr: number of formal (" ^ string_of_int (length formals) ^
                       ") and actual (" ^ string_of_int (length actuals) ^
                       ") parameters for \"" ^ unsuffix Hoare.proc_deco pn ^
                       "\" do not match.", [])
             else ();
 
     val globals =
       [Syntax.const globals_updateN $ (K_rec_syntax (Const (globalsN, dummyT) $ Bound 0))];
     val ret = Abs ("s", dummyT, Abs ("t", dummyT, Library.foldr (op $) (globals, Bound 1)));
 
     val val_formals = filter (fn (kind, _) => kind = Hoare.In) formals;
     val res_formals = filter (fn (kind, _) => kind = Hoare.Out) formals;
 
     val (val_actuals, res_actuals) = chop (length val_formals) actuals;
     val init_bdy =
       let
         val state =
           (case state_kind of
             Hoare.Record => Bound 0
           | Hoare.Function => Syntax.const localsN $ Bound 0);
         val upds = fold2 (fn (_, name) => init_par_tr name) val_formals val_actuals state;
       in
         (case state_kind of
           Hoare.Record => upds
         | Hoare.Function => Syntax.const locals_updateN $ K_rec_syntax upds $ Bound 0)
       end;
     val init = Abs ("s", dummyT, init_bdy);
 
 
     val call =
       (case cont of
         NONE => (* Procedure call *)
             let
               val results =
                 map (fn ((_, name), arg) => result_par_tr name arg)
                   (rev (res_formals ~~ res_actuals));
               val res =
                 Abs ("i", dummyT, Abs ("t", dummyT,
                     Syntax.const @{const_syntax Basic} $
                       Abs ("s", dummyT, fold_rev (fn f => fn s => f s) results (Bound 0))));
             in if has_args then Call $init $ pt $ ret $ res else Call $ pt end
         | SOME c => (* Function call *)
             let
               val res =
                 (case res_formals of
                   [(_, n)] => Abs ("s", dummyT, lookup_comp ctxt [] n (Bound 0))
                 | _ =>
                     if Config.get ctxt StateSpace.silent
                     then Abs ("s", dummyT, lookup_comp ctxt [] "dummy" (Bound 0))
                     else raise TERM ("call_tr: function " ^ pn ^ "may only have one result parameter", []));
             in Call $ init $ pt $ ret $ res $ c end)
     val guard = Hoare.generate_guard  ctxt;
   in
     if grd
     then
       (case fold_rev (fn arg => fn g => guard (antiquoteCur_tr ctxt arg) & g)
           (res_actuals @ val_actuals) NONE of
         NONE => call
       | SOME g =>
           Syntax.const @{const_syntax guards} $ mk_singleton_guard @{const_syntax False} g $ call)
     else call
   end;
 
 
 (* FIXME: What is prfx for, maybe unused *)
 fun dest_procname ctxt prfx false (Const (p, _)) =
       (prfx ^ suffix Hoare.proc_deco p, HOLogic.mk_string p)
   | dest_procname ctxt prfx false (t as Free (p, T)) =
       (prfx ^ suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T))
   | dest_procname ctxt prfx false (Const (@{syntax_const "_free"},_) $ Free (p,T)) =
       (prfx ^ suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T))
   | dest_procname ctxt prfx false (t as (Const (@{syntax_const "_antiquoteCur"},_) $ Const (p, _))) =
       (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t)
   | dest_procname ctxt prfx false (t as (Const (@{syntax_const "_antiquoteCur"}, _) $ Free (p, _))) =
       (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t)
   | dest_procname ctxt prfx false (t as Const (p, _) $ _) =
       (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *)
   | dest_procname ctxt prfx false (t as Free (p,_)$_)  =
       (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *)
   | dest_procname ctxt prfx false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Const (p, _)) =
       (prfx ^ suffix Hoare.proc_deco p, t)
   | dest_procname ctxt prfx false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Free (p,_)) =
       (prfx ^ suffix Hoare.proc_deco p, t)
   (* FIXME StateFun.lookup !? *)
   | dest_procname ctxt prfx false (t as Const (@{const_name "StateFun.lookup"}, _) $ _ $ Free (p, _) $ _) =
       (prfx ^ suffix Hoare.proc_deco (Hoare.remdeco' p), t) (* antiquoteOld *)
 
   | dest_procname ctxt prfx false t = (prfx, t)
   | dest_procname ctxt prfx true t =
       let fun quote t = Abs ("s", dummyT, antiquoteCur_tr ctxt t)
       in
         (case quote t of
           (t' as Abs (_, _, Free (p, _) $ Bound 0)) =>
             (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t')
         (* FIXME StateFun.lookup !? *)
         | (t' as Abs (_, _, Const (@{const_name "StateFun.lookup"}, _) $ _ $ Free (p, _) $ (_ $ Bound 0))) =>
             (prfx ^ suffix Hoare.proc_deco (Hoare.remdeco' p), t')
         | t' => (prfx, t'))
       end
 
 fun gen_call_tr prfx dyn grd ctxt p actuals has_args cont =
   let
     fun Call false true NONE = Const (@{const_syntax call}, dummyT)
       | Call false false NONE = Const (@{const_syntax Call}, dummyT)
       | Call true true NONE = Const (@{const_syntax dynCall}, dummyT)
       | Call false true (SOME c) = Const (@{const_syntax fcall}, dummyT)
       | Call _ _ _ = raise TERM ("gen_call_tr: no proper procedure call", []);
 
     val (pn, pt) = dest_procname ctxt prfx dyn (Term_Position.strip_positions p);
   in
     (case Hoare.get_params pn ctxt of
       SOME formals =>
         mk_call_tr ctxt grd (Call dyn has_args cont) formals pn pt actuals has_args cont
     | NONE =>
         if Config.get ctxt StateSpace.silent
         then mk_call_tr ctxt grd (Call dyn has_args cont) [] pn pt [] has_args cont
         else raise TERM ("gen_call_tr: procedure " ^ quote pn ^ " not defined", []))
   end;
 
 fun call_tr dyn grd ctxt [p, actuals] =
       gen_call_tr "" dyn grd ctxt p (dest_actuals actuals) true NONE
   | call_tr _ _ _  t = raise TERM ("call_tr", t);
 
 fun call_ass_tr dyn grd ctxt [l, p, actuals] =
       gen_call_tr "" dyn grd ctxt p (dest_actuals actuals @ [l]) true NONE
   | call_ass_tr  _ _ _ t = raise TERM ("call_ass_tr", t);
 
 fun proc_tr ctxt [p, actuals] =
       gen_call_tr "" false false ctxt p (dest_actuals actuals) false NONE
   | proc_tr _  t = raise TERM ("proc_tr", t);
 
 fun proc_ass_tr ctxt [l, p, actuals] =
       gen_call_tr "" false false ctxt p (dest_actuals actuals @ [l]) false NONE
   | proc_ass_tr _ t = raise TERM ("proc_ass_tr", t);
 
 fun fcall_tr ctxt [p, actuals, c] =
       gen_call_tr "" false false ctxt p (dest_actuals actuals) true (SOME c)
   | fcall_tr _ t = raise TERM ("fcall_tr", t);
 
 
 (* printing procedure calls *)
 
 fun upd_tr' ctxt (x_upd, T) =
   (case try (unsuffix' Record.updateN) x_upd of
     SOME x =>
       (Hoare.chopsfx Hoare.deco (Hoare.extern ctxt x),
        if T = dummyT then T else Term.domain_type T)
   | NONE =>
       (case try (unsuffix Hoare.deco) x_upd of
         SOME _ => (Hoare.remdeco ctxt x_upd, T)
       | NONE => raise Match));
 
 
 fun update_name_tr' ctxt (Free x) = Const (upd_tr' ctxt x)
   | update_name_tr' ctxt ((c as Const (@{syntax_const "_free"}, _)) $ Free x) =
       (*c $*) Const (upd_tr' ctxt x)
   | update_name_tr' ctxt (Const x) = Const (upd_tr' ctxt x)
   | update_name_tr' _ _ = raise Match;
 
 fun term_name_eq (Const (x, _)) (Const (y, _)) = (x = y)
   | term_name_eq (Free (x, _)) (Free (y, _)) = (x = y)
   | term_name_eq (Var (x, _)) (Var (y, _)) = (x = y)
   | term_name_eq (a $ b) (c $ d) = term_name_eq a c andalso term_name_eq b d
   | term_name_eq (Abs (s, _, a)) (Abs (t, _, b)) = (s = t) andalso term_name_eq a b
   | term_name_eq _ _ = false;
 
 fun list_update_tr' l (r as Const (@{const_syntax list_update},_) $ l' $ i $ e) =
       if term_name_eq l l'
       then
         let
           fun sel_arr a [i] (Const (@{const_syntax nth},_) $ a' $ i') =
                 term_name_eq a a' andalso i = i'
             | sel_arr a (i::is) (Const (@{const_syntax nth},_) $ sel $ i') =
                 i = i' andalso sel_arr a is sel
             | sel_arr _ _ _ = false;
 
           fun tr' a idxs (e as Const (@{const_syntax list_update}, _) $ sel $ i $ e') =
                 if sel_arr a idxs sel then tr' a (i :: idxs) e'
                 else (idxs, e)
             | tr' _ idxs e = (idxs, e);
 
           val (idxs, e') = tr' l [i] e;
           val lft = fold_rev (fn i => fn arr => Syntax.const @{const_syntax nth} $ arr $ i) idxs l;
         in (lft,e') end
       else (l, r)
   | list_update_tr' l r  = (l, r);
 
 fun list_mult_update_tr' l (r as Const (@{const_syntax list_multupd},_) $ var $ idxs $ values) =
       (Syntax.const @{const_syntax list_multsel} $ var $ idxs, values)
   | list_mult_update_tr' l r = (l, r);
 
 fun update_tr' l (r as Const (@{const_syntax fun_upd}, _) $
         (hp as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ p $ value) =
       if term_name_eq l hp then
         (case value of
           (Const (@{const_syntax list_update}, _) $ _ $ _ $ _) => list_update_tr' (l $ p) value
         | (Const (@{const_syntax list_multupd},_) $ _ $ _ $ _) => list_mult_update_tr' (l $ p) value
         | _ => (l $ p, value))
       else (l, r)
   | update_tr' l (r as Const (@{const_syntax list_update},_) $
         (var as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ i $ value) =
       if term_name_eq l var then list_update_tr' l r else (l, r)
   | update_tr' l (r as Const (@{const_syntax list_multupd}, _) $
         (var as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ idxs $ values) =
       if term_name_eq l var then list_mult_update_tr' l r else (l, r)
   | update_tr' l r = (l, r);
 
 
 fun dest_K_rec (Abs (_, _, v)) =
       if member (op =) (loose_bnos v) 0 then NONE else SOME (incr_boundvars ~1 v)
   | dest_K_rec (Abs (_, _, Abs (_, _, v) $ Bound 0)) = (* eta expanded version *)
       let val lbv = loose_bnos v;
       in if member (op =) lbv 0 orelse member (op =) lbv 1
          then NONE else SOME (incr_boundvars ~2 v)
       end
   | dest_K_rec _ = NONE;
 
 local
 fun uncover (upd,v) =
   (case (upd, v) of
     (Const (cupd, _), upd' $ dest $ constr $ n $ (Const (@{const_syntax K_statefun}, _) $ v') $ s) =>
       if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name cupd)
       then (case s of (Const (g, _) $ _) =>
                if member (op =) [localsN, globalsN] (Long_Name.base_name g)
                then (n, v')
                else raise Match
              | _ => raise Match)
        else (upd, v)
   | (Const (gupd, _), upd' $ k $ s) =>
       (case dest_K_rec k of
         SOME v' =>
           if Long_Name.base_name gupd = globals_updateN
           then
             (case s of
               Const (gl, _) $ _ =>
                 if Long_Name.base_name gl = globalsN (* assignment *)
                 then (upd',v')
                 else raise Match
             | _ => raise Match)
           else (upd, v)
       | _ => (upd, v))
   | (Const (upd_glob, _), upd' $ v') =>
       if Long_Name.base_name upd_glob = upd_globalsN (* result parameter *)
       then (upd', v') else (upd, v)
   | _ => (upd, v));
 in
 
 fun global_upd_tr' upd k =
   (case dest_K_rec k of
     SOME v => uncover (upd, v)
   | NONE => uncover (upd, k));
 
 end;
 
 
 fun dest_updates (t as (upd as Const (u, _)) $ k $ state) =
       (case dest_K_rec k of
         SOME value =>
           if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u)
           then dest_updates value
           else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN
           then (upd,value)::dest_updates state
           else raise Match
       | NONE => raise Match)
   | dest_updates (t as (upd as Const (u,_))$k) =
       (case dest_K_rec k of
         SOME value =>
           if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u)
           then dest_updates value
           else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN
           then [(upd,value)]
           else if Long_Name.base_name u = globalsN then [] else raise Match
       | NONE => []) (* t could be just (globals $ s) *)
   | dest_updates ((Const (u, _)) $ _ $ _ $ n $ (Const (@{const_syntax K_statefun},_) $ value) $ state) =
       if Long_Name.base_name u = Long_Name.base_name StateFun.updateN
       then (n, value) :: dest_updates state
       else raise Match
   | dest_updates t = [];
 
 (* FIXME: externalize names properly before removing decoration! *)
 fun init_tr' ctxt [Abs (_,_,t)] =
   let
     val upds  =
       case dest_updates t of
         us as [(Const (gupd, _), v)] =>
           if Long_Name.base_name gupd = globals_updateN
           then dest_updates v else us
       | us => us;
 
     val comps =
       map (fn (Const (u, _)) => Symbol.explode (unsuffix (Hoare.deco ^ Record.updateN) u))
         (map fst upds);
     val prfx = maxprefixs (op =) comps;
 
     fun dest_list (Const (@{const_syntax Nil}, _)) = []
       | dest_list (Const (@{const_syntax Cons}, _) $ x $ xs) = x :: dest_list xs
       | dest_list t = [t];
 
     fun mk_set [] = Syntax.const @{const_syntax Set.empty}
       | mk_set (x :: xs) = Syntax.const @{const_syntax insert} $ x $ mk_set xs;
 
     val l = length prfx;
     val _ = if l <= 1 then raise Match else ();
     val comp = mk_list (map (Syntax.const o implode o drop l) comps);
     val vals = map mk_set (transpose (map (dest_list o snd) upds));
     val v = case vals of [v] => v | vs => mk_list vs;
   in
     Syntax.const @{syntax_const "_Init"} $
       Syntax.const (implode (fst (split_last prfx))) $ comp $ v
   end;
 
 
 local
 fun tr' ctxt c (upd,v) =
   let
     val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd;
     val r = quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, v));
     val (l', r') = update_tr' l r;
   in (c $ l' $ r') end;
 
 in
 fun app_assign_tr' c ctxt (Abs (s, _, upd $ v $ Bound 0) :: ts) =
       tr' ctxt c (global_upd_tr' upd v)
   | app_assign_tr' c ctxt ((upd $ v) :: ts) =
       (case upd of
         u $ v => raise Match
       | _ => tr' ctxt c (global_upd_tr' upd v))
   | app_assign_tr' _ _ _ = raise Match;
 end;
 
 val assign_tr' = app_assign_tr' (Syntax.const @{syntax_const "_Assign"});
 val raise_tr' = app_assign_tr' (Syntax.const @{syntax_const "_raise"});
 
 fun split_Let' ((l as Const (@{const_syntax Let'}, _)) $ x $ t) =
       let val (recomb,t') = split_Let' t
       in (fn t => l $ x $ recomb t, t') end
   | split_Let' (Abs (x, T, t)) =
      let val (recomb, t') = split_Let' t
      in if t' = t
         then (I, t') (* Get rid of last abstraction *)
         else (fn t => Abs (x, T, recomb t), t')
      end
   | split_Let' ((s as Const (@{const_syntax case_prod},_)) $ t) =
      let val (recomb, t') = split_Let' t
      in (fn t => s $ recomb t, t') end
   | split_Let' t = (I, t)
 
 fun basic_tr' ctxt [Abs (s, T, t)] =
   let
     val (has_let, t') =
       case t of
         ((t' as (Const (@{const_syntax Let'},_) $ _ $ _)) $ Bound 0) => (true, t')
       | _ => (false, t);
     val (recomb, t'') = split_Let' t';
     val upds = dest_updates t'';
     val _ = if length upds <= 1 andalso not has_let then raise Match else ();
     val ass =
       map (fn (u, v) => app_assign_tr' (Syntax.const @{syntax_const "_BAssign"}) ctxt
             [Abs ("s",dummyT,u$v$Bound 0)]) upds;
     val basics = foldr1 (fn (x, ys) => Syntax.const @{syntax_const "_basics"} $ x $ ys) (rev ass);
   in
     Syntax.const @{syntax_const "_Basic"} $
       quote_tr' ctxt @{syntax_const "_antiquoteCur"} (Abs (s, T, recomb basics))
   end;
 
 fun loc_tr' ctxt [init, bdy, return, c] =
       (let
         val upds =
           (case init of
             Abs (_, _, t as (upd $ v $ s)) => dest_updates t
           | upd $ v => dest_updates (upd $ v $ Bound 0)
           | _ => raise Match);
 
         fun mk_locinit c v =
           Syntax.const @{syntax_const "_locinit"} $
             Syntax.const c $ quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, v));
 
         fun init_or_not c c' v =
           if c = c' then
             Syntax.const @{syntax_const "_locnoinit"} $ Syntax.const (Hoare.remdeco ctxt c')
           else mk_locinit (Hoare.remdeco ctxt c) v;
 
         fun mk_init (Const (c, _), (v as (Const (c', _) $ Bound 0))) =
               init_or_not (unsuffix' Record.updateN c) c' v
           | mk_init (Const (c, _), v) =
               mk_locinit (unsuffix' (Hoare.deco ^ Record.updateN) (Hoare.extern ctxt c)) v
           | mk_init ((f as Const (@{syntax_const "_free"}, _)) $ Free (c, _), v) =
               (case v of
                 Const (lookup, _) $ _ $
                   (Const (@{syntax_const "_free"}, _) $ Free (c', _)) $
                   (Const (locals,_) $ Bound 0) =>
                 if Long_Name.base_name lookup = Long_Name.base_name StateFun.lookupN
                   andalso Long_Name.base_name locals = localsN
                 then init_or_not c c' v
                 else mk_locinit (Hoare.remdeco' c) v
               | _ => mk_locinit (Hoare.remdeco' c) v)
           | mk_init _ = raise Match;
 
         val inits =
           foldr1 (fn (t, u) => Syntax.const @{syntax_const "_locinits"} $ t $ u)
             (map mk_init (rev upds));
       in Syntax.const @{syntax_const "_Loc"} $ inits $ bdy end handle Fail _ => raise Match)
   | loc_tr' _ _ = raise Match;
 
 
 fun actuals_tr' acts =
   (case acts of
     [] => Syntax.const @{syntax_const "_actuals_empty"}
   | xs => Syntax.const @{syntax_const "_actuals"} $
         foldr1 (fn (l, r) => (Syntax.const @{syntax_const "_pars"} $ l $ r)) xs);
 
 
 fun gen_call_tr' ctxt Call CallAss init p return c =
   let
     fun get_init_updates (Abs (s, _, upds)) = dest_updates upds
       | get_init_updates upds = dest_updates upds;
 
     fun get_res_updates (Abs (i, _, Abs (t, _, Const (@{const_syntax Basic}, _) $ Abs (s, _, upds)))) =
           dest_updates upds
       | get_res_updates (Abs (i, _, Abs (t, _, Const (@{const_syntax Basic}, _) $ upds))) =
           dest_updates upds
       | get_res_updates _ = raise Match;
 
       fun init_par_tr' par =
         Syntax.const @{syntax_const "_par"} $ quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, par));
       val init_actuals =
         map (fn (_, value) => init_par_tr' value) (rev (get_init_updates init));
 
       fun tr' c (upd, v) =
         let
           val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd;
           val r =
             quote_tr' ctxt antiquoteCur
               (quote_tr' ctxt antiquoteCur
                 (quote_tr' ctxt antiquoteCur
                   (Abs ("i", dummyT, Abs ("t", dummyT, Abs ("s", dummyT, v))))));
           val (l', _) = update_tr' l r;
         in c $ l' end;
 
       fun ret_par_tr' (upd, v) =
         tr' (Syntax.const @{syntax_const "_par"}) (global_upd_tr' upd v);
 
       val res_updates = rev (get_res_updates c);
       val res_actuals = map ret_par_tr' res_updates;
   in if Config.get ctxt use_call_tr' then
         (case res_actuals of
           [l] => CallAss $ l $ p $ actuals_tr' init_actuals
          | _ => Call $ p $ actuals_tr' (init_actuals @ res_actuals))
      else raise Match
   end;
 
 fun gen_fcall_tr' ctxt init p return result c =
   let
     fun get_init_updates (Abs (s, _, upds)) = dest_updates upds
       | get_init_updates _ = raise Match;
 
     fun init_par_tr' par =
       Syntax.const @{syntax_const "_par"} $ quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, par));
     val init_actuals =
       map (fn (_, value) => init_par_tr' value) (rev (get_init_updates init));
 
     val (v, c') =
       (case c of
         Abs abs => Syntax_Trans.atomic_abs_tr' abs
       | _ => raise Match);
   in
     if Config.get ctxt use_call_tr' then
       Syntax.const @{syntax_const "_FCall"} $ p $ actuals_tr' init_actuals $ v $ c'
     else raise Match
   end;
 
 
 fun pname_tr' ctxt ((f as Const (@{syntax_const "_free"}, _)) $ Free (p, T)) =
       (*f$*) Const (unsuffix' Hoare.proc_deco p, T)
   | pname_tr' ctxt (Free (p, T)) = Const (unsuffix' Hoare.proc_deco p, T)
   | pname_tr' ctxt p =
       let
         (* from HOL strings to ML strings *)
         fun dest_nib c =    (* FIXME authentic syntax *)
           (case raw_explode c of
             ["N", "i", "b", "b", "l", "e", h] =>
               if "0" <= h andalso h <= "9" then ord h - ord "0"
               else if "A" <= h andalso h <= "F" then ord h - ord "A" + 10
               else raise Match
           | _ => raise Match);
 
         fun dest_chr (Const (@{const_syntax Char},_) $ Const (c1, _) $ Const (c2,_)) =
               let val c = Char.chr (dest_nib c1 * 16 + dest_nib c2)
               in if Char.isPrint c then c else raise Match end
           | dest_chr _ = raise Match;
 
         fun dest_string (Const (@{const_syntax Nil}, _)) = []
           | dest_string (Const (@{const_syntax Cons}, _) $ c $ cs) = dest_chr c :: dest_string cs
           | dest_string _ = raise Match;
         in
           (case try dest_string p of
             SOME name => Syntax.const (String.implode name)
           | NONE => antiquote_mult_tr' ctxt (K true) antiquoteCur antiquoteOld p)
         end;
 
 fun call_tr' ctxt [init, p, return, result] =
       gen_call_tr' ctxt
         (Const (@{syntax_const "_Call"}, dummyT))
         (Const (@{syntax_const "_CallAss"}, dummyT)) init (pname_tr' ctxt p) return result
   | call_tr' _ _ = raise Match;
 
 
 fun dyn_call_tr' ctxt [init, p, return, result] =
       let val p' = quote_tr' ctxt antiquoteCur p
       in
         gen_call_tr' ctxt
           (Const (@{syntax_const "_DynCall"}, dummyT))
           (Const (@{syntax_const "_DynCallAss"}, dummyT)) init p' return result
       end
   | dyn_call_tr' _ _ = raise Match;
 
 fun proc_tr' ctxt [p] =
       let
         val p' = pname_tr' ctxt p;
         val pn = fst (dest_procname ctxt "" false p');
         val formals = the (Hoare.get_params pn ctxt) handle Option.Option => raise Match;
         val val_formals = map_filter (fn (Hoare.In, p) => SOME p | _ => NONE) formals;
         val res_formals = map_filter (fn (Hoare.Out, p) => SOME p | _ => NONE) formals;
         fun mkpar n =
           Syntax.const @{syntax_const "_par"} $
             (Syntax.const antiquoteCur $ Syntax.const (Hoare.remdeco ctxt n));
       in
         if not (print_mode_active "NoProc")
         then
           (case res_formals of
             [r] =>
               Syntax.const @{syntax_const "_ProcAss"} $
                 (Syntax.const antiquoteCur $
                   Syntax.const (Hoare.remdeco ctxt r)) $
                 p' $ actuals_tr' (map mkpar val_formals)
           | _ =>
               Syntax.const @{syntax_const "_Proc"} $ p' $
                 actuals_tr' (map mkpar (val_formals @ res_formals)))
          else raise Match
       end
   | proc_tr' _ _ = raise Match;
 
 fun fcall_tr' ctxt [init, p, return, result, c] =
       gen_fcall_tr' ctxt init (pname_tr' ctxt p) return result c
   | fcall_tr' _ _ = raise Match;
 
 
 (* misc. print translations *)
 
 fun assert_tr' ctxt ((t as Abs (_, _, p)) :: ts) =
       let
         fun selector (Const (c, T)) = Hoare.is_state_var c
           | selector (Const (l, _) $ _ $ _) =
               Long_Name.base_name l = Long_Name.base_name StateFun.lookupN
           | selector t = false;
 
         fun fix_state (Const (@{const_syntax HOL.eq},_) $ (Const (@{syntax_const "_free"}, _) $ _)) = true
           | fix_state (Const (@{const_syntax HOL.eq},_) $ (Const (@{syntax_const "_bound"}, _) $ _)) = true
           | fix_state (Const (@{const_syntax HOL.eq},_) $ (Const (@{syntax_const "_var"}, _) $ _)) = true
           | fix_state (Const (@{const_syntax HOL.eq},_) $ Free _) = true
           | fix_state (Const (@{const_syntax HOL.eq},_) $ Bound _) = true
           | fix_state (Const (@{const_syntax HOL.eq},_) $ Var _) = true
           | fix_state _ = false;
       in
         if antiquote_applied_only_to (fn t => selector t orelse fix_state t) p
           andalso not (print_mode_active "NoAssertion")
         then app_quote_mult_tr' ctxt selector (Syntax.const @{syntax_const "_Assert"}) (t :: ts)
         else raise Match
       end
   | assert_tr' _ _ = raise Match
 
 
 fun bexp_tr' name ctxt ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
       app_quote_tr' ctxt (Syntax.const name) (t :: ts)
   | bexp_tr' _ _ _ = raise Match;
 
 
 
 fun new_tr' ctxt
         [Abs (s,_,
           Const (@{const_syntax If}, _) $
           (Const (@{const_syntax Orderings.less_eq},_) $ size $ free) $
           (upd $ new $ (gupd $ Abs (_, _, inits_free_alloc) $ Bound 0)) $
           (upd' $ null $ Bound 0))] =
       let
         fun mk_init (Const (upd, _), Const (@{const_syntax fun_upd},_) $ _ $ _ $ v) =
               let val var = unsuffix' Hoare.deco
                 (unsuffix' Record.updateN (Hoare.extern ctxt upd))
               in Syntax.const @{syntax_const "_newinit"} $ Syntax.const var $ v end
           | mk_init ((f as Const (@{syntax_const "_free"}, _)) $
                 Free (var, T), Const (@{const_syntax fun_upd},_) $ _ $ _ $ v) =
               Syntax.const @{syntax_const "_newinit"} $
                 (f $ Free (Hoare.remdeco' var, T)) $ v;
 
         val inits_free_allocs = dest_updates inits_free_alloc;
 
         val inits = map mk_init (take (length inits_free_allocs - 2) (inits_free_allocs));
         val inits' =
           foldr1 (fn (t1, t2) => Syntax.const @{syntax_const "_newinits"} $ t1 $ t2) (rev inits);
 
         fun tr' (upd, v) =
           let
             val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd;
             val r = quote_tr' ctxt antiquoteCur (Abs (s, dummyT, v));
             val (l', r') = update_tr' l r
           in l' end;
 
         val l = tr' (global_upd_tr' upd' null);
 
       in Syntax.const @{syntax_const "_New"} $ l $ size $ inits' end
   | new_tr' _ _ = raise Match;
 
 fun nnew_tr' ctxt
         [Const (@{const_syntax if_rel},_) $
           (Abs (s, _, Const (@{const_syntax Orderings.less_eq}, _) $ size $ free)) $
           (Abs (_, _, upd $ new $ (gupd $ (Abs (_, _, free_inits_alloc)) $ Bound 0))) $
           (Abs (_, _, (upd' $ null $ Bound 0))) $ _] =
       let
         fun mk_init (Const (upd, _), Const (@{const_syntax fun_upd}, _) $ _ $ _ $ v) =
               let val var = unsuffix' Hoare.deco
                 (unsuffix' Record.updateN (Hoare.extern ctxt upd))
               in Syntax.const @{syntax_const "_newinit"} $ Syntax.const var $ v end
           | mk_init ((f as Const (@{syntax_const "_free"}, _)) $ Free (var, T),
                 Const (@{const_syntax fun_upd}, _) $_ $ _ $ v) =
               Syntax.const @{syntax_const "_newinit"} $
                 (f $ Free (Hoare.remdeco' var, T)) $ v;
 
         val free_inits_allocs = dest_updates free_inits_alloc;
 
         val inits = map mk_init (take (length free_inits_allocs - 2) (tl free_inits_allocs));
         val inits' =
           foldr1 (fn (t1, t2) => Syntax.const @{syntax_const "_newinits"} $ t1 $ t2) (rev inits);
 
         fun tr' (upd, v) =
           let
             val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd;
             val r = quote_tr' ctxt antiquoteCur (Abs (s, dummyT, v));
             val (l', r') = update_tr' l r;
           in l' end;
 
         val l = tr' (global_upd_tr' upd' null);
 
       in Syntax.const @{syntax_const "_NNew"} $ l $ size $ inits' end
   | nnew_tr' _ _ = raise Match;
 
 
 fun switch_tr' ctxt [v, vs] =
   let
     fun case_tr' (Const (@{const_syntax Pair}, _) $ V $ c) =
           Syntax.const @{syntax_const "_switchcase"} $ V $ c
       | case_tr' _ = raise Match;
 
     fun dest_list (Const (@{const_syntax Nil}, _)) = []
       | dest_list (Const (@{const_syntax Cons}, _) $ x $ xs) = x :: dest_list xs
       | dest_list t = raise Match;
 
     fun ltr' [] = raise Match
       | ltr' [Vc] = Syntax.const @{syntax_const "_switchcasesSingle"} $ case_tr' Vc
       | ltr' (Vc :: xs) = Syntax.const @{syntax_const "_switchcasesCons"} $ case_tr' Vc $ ltr' xs;
 
    in app_quote_tr' ctxt (Syntax.const @{syntax_const "_Switch"}) (v :: [ltr' (dest_list vs)]) end;
 
 fun bind_tr' ctxt [e, Abs abs] =
       let
         val (v, c) = Syntax_Trans.atomic_abs_tr' abs;
         val e' =
           case e of
             Abs a => e
           | t as Const _ => Abs ("s", dummyT, t $ Bound 0)
           | _ => raise Match;
       in app_quote_tr' ctxt (Syntax.const @{syntax_const "_Bind"}) [e', v, c] end
   | bind_tr' _ _ = raise Match;
 
 
 local
   fun dest_list (Const (@{const_syntax Nil}, _)) = []
     | dest_list (Const (@{const_syntax Cons}, _) $ x $ xs) = x :: dest_list xs
     | dest_list _ = raise Match;
 
   fun guard_tr' fg =
     let val (flag, g) = HOLogic.dest_prod fg
     in
       if flag aconv @{term True} then Syntax.const @{syntax_const "_guarantee"} $ g
       else if flag aconv @{term False} then g
       else fg
     end handle TERM _ => fg;
 
   fun guards_lst_tr' [fg] = guard_tr' fg
     | guards_lst_tr' (t :: ts) =
         Syntax.const @{syntax_const "_grds"} $ guard_tr' t $ guards_lst_tr' ts
     | guards_lst_tr' [] = raise Match;
 
   fun cond_guards_lst_tr' ctxt ts =
     if Config.get ctxt hide_guards then Syntax.const @{syntax_const "_hidden_grds"}
     else guards_lst_tr' ts;
 in
   fun guards_tr' ctxt [gs, c] =
         Syntax.const @{syntax_const "_guards"} $ cond_guards_lst_tr' ctxt (dest_list gs) $ c
     | guards_tr' _ _ = raise Match;
 
   fun whileAnnoG_tr' ctxt [gs, cond as (Const (@{const_syntax Collect}, _) $ b), I, V, c] =
         let
           val b' =
             (case assert_tr' ctxt [b] of
               Const (@{syntax_const "_Assert"}, _) $ b' => b'
             | _ => cond) handle Match => cond;
 
         in
           Syntax.const @{syntax_const "_While_guard_inv_var"} $
             cond_guards_lst_tr' ctxt (dest_list gs) $ b' $ I $ V $
             (Syntax.const @{syntax_const "_DoPre"} $ c)
         end
     | whileAnnoG_tr' _ _ = raise Match;
 
   fun whileAnnoGFix_tr' ctxt [gs, cond as (Const (@{const_syntax Collect}, _) $ b), I, V, c] =
     let
       val b' =
         (case assert_tr' ctxt [b] of
           Const (@{syntax_const "_Assert"}, _) $ b' => b'
         | _ => cond) handle Match => cond;
     in
       (case maps strip_abs_vars [I, V, c] of
         [] => raise Match
       | ((x, T) :: xs) =>
           let
             val (x', I') = Syntax_Trans.atomic_abs_tr' (x, T, strip_abs_body I);
             val (_ , V') = Syntax_Trans.atomic_abs_tr' (x, T, strip_abs_body V);
             val (_ , c') = Syntax_Trans.atomic_abs_tr' (x, T, strip_abs_body c);
           in
             Syntax.const @{syntax_const "_WhileFix_guard_inv_var"} $
               cond_guards_lst_tr' ctxt (dest_list gs) $ b' $ x' $ I' $ V' $
               (Syntax.const @{syntax_const "_DoPre"} $ c')
           end)
     end;
 end
 
 
 end;
diff --git a/thys/Timed_Automata/Floyd_Warshall.thy b/thys/Timed_Automata/Floyd_Warshall.thy
--- a/thys/Timed_Automata/Floyd_Warshall.thy
+++ b/thys/Timed_Automata/Floyd_Warshall.thy
@@ -1,1736 +1,1726 @@
 theory Floyd_Warshall
   imports Main
 begin
 
 chapter \<open>Floyd-Warshall Algorithm for the All-Pairs Shortest Paths Problem\<close>
 
 subsubsection \<open>Auxiliary\<close>
 
 lemma distinct_list_single_elem_decomp: "{xs. set xs \<subseteq> {0} \<and> distinct xs} = {[], [0]}"
 proof (standard, goal_cases)
   case 1
   { fix xs :: "'a list" assume xs: "xs \<in> {xs. set xs \<subseteq> {0} \<and> distinct xs}"
     have "xs \<in> {[], [0]}"
     proof (cases xs)
       case (Cons y ys)
       hence y: "y = 0" using xs by auto
       with Cons xs have "ys = []" by (cases ys, auto)
       thus ?thesis using y Cons by simp
     qed simp
   }
   thus ?case by blast
 qed simp
 
 
 section \<open>Cycles in Lists\<close>
 
 abbreviation "cnt x xs \<equiv> length (filter (\<lambda>y. x = y) xs)"
 
 fun remove_cycles :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "remove_cycles [] _ acc = rev acc" |
   "remove_cycles (x#xs) y acc =
     (if x = y then remove_cycles xs y [x] else remove_cycles xs y (x#acc))"
 
 lemma cnt_rev: "cnt x (rev xs) = cnt x xs" by (metis length_rev rev_filter)
 
 value "as @ [x] @ bs @ [x] @ cs @ [x] @ ds"
 
 lemma remove_cycles_removes: "cnt x (remove_cycles xs x ys) \<le> max 1 (cnt x ys)"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case
   by (simp, cases "x \<in> set ys", (auto simp: cnt_rev[of x ys]))
 next
   case (Cons y xs)
   thus ?case
   proof (cases "x = y")
     case True
     thus ?thesis using Cons[of "[y]"] True by auto
   next
     case False
     thus ?thesis using Cons[of "y # ys"] by auto
   qed
 qed
 
 lemma remove_cycles_id: "x \<notin> set xs \<Longrightarrow> remove_cycles xs x ys = rev ys @ xs"
 by (induction xs arbitrary: ys) auto
 
 lemma remove_cycles_cnt_id:
   "x \<noteq> y \<Longrightarrow> cnt y (remove_cycles xs x ys) \<le> cnt y ys + cnt y xs"
 proof (induction xs arbitrary: ys x)
   case Nil thus ?case by (simp add: cnt_rev)
 next
   case (Cons z xs)
   thus ?case
   proof (cases "x = z")
     case True thus ?thesis using Cons.IH[of z "[z]"] Cons.prems by auto
   next
     case False
     thus ?thesis using Cons.IH[of x "z # ys"] Cons.prems False by auto
   qed
 qed
 
 lemma remove_cycles_ends_cycle: "remove_cycles xs x ys \<noteq> rev ys @ xs \<Longrightarrow> x \<in> set xs"
 using remove_cycles_id by fastforce
 
 lemma remove_cycles_begins_with: "x \<in> set xs \<Longrightarrow> \<exists> zs. remove_cycles xs x ys = x # zs \<and> x \<notin> set zs"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons y xs)
   thus ?case
   proof (cases "x = y")
     case True thus ?thesis
     proof (cases "x \<in> set xs", goal_cases)
       case 1 with Cons show ?case by auto
     next
       case 2 with remove_cycles_id[of x xs "[y]"] show ?case by auto
     qed
   next
     case False
     with Cons show ?thesis by auto
   qed
 qed
 
 lemma remove_cycles_self:
   "x \<in> set xs \<Longrightarrow> remove_cycles (remove_cycles xs x ys) x zs = remove_cycles xs x ys"
 proof -
   assume x:"x \<in> set xs"
   then obtain ws where ws: "remove_cycles xs x ys = x # ws" "x \<notin> set ws"
   using remove_cycles_begins_with[OF x, of ys] by blast
   from remove_cycles_id[OF this(2)] have "remove_cycles ws x [x] = x # ws" by auto
   with ws(1) show "remove_cycles (remove_cycles xs x ys) x zs = remove_cycles xs x ys" by simp
 qed
 
 lemma remove_cycles_one: "remove_cycles (as @ x # xs) x ys = remove_cycles (x#xs) x ys"
 by (induction as arbitrary: ys) auto
 
 lemma remove_cycles_cycles:
   "x \<in> set xs \<Longrightarrow> \<exists> xxs as. as @ concat (map (\<lambda> xs. x # xs) xxs) @ remove_cycles xs x ys = xs \<and> x \<notin> set as"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons y xs)
   thus ?case
   proof (cases "x = y")
     case True thus ?thesis
     proof (cases "x \<in> set xs", goal_cases)
       case 1
       then obtain as xxs where "as @ concat (map (\<lambda>xs. y#xs) xxs) @ remove_cycles xs y [y] = xs"
       using Cons.IH[of "[y]"] by auto
       hence "[] @ concat (map (\<lambda>xs. x#xs) (as#xxs)) @ remove_cycles (y#xs) x ys = y # xs"
       by (simp add: \<open>x = y\<close>)
       thus ?thesis by fastforce
     next
       case 2
       hence "remove_cycles (y # xs) x ys = y # xs" using remove_cycles_id[of x xs "[y]"] by auto
       hence "[] @ concat (map (\<lambda>xs. x # xs) []) @ remove_cycles (y#xs) x ys = y # xs" by auto
       thus ?thesis by fastforce
     qed
   next
     case False
     then obtain as xxs where as:
       "as @ concat (map (\<lambda>xs. x # xs) xxs) @ remove_cycles xs x (y#ys) = xs" "x \<notin> set as"
     using Cons.IH[of "y # ys"] Cons.prems by auto
     hence "(y # as) @ concat (map (\<lambda>xs. x # xs) xxs) @ remove_cycles (y#xs) x ys = y # xs"
     using \<open>x \<noteq> y\<close> by auto
     thus ?thesis using as(2) \<open>x \<noteq> y\<close> by fastforce
   qed
 qed
 
 fun start_remove :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "start_remove [] _ acc = rev acc" |
   "start_remove (x#xs) y acc =
     (if x = y then rev acc @ remove_cycles xs y [y] else start_remove xs y (x # acc))"
 
 lemma start_remove_decomp:
   "x \<in> set xs \<Longrightarrow> \<exists> as bs. xs = as @ x # bs \<and> start_remove xs x ys = rev ys @ as @ remove_cycles bs x [x]"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons y xs)
   thus ?case
   proof (auto, goal_cases)
     case 1
     from 1(1)[of "y # ys"]
     obtain as bs where 
       "xs = as @ x # bs" "start_remove xs x (y # ys) = rev (y # ys) @ as @ remove_cycles bs x [x]"
     by blast
     hence "y # xs = (y # as) @ x # bs"
           "start_remove xs x (y # ys) = rev ys @ (y # as) @ remove_cycles bs x [x]" by simp+
     thus ?case by blast
   qed
 qed
 
 lemma start_remove_removes: "cnt x (start_remove xs x ys) \<le> Suc (cnt x ys)"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case using cnt_rev[of x ys] by auto
 next
   case (Cons y xs)
   thus ?case
   proof (cases "x = y")
     case True
     thus ?thesis using remove_cycles_removes[of y xs "[y]"] cnt_rev[of y ys] by auto
   next
     case False
     thus ?thesis using Cons[of "y # ys"] by auto
   qed
 qed
 
 lemma start_remove_id[simp]: "x \<notin> set xs \<Longrightarrow> start_remove xs x ys = rev ys @ xs"
 by (induction xs arbitrary: ys) auto
 
 lemma start_remove_cnt_id:
   "x \<noteq> y \<Longrightarrow> cnt y (start_remove xs x ys) \<le> cnt y ys + cnt y xs"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by (simp add: cnt_rev)
 next
   case (Cons z xs)
   thus ?case
   proof (cases "x = z", goal_cases)
     case 1 thus ?case using remove_cycles_cnt_id[of x y xs "[x]"] by (simp add: cnt_rev)
   next
     case 2 from this(1)[of "(z # ys)"] this(2,3) show ?case by auto
   qed
 qed
 
 fun remove_all_cycles :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "remove_all_cycles [] xs = xs" |
   "remove_all_cycles (x # xs) ys = remove_all_cycles xs (start_remove ys x [])"
 
 lemma cnt_remove_all_mono:"cnt y (remove_all_cycles xs ys) \<le> max 1 (cnt y ys)"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons x xs)
   thus ?case
   proof (cases "x = y")
     case True thus ?thesis using start_remove_removes[of y ys "[]"] Cons[of "start_remove ys y []"]
     by auto
   next
     case False
     hence "cnt y (start_remove ys x []) \<le> cnt y ys"
     using start_remove_cnt_id[of x y ys "[]"] by auto
     thus ?thesis using Cons[of "start_remove ys x []"] by auto
   qed
 qed
 
 
 lemma cnt_remove_all_cycles: "x \<in> set xs \<Longrightarrow> cnt x (remove_all_cycles xs ys) \<le> 1"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons y xs)
   thus ?case
   using start_remove_removes[of x ys "[]"] cnt_remove_all_mono[of y xs "start_remove ys y []"]
   by auto
 qed
 
 lemma cnt_mono:
   "cnt a (b # xs) \<le> cnt a (b # c # xs)"
 by (induction xs) auto
   
 lemma cnt_distinct_intro: "\<forall> x \<in> set xs. cnt x xs \<le> 1 \<Longrightarrow> distinct xs"
 proof (induction xs)
   case Nil thus ?case by auto
 next
   case (Cons x xs)
   from this(2) have "\<forall> x \<in> set xs. cnt x xs \<le> 1"
   by (metis filter.simps(2) impossible_Cons linorder_class.linear list.set_intros(2)
       preorder_class.order_trans)
   with Cons.IH have "distinct xs" by auto
   moreover have "x \<notin> set xs" using Cons.prems
   proof (induction xs)
     case Nil then show ?case by auto
   next
     case (Cons a xs)
     from this(2) have "\<forall>xa\<in>set (x # xs). cnt xa (x # a # xs) \<le> 1"
     by auto
     then have *: "\<forall>xa\<in>set (x # xs). cnt xa (x # xs) \<le> 1"
     proof (safe, goal_cases)
       case (1 b)
       then have "cnt b (x # a # xs) \<le> 1" by auto
       with cnt_mono[of b x xs a] show ?case by fastforce
     qed
     with Cons(1) have "x \<notin> set xs" by auto
     moreover have "x \<noteq> a"
     by (metis (full_types) Cons.prems One_nat_def * empty_iff filter.simps(2) impossible_Cons
                            le_0_eq le_Suc_eq length_0_conv list.set(1) list.set_intros(1)) 
     ultimately show ?case by auto
   qed
   ultimately show ?case by auto
 qed
 
 lemma remove_cycles_subs:
   "set (remove_cycles xs x ys) \<subseteq> set xs \<union> set ys"
 by (induction xs arbitrary: ys; auto; fastforce)
 
 lemma start_remove_subs:
   "set (start_remove xs x ys) \<subseteq> set xs \<union> set ys"
 using remove_cycles_subs by (induction xs arbitrary: ys; auto; fastforce)
 
 lemma remove_all_cycles_subs:
   "set (remove_all_cycles xs ys) \<subseteq> set ys"
 using start_remove_subs by (induction xs arbitrary: ys, auto) (fastforce+)
 
 lemma remove_all_cycles_distinct: "set ys \<subseteq> set xs \<Longrightarrow> distinct (remove_all_cycles xs ys)"
 proof -
   assume "set ys \<subseteq> set xs"
   hence "\<forall> x \<in> set ys. cnt x (remove_all_cycles xs ys) \<le> 1" using cnt_remove_all_cycles by fastforce
   hence "\<forall> x \<in> set (remove_all_cycles xs ys). cnt x (remove_all_cycles xs ys) \<le> 1"
   using remove_all_cycles_subs by fastforce
   thus "distinct (remove_all_cycles xs ys)" using cnt_distinct_intro by auto
 qed
 
 lemma distinct_remove_cycles_inv: "distinct (xs @ ys) \<Longrightarrow> distinct (remove_cycles xs x ys)"
 proof (induction xs arbitrary: ys)
   case Nil thus ?case by auto
 next
   case (Cons y xs)
   thus ?case by auto
 qed
 
 definition "remove_all x xs = (if x \<in> set xs then tl (remove_cycles xs x []) else xs)"
 
 definition "remove_all_rev x xs = (if x \<in> set xs then rev (tl (remove_cycles (rev xs) x [])) else xs)"
 
 lemma remove_all_distinct:
   "distinct xs \<Longrightarrow> distinct (x # remove_all x xs)"
 proof (cases "x \<in> set xs", goal_cases)
   case 1
   from remove_cycles_begins_with[OF 1(2), of "[]"] obtain zs
   where "remove_cycles xs x [] = x # zs" "x \<notin> set zs" by auto
   thus ?thesis using 1(1) distinct_remove_cycles_inv[of "xs" "[]" x] by (simp add: remove_all_def)
 next
   case 2 thus ?thesis by (simp add: remove_all_def)
 qed
 
 lemma remove_all_removes:
   "x \<notin> set (remove_all x xs)"
 by (metis list.sel(3) remove_all_def remove_cycles_begins_with)
 
 lemma remove_all_subs:
   "set (remove_all x xs) \<subseteq> set xs"
 using remove_cycles_subs remove_all_def
 by (metis (no_types, lifting) append_Nil2 list.sel(2) list.set_sel(2) set_append subsetCE subsetI)
 
 lemma remove_all_rev_distinct: "distinct xs \<Longrightarrow> distinct (x # remove_all_rev x xs)"
 proof (cases "x \<in> set xs", goal_cases)
   case 1
   then have "x \<in> set (rev xs)" by auto
   from remove_cycles_begins_with[OF this, of "[]"] obtain zs
   where "remove_cycles (rev xs) x [] = x # zs" "x \<notin> set zs" by auto
   thus ?thesis using 1(1) distinct_remove_cycles_inv[of "rev xs" "[]" x] by (simp add: remove_all_rev_def)
 next
   case 2 thus ?thesis by (simp add: remove_all_rev_def)
 qed
 
 lemma remove_all_rev_removes: "x \<notin> set (remove_all_rev x xs)"
 by (metis remove_all_def remove_all_removes remove_all_rev_def set_rev)
 
 lemma remove_all_rev_subs: "set (remove_all_rev x xs) \<subseteq> set xs"
 by (metis remove_all_def remove_all_subs set_rev remove_all_rev_def)
 
 abbreviation "rem_cycles i j xs \<equiv> remove_all i (remove_all_rev j (remove_all_cycles xs xs))"
 
 lemma rem_cycles_distinct': "i \<noteq> j \<Longrightarrow> distinct (i # j # rem_cycles i j xs)"
 proof -
   assume "i \<noteq> j"
   have "distinct (remove_all_cycles xs xs)" by (simp add: remove_all_cycles_distinct)
   from remove_all_rev_distinct[OF this] have
     "distinct (remove_all_rev j (remove_all_cycles xs xs))"
   by simp
   from remove_all_distinct[OF this] have "distinct (i # rem_cycles i j xs)" by simp
   moreover have
     "j \<notin> set (rem_cycles i j xs)"
   using remove_all_subs remove_all_rev_removes remove_all_removes by fastforce
   ultimately show ?thesis by (simp add: \<open>i \<noteq> j\<close>)
 qed
 
 lemma rem_cycles_removes_last: "j \<notin> set (rem_cycles i j xs)"
 by (meson remove_all_rev_removes remove_all_subs rev_subsetD)
 
 lemma rem_cycles_distinct: "distinct (rem_cycles i j xs)"
 by (meson distinct.simps(2) order_refl remove_all_cycles_distinct
           remove_all_distinct remove_all_rev_distinct) 
 
 lemma rem_cycles_subs: "set (rem_cycles i j xs) \<subseteq> set xs"
 by (meson order_trans remove_all_cycles_subs remove_all_subs remove_all_rev_subs)
 
 section \<open>Definition of the Algorithm\<close>
 
 text \<open>
   We formalize the Floyd-Warshall algorithm on a linearly ordered abelian semigroup.
   However, we would not need an \<open>abelian\<close> monoid if we had the right type class.
 \<close>
 
 class linordered_ab_monoid_add = linordered_ab_semigroup_add +
   fixes neutral :: 'a ("\<one>")
     assumes neutl[simp]: "\<one> + x = x"
     assumes neutr[simp]: "x + \<one> = x"
 begin
 
 lemmas assoc = add.assoc
 
 type_synonym 'c mat = "nat \<Rightarrow> nat \<Rightarrow> 'c"
 
 definition (in -) upd :: "'c mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'c \<Rightarrow> 'c mat"
 where
   "upd m x y v = m (x := (m x) (y := v))"
 
 definition fw_upd :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat" where
   "fw_upd m k i j \<equiv> upd m i j (min (m i j) (m i k + m k j))"
 
 lemma fw_upd_mono:
   "fw_upd m k i j i' j' \<le> m i' j'" 
 by (cases "i = i'", cases "j = j'") (auto simp: fw_upd_def upd_def)
 
 fun fw :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mat" where
   "fw m n 0       0       0        = fw_upd m 0 0 0" |
   "fw m n (Suc k) 0       0        = fw_upd (fw m n k n n) (Suc k) 0 0" |
   "fw m n k       (Suc i) 0        = fw_upd (fw m n k i n) k (Suc i) 0" |
   "fw m n k       i       (Suc j)  = fw_upd (fw m n k i j) k i (Suc j)"
 
 lemma fw_invariant_aux_1:
   "j'' \<le> j \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> fw m n k i j i' j' \<le> fw m n k i j'' i' j'"
 proof (induction j)
   case 0 thus ?case by simp
 next
   case (Suc j) thus ?case
   proof (cases "j'' = Suc j")
     case True thus ?thesis by simp
   next
     case False
     have "fw_upd (fw m n k i j) k i (Suc j) i' j' \<le> fw m n k i j i' j'" by (simp add: fw_upd_mono)
     thus ?thesis using Suc False by simp
   qed
 qed
 
 lemma fw_invariant_aux_2:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> i'' \<le> i \<Longrightarrow> j'' \<le> j
    \<Longrightarrow> fw m n k i j i' j' \<le> fw m n k i'' j'' i' j'"
 proof (induction i)
   case 0 thus ?case using fw_invariant_aux_1 by auto
 next
   case (Suc i) thus ?case
   proof (cases "i'' = Suc i")
     case True thus ?thesis using Suc fw_invariant_aux_1 by simp
   next
     case False
     have "fw m n k (Suc i) j i' j' \<le> fw m n k (Suc i) 0 i' j'"
     using fw_invariant_aux_1[of 0 j "Suc i" n k] Suc(2-) by simp
     also have "\<dots> \<le> fw m n k i n i' j'" by (simp add: fw_upd_mono)
     also have "\<dots> \<le> fw m n k i j i' j'" using fw_invariant_aux_1[of j n i n k] False Suc by simp
     also have "\<dots> \<le> fw m n k i'' j'' i' j'" using Suc False by simp
     finally show ?thesis by simp
   qed
 qed
 
 lemma fw_invariant:
   "k' \<le> k \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> j'' \<le> j \<Longrightarrow> i'' \<le> i
    \<Longrightarrow> fw m n k i j i' j' \<le> fw m n k' i'' j'' i' j'"
 proof (induction k)
   case 0 thus ?case using fw_invariant_aux_2 by auto
 next
   case (Suc k) thus ?case
   proof (cases "k' = Suc k")
     case True thus ?thesis using Suc fw_invariant_aux_2 by simp
   next
     case False
     have "fw m n (Suc k) i j i' j' \<le> fw m n (Suc k) 0 0 i' j'"
     using fw_invariant_aux_2[of i n j "Suc k" 0 0] Suc(2-) by simp
     also have "\<dots> \<le> fw m n k n n i' j'" by (simp add: fw_upd_mono)
     also have "\<dots> \<le> fw m n k i j i' j'" using fw_invariant_aux_2[of n n n k] False Suc by simp
     also have "\<dots> \<le> fw m n k' i'' j'' i' j'" using Suc False by simp
     finally show ?thesis by simp
   qed
 qed
 
 lemma single_row_inv:
   "j' < j \<Longrightarrow> j \<le> n \<Longrightarrow> i' \<le> n \<Longrightarrow> fw m n k i' j i' j' = fw m n k i' j' i' j'"
 proof (induction j)
   case 0 thus ?case by simp
 next
   case (Suc j) thus ?case by (cases "j' = j") (simp add: fw_upd_def upd_def)+
 qed
 
 lemma single_iteration_inv':
   "i' < i \<Longrightarrow> j' \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> i \<le> n \<Longrightarrow> fw m n k i j i' j' = fw m n k i' j' i' j'"
 proof (induction i arbitrary: j)
   case 0 thus ?case by simp
 next
   case (Suc i) thus ?case
   proof (induction j)
     case 0 thus ?case
     proof (cases "i = i'", goal_cases)
       case 2 thus ?case by (simp add: fw_upd_def upd_def)
     next
       case 1 thus ?case using single_row_inv[of j' n n i' m k] 
       by (cases "j' = n") (fastforce simp add: fw_upd_def upd_def)+
     qed
   next
     case (Suc j) thus ?case by (simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma single_iteration_inv:
   "i' \<le> i \<Longrightarrow> j' \<le> j \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n\<Longrightarrow> fw m n k i j i' j' = fw m n k i' j' i' j'"
 proof (induction i arbitrary: j)
   case 0 thus ?case
   proof (induction j)
     case 0 thus ?case by simp
   next
     case (Suc j) thus ?case using 0 by (cases "j' = Suc j") (simp add: fw_upd_def upd_def)+
   qed
 next
   case (Suc i) thus ?case
   proof (induction j)
     case 0 thus ?case by (cases "i' = Suc i") (simp add: fw_upd_def upd_def)+
   next
     case (Suc j) thus ?case
     proof (cases "i' = Suc i", goal_cases)
       case 1 thus ?case
       proof (cases "j' = Suc j", goal_cases)
         case 1 thus ?case by simp
       next
         case 2 thus ?case by (simp add: fw_upd_def upd_def)
       qed
     next
       case 2 thus ?case
       proof (cases "j' = Suc j", goal_cases)
         case 1 thus ?case using single_iteration_inv'[of i' "Suc i" j' n "Suc j" m k] by simp
       next
         case 2 thus ?case by (simp add: fw_upd_def upd_def)
       qed
     qed
   qed
 qed
 
 lemma fw_innermost_id:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' \<le> n \<Longrightarrow> i' < i \<Longrightarrow> fw m n 0 i' j' i j = m i j"
 proof (induction i' arbitrary: j')
   case 0 thus ?case
   proof (induction j')
     case 0 thus ?case by (simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp: fw_upd_def upd_def)
   qed
 next
   case (Suc i') thus ?case
   proof (induction j')
     case 0 thus ?case by (auto simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma fw_middle_id:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' < j \<Longrightarrow> i' \<le> i \<Longrightarrow> fw m n 0 i' j' i j = m i j"
 proof (induction i' arbitrary: j')
   case 0 thus ?case
   proof (induction j')
     case 0 thus ?case by (simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp: fw_upd_def upd_def)
   qed
 next
   case (Suc i') thus ?case
   proof (induction j')
     case 0 thus ?case using fw_innermost_id by (auto simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma fw_outermost_mono:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> fw m n 0 i j i j \<le> m i j"
 proof (cases j)
   case 0
   assume "i \<le> n"
   thus ?thesis
   proof (cases i)
     case 0 thus ?thesis using \<open>j = 0\<close> by (simp add: fw_upd_def upd_def)
   next
     case (Suc i')
     hence "fw m n 0 i' n (Suc i') 0 = m (Suc i') 0" using fw_innermost_id[of "Suc i'" n 0 n i' m]
     using \<open>i \<le> n\<close> by simp
     thus ?thesis using \<open>j = 0\<close> Suc by (simp add: fw_upd_def upd_def)
   qed
 next
   case (Suc j')
   assume "i \<le> n" "j \<le> n"
   hence "fw m n 0 i j' i (Suc j') = m i (Suc j')"
   using fw_middle_id[of i n "Suc j'" j' i m] Suc by simp
   thus ?thesis using Suc by (simp add: fw_upd_def upd_def)
 qed
 
 lemma Suc_innermost_id1:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' \<le> n \<Longrightarrow> i' < i \<Longrightarrow> fw m n (Suc k) i' j' i j = fw m n k i j i j"
 proof (induction i' arbitrary: j')
   case 0 thus ?case
   proof (induction j')
     case 0
     hence "fw m n k n n i j = fw m n k i j i j" using single_iteration_inv[of i n j n n m k] by simp
     thus ?case using 0 by (simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp: fw_upd_def upd_def)
   qed
 next
   case (Suc i') thus ?case
   proof (induction j')
     case 0 thus ?case by (auto simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma Suc_innermost_id2:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' < j \<Longrightarrow> i' \<le> i \<Longrightarrow> fw m n (Suc k) i' j' i j = fw m n k i j i j"
 proof (induction i' arbitrary: j')
   case 0
   hence "fw m n k n n i j = fw m n k i j i j" using single_iteration_inv[of i n j n n m k] by simp
   with 0 show ?case
   proof (induction j')
     case 0
     thus ?case by (auto simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp: fw_upd_def upd_def)
   qed
 next
   case (Suc i') thus ?case
   proof (induction j')
     case 0 thus ?case using Suc_innermost_id1 by (auto simp add: fw_upd_def upd_def)
   next
     case (Suc j') thus ?case by (auto simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma Suc_innermost_id1':
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' \<le> n \<Longrightarrow> i' < i \<Longrightarrow> fw m n (Suc k) i' j' i j = fw m n k n n i j"
 proof goal_cases
   case 1
   hence "fw m n (Suc k) i' j' i j = fw m n k i j i j" using Suc_innermost_id1 by simp
   thus ?thesis using 1 single_iteration_inv[of i n] by simp
 qed
 
 lemma Suc_innermost_id2':
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> j' < j \<Longrightarrow> i' \<le> i \<Longrightarrow> fw m n (Suc k) i' j' i j = fw m n k n n i j"
 proof goal_cases
   case 1
   hence "fw m n (Suc k) i' j' i j = fw m n k i j i j" using Suc_innermost_id2 by simp
   thus ?thesis using 1 single_iteration_inv[of i n] by simp
 qed
 
 lemma Suc_innermost_mono:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> fw m n (Suc k) i j i j \<le> fw m n k i j i j"
 proof (cases j)
   case 0
   assume "i \<le> n"
   thus ?thesis
   proof (cases i)
     case 0 thus ?thesis using \<open>j = 0\<close> single_iteration_inv[of 0 n 0 n n m k]
     by (simp add: fw_upd_def upd_def)
   next
     case (Suc i')
     thus ?thesis using Suc_innermost_id1 \<open>i \<le> n\<close> \<open>j = 0\<close>
     by (auto simp: fw_upd_def upd_def local.min.coboundedI1)
   qed
 next
   case (Suc j')
   assume "i \<le> n" "j \<le> n"
   thus ?thesis using Suc Suc_innermost_id2 by (auto simp: fw_upd_def upd_def local.min.coboundedI1)
 qed
 
 lemma fw_mono':
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> fw m n k i j i j \<le> m i j"
 proof (induction k)
   case 0 thus ?case using fw_outermost_mono by simp
 next
   case (Suc k) thus ?case using Suc_innermost_mono[OF Suc.prems, of m k] by simp
 qed
 
 lemma fw_mono:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> i' \<le> n \<Longrightarrow> j' \<le> n \<Longrightarrow> fw m n k i j i' j' \<le> m i' j'"
 proof (cases k)
   case 0
   assume 0: "i \<le> n" "j \<le> n" "i' \<le> n" "j' \<le> n" "k = 0"
   thus ?thesis
   proof (cases "i' \<le> i")
     case False thus ?thesis using 0 fw_innermost_id by simp
   next
     case True thus ?thesis
     proof (cases "j' \<le> j")
       case True
       have "fw m n 0 i j i' j' \<le> fw m n 0 i' j' i' j'" using fw_invariant True \<open>i' \<le> i\<close> 0 by simp
       also have "fw m n 0 i' j' i' j' \<le> m i' j'" using 0 fw_outermost_mono by blast
       finally show ?thesis by (simp add: \<open>k = 0\<close>)
     next
       case False thus ?thesis
       proof (cases "i = i'", goal_cases)
         case 1 then show ?thesis using fw_middle_id[of i' n j' j i' m] 0 by simp
       next
         case 2
         then show ?case
         using single_iteration_inv'[of i' i j' n j m 0] \<open>i' \<le> i\<close> fw_middle_id[of i' n j' j i' m]
               fw_outermost_mono[of i' n j' m] 0
         by simp
       qed
     qed
   qed
 next
   case (Suc k)
   assume prems: "i \<le> n" "j \<le> n" "i' \<le> n" "j' \<le> n"
   thus ?thesis
   proof (cases "i' \<le> i \<and> j' \<le> j")
     case True
     hence "fw m n (Suc k) i j i' j' = fw m n (Suc k) i' j' i' j'"
     using prems single_iteration_inv by blast
     thus ?thesis using Suc prems fw_mono' by auto
   next
     case False thus ?thesis
     proof auto
       assume "\<not> i' \<le> i"
       thus ?thesis using Suc prems fw_mono' Suc_innermost_id1 by auto
     next
       assume "\<not> j' \<le> j"
       hence "j < j'" by simp
       show ?thesis
       proof (cases "i \<le> i'")
         case True
         thus ?thesis using Suc prems Suc_innermost_id2 \<open>j < j'\<close> fw_mono' by auto
       next
         case False
         thus ?thesis using single_iteration_inv' Suc prems fw_mono' by auto
       qed
     qed
   qed
 qed
 
 lemma add_mono_neutr:
   assumes "\<one> \<le> b"
   shows "a \<le> a + b"
 using neutr add_mono assms by force
 
 lemma add_mono_neutl:
   assumes "\<one> \<le> b"
   shows "a \<le> b + a"
 using neutr add_mono assms by force
 
 lemma fw_step_0:
   "m 0 0 \<ge> \<one> \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> fw m n 0 i j i j = min (m i j) (m i 0 + m 0 j)"
 proof (induction i)
   case 0 thus ?case
   proof (cases j)
     case 0 thus ?thesis by (simp add: fw_upd_def upd_def)
   next
     case (Suc j)
     hence "fw m n 0 0 j 0 (Suc j) = m 0 (Suc j)" using 0 fw_middle_id[of 0 n "Suc j" j 0 m] by fast
     moreover have "fw m n 0 0 j 0 0 = m 0 0" using single_iteration_inv[of 0 0 0 j n m 0] Suc 0
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutl)
     ultimately show ?thesis using Suc by (simp add: fw_upd_def upd_def)
   qed
 next
   case (Suc i)
   note A = this
   show ?case
   proof (cases j)
     case 0
     have "fw m n 0 i n (Suc i) 0 = m (Suc i) 0" using fw_innermost_id[of "Suc i" n 0 n i m] Suc by simp
     moreover have "fw m n 0 i n 0 0 = m 0 0" using Suc single_iteration_inv[of 0 i 0 n n m 0]
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutl)
     ultimately show ?thesis using 0 by (simp add: fw_upd_def upd_def)
   next
     case (Suc j)
     have *: "fw m n 0 0 j 0 0 = m 0 0" using single_iteration_inv[ of 0 0 0 j n m 0] A Suc
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutl)
     have **: "fw m n 0 i n 0 0 = m 0 0" using single_iteration_inv[of 0 i 0 n n m 0] A
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutl)
     have "m 0 (Suc j) = fw_upd m 0 0 (Suc j) 0 (Suc j)" using \<open>m 0 0 >= \<one>\<close>
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutl)
     also have "\<dots> = fw m n 0 0 (Suc j) 0 (Suc j)" using fw_middle_id[of 0 n "Suc j" j 0 m] Suc A(4)
     by (simp add: fw_upd_def upd_def *)
     finally have ***: "fw m n 0 (Suc i) j 0 (Suc j) = m 0 (Suc j)"
     using single_iteration_inv'[of 0 "Suc i" "Suc j" n j m 0] A Suc by simp
     have "m (Suc i) 0 = fw_upd m 0 (Suc i) 0 (Suc i) 0" using \<open>m 0 0 >= \<one>\<close>
     by (auto simp add: fw_upd_def upd_def min_def intro: add_mono_neutr)
     also have "\<dots> = fw m n 0 (Suc i) 0 (Suc i) 0"
     using fw_innermost_id[of "Suc i" n 0 n i m] \<open>Suc i \<le> n\<close> ** by (simp add: fw_upd_def upd_def)
     finally have "fw m n 0 (Suc i) j (Suc i) 0 = m (Suc i) 0"
     using single_iteration_inv A Suc by auto
     moreover have "fw m n 0 (Suc i) j (Suc i) (Suc j) = m (Suc i) (Suc j)"
     using fw_middle_id A Suc by simp
     ultimately show ?thesis using Suc *** by (simp add: fw_upd_def upd_def)
   qed
 qed
 
 lemma fw_step_Suc:
   "\<forall> k'\<le>n. fw m n k n n k' k' \<ge> \<one> \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> Suc k \<le> n
     \<Longrightarrow> fw m n (Suc k) i j i j = min (fw m n k n n i j) (fw m n k n n i (Suc k) + fw m n k n n (Suc k) j)"
 proof (induction i)
   case 0 thus ?case
   proof (cases j)
     case 0 thus ?thesis by (simp add: fw_upd_def upd_def)
   next
     case (Suc j)
     then have
       "fw m n k n n 0 (Suc j) = fw m n (Suc k) 0 j 0 (Suc j)"
     using 0(2-) Suc_innermost_id2' by simp
     moreover have "fw m n (Suc k) 0 j 0 (Suc k) = fw m n k n n 0 (Suc k)"
     proof (cases "j < Suc k")
       case True thus ?thesis using 0 Suc_innermost_id2' by simp
     next
       case False
       hence
         "fw m n (Suc k) 0 k 0 (Suc k) = fw m n k n n 0 (Suc k)"
       using 0(2-) Suc Suc_innermost_id2' by simp
       moreover have "fw m n (Suc k) 0 k (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
       using 0(2-) Suc Suc_innermost_id2' by simp
       moreover have "fw m n (Suc k) 0 j 0 (Suc k) = fw m n (Suc k) 0 (Suc k) 0 (Suc k)"
       using False single_iteration_inv 0(2-) Suc by force
       ultimately show ?thesis using 0(1)
       by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutr)
     qed
     moreover have "fw m n k n n (Suc k) (Suc j) = fw m n (Suc k) 0 j (Suc k) (Suc j)"
     using 0(2-) Suc Suc_innermost_id2' by simp
     ultimately show ?thesis using Suc by (simp add: fw_upd_def upd_def)
   qed
 next
   case (Suc i)
   note A = this
   show ?case
   proof (cases j)
     case 0
     hence
       "fw m n (Suc k) i n (Suc i) 0 = fw m n k n n (Suc i) 0"
     using Suc_innermost_id1' \<open>Suc i \<le> n\<close> by simp
     moreover have "fw m n (Suc k) i n (Suc i) (Suc k) = fw m n k n n (Suc i) (Suc k)"
     using Suc_innermost_id1' A(3,5) by simp
     moreover have "fw m n (Suc k) i n (Suc k) 0 = fw m n k n n (Suc k) 0"
     proof (cases "i < Suc k")
       case True thus ?thesis using Suc_innermost_id1' A(3,5) by simp
     next
       case False
       have "fw m n (Suc k) k n (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
       using Suc_innermost_id1' \<open>Suc i \<le> n\<close> False by simp
       moreover have "fw m n (Suc k) k n (Suc k) 0 = fw m n k n n (Suc k) 0"
       using Suc_innermost_id1' \<open>Suc i \<le> n\<close> False by simp
       moreover have "fw m n (Suc k) i n (Suc k) 0 = fw m n (Suc k) (Suc k) 0 (Suc k) 0"
       using single_iteration_inv \<open>Suc i \<le> n\<close> False by simp
       ultimately show ?thesis using Suc(2)
       by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutl)
     qed
     ultimately show ?thesis using 0 by (simp add: fw_upd_def upd_def)
   next
     case (Suc j)
     hence "fw m n (Suc k) (Suc i) j (Suc i) (Suc j) = fw m n k n n (Suc i) (Suc j)"
     using Suc_innermost_id2' A(3,4) by simp
     moreover have "fw m n (Suc k) (Suc i) j (Suc i) (Suc k) = fw m n k n n (Suc i) (Suc k)"
     proof (cases "j < Suc k")
       case True thus ?thesis using Suc A(3-) Suc_innermost_id2' by simp
     next
       case False
       have *:"fw m n (Suc k) (Suc i) k (Suc i) (Suc k) = fw m n k n n (Suc i) (Suc k)"
       using Suc_innermost_id2' A(3,5) by simp
       have **:"fw m n (Suc k) (Suc i) k (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
       proof (cases "Suc i \<le> Suc k")
         case True thus ?thesis using Suc_innermost_id2' A(5) by simp
       next
         case False
         hence "fw m n (Suc k) (Suc i) k (Suc k) (Suc k) = fw m n (Suc k) (Suc k) (Suc k) (Suc k) (Suc k)"
         using single_iteration_inv'[of "Suc k" "Suc i" "Suc k" n k m "Suc k"] A(3) by simp
         moreover have "fw m n (Suc k) (Suc k) k (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
         using Suc_innermost_id2' A(5) by simp
         ultimately show ?thesis using A(2)
         by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutl)
       qed
       have "fw m n (Suc k) (Suc i) j (Suc i) (Suc k) = fw m n (Suc k) (Suc i) (Suc k) (Suc i) (Suc k)"
       using False single_iteration_inv[of "Suc i" "Suc i" "Suc k" j n m "Suc k"] A(3-) Suc by simp
       also have "\<dots> = fw m n k n n (Suc i) (Suc k)" using * ** A(2)
       by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutr)
       finally show ?thesis by simp
     qed
     moreover have "fw m n (Suc k) (Suc i) j (Suc k) (Suc j) = fw m n k n n (Suc k) (Suc j)"
     proof (cases "Suc i \<le> Suc k")
       case True thus ?thesis using Suc_innermost_id2' Suc A(3-5) by simp
     next
       case False
       have "fw m n (Suc k) (Suc k) j (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
       proof (cases "j < Suc k")
         case True thus ?thesis using Suc_innermost_id2' A(5) by simp
       next
         case False
         hence "fw m n (Suc k) (Suc k) j (Suc k) (Suc k) = fw m n (Suc k) (Suc k) (Suc k) (Suc k) (Suc k)"
         using single_iteration_inv A(3,4) Suc by simp
         moreover have "fw m n (Suc k) (Suc k) k (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
         using Suc_innermost_id2' A(5) by simp
         ultimately show ?thesis using A(2)
         by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutl)
       qed
       moreover have "fw m n (Suc k) (Suc k) j (Suc k) (Suc j) = fw m n k n n (Suc k) (Suc j)"
       using Suc_innermost_id2' Suc A(3-5) by simp
       ultimately have "fw m n (Suc k) (Suc k) (Suc j) (Suc k) (Suc j) = fw m n k n n (Suc k) (Suc j)"
       using A(2) by (auto simp add: fw_upd_def upd_def \<open>Suc k \<le> n\<close> min_def intro: add_mono_neutl)
       moreover have "fw m n (Suc k) (Suc i) j (Suc k) (Suc j) = fw m n (Suc k) (Suc k) (Suc j) (Suc k) (Suc j)"
       using single_iteration_inv'[of "Suc k" "Suc i" "Suc j" n j m "Suc k"] Suc A(3-) False  by simp
       moreover have "fw m n (Suc k) (Suc k) k (Suc k) (Suc k) = fw m n k n n (Suc k) (Suc k)"
       using Suc_innermost_id2' A(5) by simp
       ultimately show ?thesis using A(2) by (simp add: fw_upd_def upd_def)
     qed
     ultimately show ?thesis using Suc by (simp add: fw_upd_def upd_def)
   qed
 qed
 
 
 subsection \<open>Length of Paths\<close>
 
 fun len :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> 'a" where
   "len m u v [] = m u v" |
   "len m u v (w#ws) = m u w + len m w v ws"
 
 lemma len_decomp: "xs = ys @ y # zs \<Longrightarrow> len m x z xs = len m x y ys + len m y z zs"
 by (induction ys arbitrary: x xs) (simp add: assoc)+
 
 lemma len_comp: "len m a c (xs @ b # ys) = len m a b xs + len m b c ys"
 by (induction xs arbitrary: a) (auto simp: assoc)
 
 
 subsection \<open>Shortening Negative Cycles\<close>
 
 lemma remove_cycles_neg_cycles_aux:
   fixes i xs ys
   defines "xs' \<equiv> i # ys"
   assumes "i \<notin> set ys"
   assumes "i \<in> set xs"
   assumes "xs = as @ concat (map ((#) i) xss) @ xs'"
   assumes "len m i j ys > len m i j xs"
   shows "\<exists> ys. set ys \<subseteq> set xs \<and> len m i i ys < \<one>" using assms
 proof (induction xss arbitrary: xs as)
   case Nil
   with Nil show ?case
   proof (cases "len m i i as \<ge> \<one>", goal_cases)
     case 1
     from this(4,6) len_decomp[of xs as i ys m i j]
     have "len m i j xs = len m i i as + len m i j ys" by simp
     with 1(11)
     have "len m i j ys \<le> len m i j xs" using add_mono by fastforce
     thus ?thesis using Nil(5) by auto
   next
     case 2 thus ?case by auto
   qed
 next
   case (Cons zs xss)
   let ?xs = "zs @ concat (map ((#) i) xss) @ xs'"
   from Cons show ?case
   proof (cases "len m i i as \<ge> \<one>", goal_cases)
     case 1
     from this(5,7) len_decomp add_mono
     have "len m i j ?xs \<le> len m i j xs" by fastforce
     hence 4:"len m i j ?xs < len m i j ys" using 1(6) by simp
     have 2:"i \<in> set ?xs" using Cons(2) by auto
     have "set ?xs \<subseteq> set xs" using Cons(5) by auto
     moreover from Cons(1)[OF 1(2,3) 2 _ 4] have "\<exists>ys. set ys \<subseteq> set ?xs \<and> len m i i ys < \<one>" by auto
     ultimately show ?case by blast
   next
     case 2
     from this(5,7) show ?case by auto
   qed
 qed
 
 lemma add_lt_neutral: "a + b < b \<Longrightarrow> a < \<one>"
 proof (rule ccontr)
   assume "a + b < b" "\<not> a < \<one>"
   hence "a \<ge> \<one>" by auto
   from add_mono[OF this, of b b] \<open>a + b < b\<close> show False by auto
 qed
 
 lemma remove_cycles_neg_cycles_aux':
   fixes j xs ys
   assumes "j \<notin> set ys"
   assumes "j \<in> set xs"
   assumes "xs = ys @ j # concat (map (\<lambda> xs. xs @ [j]) xss) @ as"
   assumes "len m i j ys > len m i j xs"
   shows "\<exists> ys. set ys \<subseteq> set xs \<and> len m j j ys < \<one>" using assms
 proof (induction xss arbitrary: xs as)
   case Nil
   show ?case
   proof (cases "len m j j as \<ge> \<one>")
     case True
     from Nil(3) len_decomp[of xs ys j as m i j]
     have "len m i j xs = len m i j ys + len m j j as" by simp
     with True
     have "len m i j ys \<le> len m i j xs" using add_mono by fastforce
     with Nil show ?thesis by auto
   next
     case False with Nil show ?thesis by auto
   qed
 next
   case (Cons zs xss)
   let ?xs = "ys @ j # concat (map (\<lambda>xs. xs @ [j]) xss) @ as"
   let ?t = "concat (map (\<lambda>xs. xs @ [j]) xss) @ as"
   show ?case
   proof (cases "len m i j ?xs \<le> len m i j xs")
     case True
     hence 4:"len m i j ?xs < len m i j ys" using Cons(5) by simp
     have 2:"j \<in> set ?xs" using Cons(2) by auto
     have "set ?xs \<subseteq> set xs" using Cons(4) by auto
     moreover from Cons(1)[OF Cons(2) 2 _ 4] have "\<exists>ys. set ys \<subseteq> set ?xs \<and> len m j j ys < \<one>" by blast
     ultimately show ?thesis by blast
   next
     case False
     hence "len m i j xs < len m i j ?xs" by auto
     from this len_decomp Cons(4) add_mono
     have "len m j j (concat (map (\<lambda>xs. xs @ [j]) (zs # xss)) @ as) < len m j j ?t"
     using False local.leI by fastforce 
     hence "len m j j (zs @ j # ?t) < len m j j ?t" by simp
     with len_decomp[of "zs @ j # ?t" zs j ?t m j j]
     have "len m j j zs + len m j j ?t < len m j j ?t" by auto
     hence "len m j j zs < \<one>" using add_lt_neutral by auto
     thus ?thesis using Cons.prems(3) by auto
   qed
 qed
 
 lemma add_le_impl: "a + b < a + c \<Longrightarrow> b < c"
 proof (rule ccontr)
   assume "a + b < a + c" "\<not> b < c"
   hence "b \<ge> c" by auto
   from add_mono[OF _ this, of a a] \<open>a + b < a + c\<close> show False by auto
 qed
 
 lemma start_remove_neg_cycles:
   "len m i j (start_remove xs k []) > len m i j xs \<Longrightarrow> \<exists> ys. set ys \<subseteq> set xs \<and> len m k k ys < \<one>"
 proof-
   let ?xs = "start_remove xs k []"
   assume len_lt:"len m i j ?xs > len m i j xs"
   hence "k \<in> set xs" using start_remove_id by fastforce
   from start_remove_decomp[OF this, of "[]"] obtain as bs where as_bs:
     "xs = as @ k # bs" "?xs = as @ remove_cycles bs k [k]"
   by fastforce
   let ?xs' = "remove_cycles bs k [k]"
   have "k \<in> set bs" using as_bs len_lt remove_cycles_id by fastforce
   then obtain ys where ys: "?xs = as @ k # ys" "?xs' = k # ys" "k \<notin> set ys"
   using as_bs(2) remove_cycles_begins_with[OF \<open>k \<in> set bs\<close>] by auto
   have len_lt': "len m k j bs < len m k j ys"
   using len_decomp[OF as_bs(1), of m i j] len_decomp[OF ys(1), of m i j] len_lt add_le_impl by metis
   from remove_cycles_cycles[OF \<open>k \<in> set bs\<close>] obtain xss as'
   where "as' @ concat (map ((#) k) xss) @ ?xs' = bs" by fastforce
   hence "as' @ concat (map ((#) k) xss) @ k # ys = bs" using ys(2) by simp
   from remove_cycles_neg_cycles_aux[OF \<open>k \<notin> set ys\<close> \<open>k \<in> set bs\<close> this[symmetric] len_lt']
   show ?thesis using as_bs(1) by auto
 qed
 
 lemma remove_all_cycles_neg_cycles:
   "len m i j (remove_all_cycles ys xs) > len m i j xs
   \<Longrightarrow> \<exists> ys k. set ys \<subseteq> set xs \<and> k \<in> set xs \<and> len m k k ys < \<one>"
 proof (induction ys arbitrary: xs)
   case Nil thus ?case by auto
 next
   case (Cons y ys)
   let ?xs = "start_remove xs y []"
   show ?case
   proof (cases "len m i j xs < len m i j ?xs")
     case True
     with start_remove_id have "y \<in> set xs" by fastforce
     with start_remove_neg_cycles[OF True] show ?thesis by blast
   next
     case False
     with Cons(2) have "len m i j ?xs < len m i j (remove_all_cycles (y # ys) xs)" by auto
     hence "len m i j ?xs < len m i j (remove_all_cycles ys ?xs)" by auto
     from Cons(1)[OF this] show ?thesis using start_remove_subs[of xs y "[]"] by auto
   qed
 qed
 
 lemma (in -) concat_map_cons_rev:
   "rev (concat (map ((#) j) xss)) = concat (map (\<lambda> xs. xs @ [j]) (rev (map rev xss)))"
 by (induction xss) auto
 
 lemma negative_cycle_dest: "len m i j (rem_cycles i j xs) > len m i j xs
        \<Longrightarrow> \<exists> i' ys. len m i' i' ys < \<one> \<and> set ys \<subseteq> set xs \<and> i' \<in> set (i # j # xs)"
 proof -
   let ?xsij = "rem_cycles i j xs"
   let ?xsj  = "remove_all_rev j (remove_all_cycles xs xs)"
   let ?xs   = "remove_all_cycles xs xs"
   assume len_lt: "len m i j ?xsij > len m i j xs"
   show ?thesis
   proof (cases "len m i j ?xsij \<le> len m i j ?xsj")
     case True
     hence len_lt: "len m i j ?xsj > len m i j xs" using len_lt by simp
     show ?thesis
     proof (cases "len m i j ?xsj \<le> len m i j ?xs")
       case True
       hence "len m i j ?xs > len m i j xs" using len_lt by simp
       with remove_all_cycles_neg_cycles[OF this] show ?thesis by auto
     next
       case False
       then have len_lt': "len m i j ?xsj > len m i j ?xs" by simp
       show ?thesis
       proof (cases "j \<in> set ?xs")
         case False
         thus ?thesis using len_lt' by (simp add: remove_all_rev_def)
       next
         case True
           from remove_all_rev_removes[of j] have 1: "j \<notin> set ?xsj" by simp
           from True have "j \<in> set (rev ?xs)" by auto
           from remove_cycles_cycles[OF this] obtain xss as where as:
           "as @ concat (map ((#) j) xss) @ remove_cycles (rev ?xs) j [] = rev ?xs" "j \<notin> set as"
           by blast
           from True have "?xsj = rev (tl (remove_cycles (rev ?xs) j []))" by (simp add: remove_all_rev_def)
           with remove_cycles_begins_with[OF \<open>j \<in> set (rev ?xs)\<close>, of "[]"]
           have "remove_cycles (rev ?xs) j [] = j # rev ?xsj" "j \<notin> set ?xsj"
           by auto
           with as(1) have xss: "as @ concat (map ((#) j) xss) @ j # rev ?xsj = rev ?xs" by simp
           hence "rev (as @ concat (map ((#) j) xss) @ j # rev ?xsj) = ?xs" by simp
           hence "?xsj @ j # rev (concat (map ((#) j) xss)) @ rev as = ?xs" by simp
           hence "?xsj @ j # concat (map (\<lambda> xs. xs @ [j]) (rev (map rev xss))) @ rev as = ?xs"
           by (simp add: concat_map_cons_rev)
           from remove_cycles_neg_cycles_aux'[OF 1 True this[symmetric] len_lt']
           show ?thesis using remove_all_cycles_subs by fastforce
       qed
     qed
   next
     case False
     hence len_lt': "len m i j ?xsij > len m i j ?xsj" by simp
     show ?thesis
     proof (cases "i \<in> set ?xsj")
       case False
       thus ?thesis using len_lt' by (simp add: remove_all_def)
     next
       case True
       from remove_all_removes[of i] have 1: "i \<notin> set ?xsij" by (simp add: remove_all_def)
       from remove_cycles_cycles[OF True] obtain xss as where as:
       "as @ concat (map ((#) i) xss) @ remove_cycles ?xsj i [] = ?xsj" "i \<notin> set as" by blast
       from True have "?xsij = tl (remove_cycles ?xsj i [])" by (simp add: remove_all_def)
       with remove_cycles_begins_with[OF True, of "[]"]
       have "remove_cycles ?xsj i [] = i # ?xsij" "i \<notin> set ?xsij"
       by auto
       with as(1) have xss: "as @ concat (map ((#) i) xss) @ i # ?xsij = ?xsj" by simp
       from remove_cycles_neg_cycles_aux[OF 1 True this[symmetric] len_lt']
       show ?thesis using remove_all_rev_subs remove_all_cycles_subs by fastforce
     qed
   qed
 qed
 
 section \<open>Definition of Shortest Paths\<close>
 
 definition D :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
   "D m i j k \<equiv> Min {len m i j xs | xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
 
 lemma (in -) distinct_length_le:"finite s \<Longrightarrow> set xs \<subseteq> s \<Longrightarrow> distinct xs \<Longrightarrow> length xs \<le> card s"
 by (metis card_mono distinct_card) 
 
-lemma (in -) finite_distinct: "finite s \<Longrightarrow> finite {xs . set xs \<subseteq> s \<and> distinct xs}"
-proof -
-  assume "finite s"
-  hence "{xs . set xs \<subseteq> s \<and> distinct xs} \<subseteq> {xs. set xs \<subseteq> s \<and> length xs \<le> card s}"
-  using distinct_length_le by auto
-  moreover have "finite {xs. set xs \<subseteq> s \<and> length xs \<le> card s}"
-  using finite_lists_length_le[OF \<open>finite s\<close>] by auto
-  ultimately show ?thesis by (rule finite_subset)
-qed
-
 lemma D_base_finite:
   "finite {len m i j xs | xs. set xs \<subseteq> {0..k} \<and> distinct xs}"
-using finite_distinct finite_image_set by blast
+using finite_subset_distinct finite_image_set by blast
 
 lemma D_base_finite':
   "finite {len m i j xs | xs. set xs \<subseteq> {0..k} \<and> distinct (i # j # xs)}"
 proof -
   have "{len m i j xs | xs. set xs \<subseteq> {0..k} \<and> distinct (i # j # xs)}
         \<subseteq> {len m i j xs | xs. set xs \<subseteq> {0..k} \<and> distinct xs}" by auto
   with D_base_finite[of m i j k] show ?thesis by (rule rev_finite_subset)
 qed
 
 lemma D_base_finite'':
   "finite {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
 using D_base_finite[of m i j k] by - (rule finite_subset, auto)
 
 definition cycle_free :: "'a mat \<Rightarrow> nat \<Rightarrow> bool" where
   "cycle_free m n \<equiv> \<forall> i xs. i \<le> n \<and> set xs \<subseteq> {0..n} \<longrightarrow>
   (\<forall> j. j \<le> n \<longrightarrow> len m i j (rem_cycles i j xs) \<le> len m i j xs) \<and> len m i i xs \<ge> \<one>"
 
 lemma D_eqI:
   fixes m n i j k
   defines "A \<equiv> {len m i j xs | xs. set xs \<subseteq> {0..k}}"
   defines "A_distinct \<equiv> {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   assumes "cycle_free m n" "i \<le> n" "j \<le> n" "k \<le> n" "(\<And>y. y \<in> A_distinct \<Longrightarrow> x \<le> y)" "x \<in> A"
   shows "D m i j k = x" using assms
 proof -
   let ?S = "{len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   show ?thesis unfolding D_def
   proof (rule Min_eqI)
     have "?S \<subseteq> {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> distinct xs}" by auto
     thus "finite {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
     using D_base_finite[of m i j k] by (rule finite_subset)
   next
     fix y assume "y \<in> ?S"
     hence "y \<in> A_distinct" using assms(2,7) by fastforce
     thus "x \<le> y" using assms by meson
   next
     from assms obtain xs where xs: "x = len m i j xs" "set xs \<subseteq> {0..k}" by auto
     let ?ys = "rem_cycles i j xs"
     let ?y = "len m i j ?ys"
     from assms(3-6) xs have *:"?y \<le> x" by (fastforce simp add: cycle_free_def)
     have distinct: "i \<notin> set ?ys" "j \<notin> set ?ys" "distinct ?ys"
     using rem_cycles_distinct remove_all_removes rem_cycles_removes_last by fast+
     with xs(2) have "?y \<in> A_distinct" unfolding A_distinct_def using rem_cycles_subs by fastforce
     hence "x \<le> ?y" using assms by meson
     moreover have "?y \<le> x" using assms(3-6) xs by (fastforce simp add: cycle_free_def)
     ultimately have "x = ?y" by simp
     thus "x \<in> ?S" using distinct xs(2) rem_cycles_subs[of i j xs] by fastforce
   qed
 qed
 
 lemma D_base_not_empty:
    "{len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs} \<noteq> {}"
 proof -
   have "len m i j [] \<in> {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   by fastforce
   thus ?thesis by auto
 qed
 
 lemma Min_elem_dest: "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> x = Min A \<Longrightarrow> x \<in> A" by simp
 
 lemma D_dest: "x = D m i j k \<Longrightarrow>
   x \<in> {len m i j xs |xs. set xs \<subseteq> {0..Suc k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
 using Min_elem_dest[OF D_base_finite'' D_base_not_empty] by (fastforce simp add: D_def)
 
 lemma D_dest': "x = D m i j k \<Longrightarrow> x \<in> {len m i j xs |xs. set xs \<subseteq> {0..Suc k}}"
 using Min_elem_dest[OF D_base_finite'' D_base_not_empty] by (fastforce simp add: D_def)
 
 lemma D_dest'': "x = D m i j k \<Longrightarrow> x \<in> {len m i j xs |xs. set xs \<subseteq> {0..k}}"
 using Min_elem_dest[OF D_base_finite'' D_base_not_empty] by (fastforce simp add: D_def)
 
 lemma cycle_free_loop_dest: "i \<le> n \<Longrightarrow> set xs \<subseteq> {0..n} \<Longrightarrow> cycle_free m n \<Longrightarrow> len m i i xs \<ge> \<one>"
 unfolding cycle_free_def by auto
 
 lemma cycle_free_dest:
   "cycle_free m n \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> set xs \<subseteq> {0..n}
     \<Longrightarrow> len m i j (rem_cycles i j xs) \<le> len m i j xs"
 by (auto simp add: cycle_free_def)
 
 definition cycle_free_up_to :: "'a mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "cycle_free_up_to m k n \<equiv> \<forall> i xs. i \<le> n \<and> set xs \<subseteq> {0..k} \<longrightarrow>
   (\<forall> j. j \<le> n \<longrightarrow> len m i j (rem_cycles i j xs) \<le> len m i j xs) \<and> len m i i xs \<ge> \<one>"
 
 lemma cycle_free_up_to_loop_dest:
   "i \<le> n \<Longrightarrow> set xs \<subseteq> {0..k} \<Longrightarrow> cycle_free_up_to m k n \<Longrightarrow> len m i i xs \<ge> \<one>"
 unfolding cycle_free_up_to_def by auto
 
 lemma cycle_free_up_to_diag:
   assumes "cycle_free_up_to m k n" "i \<le> n"
   shows "m i i \<ge> \<one>"
 using cycle_free_up_to_loop_dest[OF assms(2) _ assms(1), of "[]"] by auto
 
 lemma D_eqI2:
   fixes m n i j k
   defines "A \<equiv> {len m i j xs | xs. set xs \<subseteq> {0..k}}"
   defines "A_distinct \<equiv> {len m i j xs | xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   assumes "cycle_free_up_to m k n" "i \<le> n" "j \<le> n" "k \<le> n"
           "(\<And>y. y \<in> A_distinct \<Longrightarrow> x \<le> y)" "x \<in> A"
   shows "D m i j k = x" using assms
 proof -
   show ?thesis
   proof (simp add: D_def A_distinct_def[symmetric], rule Min_eqI)
     show "finite A_distinct" using D_base_finite''[of m i j k] unfolding A_distinct_def by auto
   next
     fix y assume "y \<in> A_distinct"
     thus "x \<le> y" using assms by meson
   next
     from assms obtain xs where xs: "x = len m i j xs" "set xs \<subseteq> {0..k}" by auto
     let ?ys = "rem_cycles i j xs"
     let ?y = "len m i j ?ys"
     from assms(3-6) xs have *:"?y \<le> x" by (fastforce simp add: cycle_free_up_to_def)
     have distinct: "i \<notin> set ?ys" "j \<notin> set ?ys" "distinct ?ys"
     using rem_cycles_distinct remove_all_removes rem_cycles_removes_last by fast+
     with xs(2) have "?y \<in> A_distinct" unfolding A_distinct_def using rem_cycles_subs by fastforce 
     hence "x \<le> ?y" using assms by meson
     moreover have "?y \<le> x" using assms(3-6) xs by (fastforce simp add: cycle_free_up_to_def)
     ultimately have "x = ?y" by simp
     then show "x \<in> A_distinct" using distinct xs(2) rem_cycles_subs[of i j xs]
     unfolding A_distinct_def by fastforce
   qed
 qed
 
 
 section \<open>Result Under The Absence of Negative Cycles\<close>
 
 text \<open>
   This proves that the algorithm correctly computes shortest paths under the absence of negative
   cycles by a standard argument.
 \<close>
 
 theorem fw_shortest_path_up_to:
   "cycle_free_up_to m k n \<Longrightarrow> i' \<le> i \<Longrightarrow> j' \<le> j \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n
         \<Longrightarrow> D m i' j' k = fw m n k i j i' j'"
 proof (induction k arbitrary: i j i' j')
   case 0
   from cycle_free_up_to_diag[OF 0(1)] have diag: "\<forall> k \<le> n. m k k \<ge> \<one>" by auto
   then have m_diag: "m 0 0 \<ge> \<one>" by simp
   let ?S = "{len m i' j' xs |xs. set xs \<subseteq> {0} \<and> i' \<notin> set xs \<and> j' \<notin> set xs \<and> distinct xs}"
   show ?case unfolding D_def
   proof (simp, rule Min_eqI)
     have "?S \<subseteq> {len m i' j' xs |xs. set xs \<subseteq> {0..0} \<and> distinct xs}" by auto
     thus "finite ?S" using D_base_finite[of m i' j' 0] by (rule finite_subset)
   next
     fix l assume "l \<in> ?S"
     then obtain xs where l: "l = len m i' j' xs" and xs: "xs = [] \<or> xs = [0]"
     using distinct_list_single_elem_decomp by auto
     { assume "xs = []"
       have "fw m n 0 i j i' j' \<le> fw m n 0 0 0 i' j'" using fw_invariant 0 by blast
       also have "\<dots> \<le> m i' j'" by (cases "i' = 0 \<and> j' = 0") (simp add: fw_upd_def upd_def)+
       finally have "fw m n 0 i j i' j' \<le> l" using \<open>xs = []\<close> l by simp
     }
     moreover
     { assume "xs = [0]"
       have "fw m n 0 i j i' j' \<le> fw m n 0 i' j' i' j'" using fw_invariant 0 by blast
       also have "\<dots> \<le> m i' 0 + m 0 j'"
       proof (cases j')
         assume "j' = 0"
         show ?thesis
         proof (cases i')
           assume "i' = 0"
           thus ?thesis using \<open>j' = 0\<close> by (simp add: fw_upd_def upd_def)
         next
           fix i'' assume i'': "i' = Suc i''"
           have "fw_upd (fw m n 0 i'' n) 0 (Suc i'') 0 (Suc i'') 0 \<le> fw m n 0 i'' n (Suc i'') 0"
           by (simp add: fw_upd_mono)
           also have "\<dots> \<le> m (Suc i'') 0" using fw_mono 0 i'' by simp
           finally show ?thesis using \<open>j' = 0\<close> m_diag i'' neutr add_mono by fastforce
         qed
       next
         fix j'' assume j'': "j' = Suc j''"
         have "fw_upd (fw m n 0 i' j'') 0 i' (Suc j'') i' (Suc j'')
               \<le> fw m n 0 i' j'' i' 0 + fw m n 0 i' j'' 0 (Suc j'') "
         by (simp add: fw_upd_def upd_def)
         also have "\<dots> \<le> m i' 0 + m 0 (Suc j'')"
         using fw_mono[of i' n j'' i' 0 m 0] fw_mono[of i' n j'' 0 "Suc j''" m 0 ] j'' 0
         by (simp add: add_mono)
         finally show ?thesis using j'' by simp
       qed
       finally have "fw m n 0 i j i' j' \<le> l" using \<open>xs = [0]\<close> l by simp
     }
     ultimately show "fw m n 0 i j i' j' \<le> l" using xs by auto
   next
     have A: "fw m n 0 i j i' j' = fw m n 0 i' j' i' j'" using single_iteration_inv 0 by blast
     have "fw m n 0 i' j' i' j' = min (m i' j') (m i' 0 + m 0 j')"
     using 0 by (simp add: fw_step_0[of m, OF m_diag])
     hence
       "fw m n 0 i' j' i' j' = m i' j'
       \<or> (fw m n 0 i' j' i' j' = m i' 0 + m 0 j'\<and> m i' 0 + m 0 j' \<le> m i' j')"
     by (auto simp add: ord.min_def) 
     thus "fw m n 0 i j i' j' \<in> ?S"
     proof (standard, goal_cases)
       case 1
       hence "fw m n 0 i j i' j' = len m i' j' []" using A by auto
       thus ?case by fastforce
     next
       case 2
       hence *:"fw m n 0 i j i' j' = len m i' j' [0]" using A by auto
       thus ?case
       proof (cases "i' = 0 \<or> j' = 0")
         case False thus ?thesis using * by fastforce
       next
         case True
         { assume "i' = 0"
           from diag have "m 0 0 + m 0 j' \<ge> m 0 j'" by (auto intro: add_mono_neutl)
           with \<open>i' = 0\<close> have "fw m n 0 i j i' j' = len m 0 j' []" using 0 A 2 by auto
         } moreover
         { assume "j' = 0"
           from diag have "m i' 0 + m 0 0 \<ge> m i' 0" by (auto intro: add_mono_neutr)
           with \<open>j' = 0\<close> have "fw m n 0 i j i' j' = len m i' 0 []" using 0 A 2 by auto
         }
         ultimately have "fw m n 0 i j i' j' = len m i' j' []" using True by auto
         then show ?thesis by fastforce
       qed
     qed
   qed
 next
   case (Suc k)
   from cycle_free_up_to_diag[OF Suc.prems(1)] have diag: "\<forall> k \<le> n. m k k \<ge> \<one>" by auto
   from Suc.prems have cycle_free_to_k:
     "cycle_free_up_to m k n" by (fastforce simp add: cycle_free_up_to_def)
   { fix k' assume "k' \<le> n"
     with Suc cycle_free_to_k have "D m k' k' k = fw m n k n n k' k'" by auto
     from D_dest''[OF this[symmetric]] obtain xs where
       "set xs \<subseteq> {0..k}" "fw m n k n n k' k'= len m k' k' xs"
     by auto
     with Suc(2) \<open>Suc k \<le> n\<close> \<open>k' \<le> n\<close> have "fw m n k n n k' k' \<ge> \<one>"
     unfolding cycle_free_up_to_def by force
   }
   hence K: "\<forall>k'\<le>n. fw m n k n n k' k' \<ge> \<one>" by simp
   let ?S = "\<lambda> k i j. {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   show ?case
   proof (rule D_eqI2)
     show "cycle_free_up_to m (Suc k) n" using Suc.prems(1) .
   next
     show "i' \<le> n" using Suc.prems by simp
   next
     show "j' \<le> n" using Suc.prems by simp
   next
     show "Suc k \<le> n" using Suc.prems by simp
   next
     fix l assume "l \<in> {len m i' j' xs | xs. set xs \<subseteq> {0..Suc k} \<and> i' \<notin> set xs \<and> j' \<notin> set xs \<and> distinct xs}"
     then obtain xs where xs:
       "l = len m i' j' xs" "set xs \<subseteq> {0..Suc k}" "i' \<notin> set xs" "j' \<notin> set xs" "distinct xs"
     by auto
     have IH: "D m i' j' k = fw m n k i j i' j'" using cycle_free_to_k Suc by auto
     have fin:
       "finite {len m i' j' xs |xs. set xs \<subseteq> {0..k} \<and> i' \<notin> set xs \<and> j' \<notin> set xs \<and> distinct xs}"
     using D_base_finite'' by simp
     show "fw m n (Suc k) i j i' j' \<le> l"
     proof (cases "Suc k \<in> set xs")
       case False
       hence "set xs \<subseteq> {0..k}" using xs(2) using atLeastAtMostSuc_conv by auto
       hence
         "l \<in> {len m i' j' xs | xs. set xs \<subseteq> {0..k} \<and> i' \<notin> set xs \<and> j' \<notin> set xs \<and> distinct xs}"
       using xs by auto
       with Min_le[OF fin this] have "fw m n k i j i' j' \<le> l" using IH by (simp add: D_def)
       thus ?thesis using fw_invariant[of k "Suc k" i n j j i m i' j'] Suc.prems by simp
     next
       case True
       then obtain ys zs where ys_zs_id: "xs = ys @ Suc k # zs" by (meson split_list)
       with xs(5) have ys_zs: "distinct ys" "distinct zs" "Suc k \<notin> set ys" "Suc k \<notin> set zs"
       "set ys \<inter> set zs = {}" by auto
       have "i' \<noteq> Suc k" "j' \<noteq> Suc k" using xs(3,4) True by auto
 
       have "set ys \<subseteq> {0..k}" using ys_zs(3) xs(2) ys_zs_id using atLeastAtMostSuc_conv by auto
       hence "len m i' (Suc k) ys \<in> ?S k i' (Suc k)" using ys_zs_id ys_zs xs(3) by fastforce
       with Min_le[OF _ this] have "Min (?S k i' (Suc k)) \<le> len m i' (Suc k) ys"
       using D_base_finite'[of m i' "Suc k" k] \<open>i' \<noteq> Suc k\<close> by fastforce
       moreover have "fw m n k n n i' (Suc k)  =  D m i' (Suc k) k"
       using Suc.IH[OF cycle_free_to_k, of i' n] Suc.prems by auto
       ultimately have *:"fw m n k n n i' (Suc k) \<le> len m i' (Suc k) ys" using \<open>i' \<noteq> Suc k\<close>
       by (auto simp: D_def)
 
       have "set zs \<subseteq> {0..k}" using ys_zs(4) xs(2) ys_zs_id using atLeastAtMostSuc_conv by auto
       hence "len m (Suc k) j' zs \<in> ?S k (Suc k) j'" using ys_zs_id ys_zs xs(3,4,5) by fastforce
       with Min_le[OF _ this] have "Min (?S k (Suc k) j') \<le> len m (Suc k) j' zs"
       using D_base_finite'[of m "Suc k" j' k] \<open>j' \<noteq> Suc k\<close> by fastforce
       moreover have "fw m n k n n (Suc k) j'  =  D m (Suc k) j' k"
       using Suc.IH[OF cycle_free_to_k, of "Suc k" n j' n] Suc.prems by auto
       ultimately have **:"fw m n k n n (Suc k) j' \<le> len m (Suc k) j' zs" using \<open>j' \<noteq> Suc k\<close>
       by (auto simp: D_def)
 
       have len_eq: "l = len m i' (Suc k) ys + len m (Suc k) j' zs"
       by (simp add: xs(1) len_decomp[OF ys_zs_id, symmetric] ys_zs_id)
       have "fw m n (Suc k) i' j' i' j' \<le> fw m n k n n i' (Suc k) + fw m n k n n (Suc k) j'"
       using fw_step_Suc[of n m k i' j', OF K] Suc.prems(2-) by simp
       hence "fw m n (Suc k) i' j' i' j' \<le> l"
       using fw_step_Suc[of n m k i j] Suc.prems(3-) * ** len_eq add_mono by fastforce
       thus ?thesis using fw_invariant[of "Suc k" "Suc k" i n j j' i' m i' j'] Suc.prems(2-) by simp
     qed
   next
     have "fw m n (Suc k) i j i' j' = fw m n (Suc k) i' j' i' j'"
     using single_iteration_inv[OF Suc.prems(2-5)] .
     also have "\<dots> = min (fw m n k n n i' j') (fw m n k n n i' (Suc k) + fw m n k n n (Suc k) j')"
     using fw_step_Suc[OF K] Suc.prems(2-) by simp
     finally show "fw m n (Suc k) i j i' j' \<in> {len m i' j' xs | xs. set xs \<subseteq> {0..Suc k}}"
     proof (cases "fw m n (Suc k) i j i' j' = fw m n k n n i' j'", goal_cases)
       case True
       have "fw m n (Suc k) i j i' j' = D m i' j' k"
       using Suc.IH[OF cycle_free_to_k, of i' n j' n] Suc.prems(2-) True by simp
       from D_dest'[OF this] show ?thesis by blast
     next
       case 2
       hence A:"fw m n (Suc k) i j i' j' = fw m n k n n i' (Suc k) + fw m n k n n (Suc k) j'"
       by (metis ord.min_def)
       have "fw m n k n n i' j' = D m i' j' k"
       using Suc.IH[OF cycle_free_to_k, of i' n j' n] Suc.prems by simp
       from D_dest[OF this] have B:"fw m n k n n i' j' \<in> ?S (Suc k) i' j'"
       by blast
       have "fw m n k n n i' (Suc k) = D m i' (Suc k) k"
       using Suc.IH[OF cycle_free_to_k, of i' n "Suc k" n] Suc.prems by simp
       from D_dest'[OF this] obtain xs where xs:
         "fw m n k n n i' (Suc k) = len m i' (Suc k) xs" "set xs \<subseteq> {0..Suc k}" by blast
       have "fw m n k n n (Suc k) j' = D m (Suc k) j' k"
       using Suc.IH[OF cycle_free_to_k, of "Suc k" n j' n] Suc.prems by simp
       from D_dest'[OF this] obtain ys where ys:
         "fw m n k n n (Suc k) j' = len m (Suc k) j' ys" "set ys \<subseteq> {0..Suc k}" by blast
       from A xs(1) ys(1) len_comp
       have "fw m n (Suc k) i j i' j' = len m i' j' (xs @ Suc k # ys)" by simp
       moreover have "set (xs @ Suc k # ys) \<subseteq> {0..Suc k}" using xs(2) ys(2) by auto
       ultimately show ?thesis by blast
     qed
   qed
 qed
 
 lemma cycle_free_cycle_free_up_to:
   "cycle_free m n \<Longrightarrow> k \<le> n \<Longrightarrow> cycle_free_up_to m k n"
 unfolding cycle_free_def cycle_free_up_to_def by force
 
 lemma cycle_free_diag:
   "cycle_free m n \<Longrightarrow> i \<le> n \<Longrightarrow> \<one> \<le> m i i"
 using cycle_free_up_to_diag[OF cycle_free_cycle_free_up_to] by blast
 
 corollary fw_shortest_path:
   "cycle_free m n \<Longrightarrow> i' \<le> i \<Longrightarrow> j' \<le> j \<Longrightarrow> i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> k \<le> n
         \<Longrightarrow> D m i' j' k = fw m n k i j i' j'"
 using fw_shortest_path_up_to[OF cycle_free_cycle_free_up_to] by auto
 
 corollary fw_shortest:
   assumes "cycle_free m n" "i \<le> n" "j \<le> n" "k \<le> n"
   shows "fw m n n n n i j \<le> fw m n n n n i k + fw m n n n n k j"
 proof (rule ccontr, goal_cases)
   case 1
   let ?S = "\<lambda> i j. {len m i j xs |xs. set xs \<subseteq> {0..n}}"
   let ?FW = "fw m n n n n"
   from assms fw_shortest_path
   have FW: "?FW i j = D m i j n" "?FW i k = D m i k n" "?FW k j = D m k j n" by auto
   with D_dest'' FW have "?FW i k \<in> ?S i k" "?FW k j \<in> ?S k j" by auto
   then obtain xs ys where xs_ys:
     "?FW i k = len m i k xs" "set xs \<subseteq> {0..n}" "?FW k j = len m k j ys" "set ys \<subseteq> {0..n}" by auto
   let ?zs = "rem_cycles i j (xs @ k # ys)"
   have *:"?FW i j = Min {len m i j xs |xs. set xs \<subseteq> {0..n} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   using FW(1) unfolding D_def .
   have "set (xs @ k # ys) \<subseteq> {0..n}" using assms xs_ys by fastforce
   from cycle_free_dest [OF \<open>cycle_free m n\<close> \<open>i \<le> n\<close> \<open>j \<le> n\<close> this]
   have **:"len m i j ?zs \<le> len m i j (xs @ k # ys)" by auto
   moreover have "i \<notin> set ?zs" "j \<notin> set ?zs" "distinct ?zs"
   using rem_cycles_distinct remove_all_removes rem_cycles_removes_last by fast+
   moreover have "set ?zs \<subseteq> {0..n}" using rem_cycles_subs[of i j"xs @ k # ys"] xs_ys assms by fastforce
   ultimately have
     "len m i j ?zs \<in> {len m i j xs |xs. set xs \<subseteq> {0..n} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}"
   by blast
   with * have "?FW i j \<le> len m i j ?zs" using D_base_finite'' by auto
   with ** xs_ys len_comp 1 show ?case by auto
 qed
 
 
 section \<open>Result Under the Presence of Negative Cycles\<close>
 
 lemma not_cylce_free_dest: "\<not> cycle_free m n \<Longrightarrow> \<exists> k \<le> n. \<not> cycle_free_up_to m k n"
 by (auto simp add: cycle_free_def cycle_free_up_to_def)
 
 lemma D_not_diag_le:
   "(x :: 'a) \<in> {len m i j xs |xs. set xs \<subseteq> {0..k} \<and> i \<notin> set xs \<and> j \<notin> set xs \<and> distinct xs}
   \<Longrightarrow> D m i j k \<le> x" using Min_le[OF D_base_finite''] by (auto simp add: D_def)
 
 lemma D_not_diag_le': "set xs \<subseteq> {0..k} \<Longrightarrow> i \<notin> set xs \<Longrightarrow> j \<notin> set xs \<Longrightarrow> distinct xs
   \<Longrightarrow> D m i j k \<le> len m i j xs" using Min_le[OF D_base_finite''] by (fastforce simp add: D_def)
 
 lemma (in -) nat_upto_subs_top_removal':
   "S \<subseteq> {0..Suc n} \<Longrightarrow> Suc n \<notin> S \<Longrightarrow> S \<subseteq> {0..n}"
 apply (induction n)
  apply safe
  apply (rename_tac x)
  apply (case_tac "x = Suc 0"; fastforce)
 apply (rename_tac n x)
 apply (case_tac "x = Suc (Suc n)"; fastforce)
 done
 
 lemma (in -) nat_upto_subs_top_removal:
   "S \<subseteq> {0..n::nat} \<Longrightarrow> n \<notin> S \<Longrightarrow> S \<subseteq> {0..n - 1}"
 using nat_upto_subs_top_removal' by (cases n; simp)
 
 lemma fw_Suc:
   "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> i' \<le> n \<Longrightarrow> j' \<le> n \<Longrightarrow> fw m n (Suc k) i' j' i j \<le> fw m n k n n i j"
 by (metis Suc_innermost_id1' Suc_innermost_id2 Suc_innermost_mono linorder_class.not_le order.eq_iff
           preorder_class.order_refl single_iteration_inv single_iteration_inv')
 
 lemma negative_len_shortest:
   "length xs = n \<Longrightarrow> len m i i xs < \<one>
     \<Longrightarrow> \<exists> j ys. distinct (j # ys) \<and> len m j j ys < \<one> \<and> j \<in> set (i # xs) \<and> set ys \<subseteq> set xs"
 proof (induction n arbitrary: xs i rule: less_induct)
   case (less n)
   show ?case
   proof (cases xs)
     case Nil
     thus ?thesis using less.prems by auto
   next
     case (Cons y ys)
     then have "length xs \<ge> 1" by auto
     show ?thesis
     proof (cases "i \<in> set xs")
       assume i: "i \<in> set xs"
       then obtain as bs where xs: "xs = as @ i # bs" by (meson split_list)
       show ?thesis
       proof (cases "len m i i as < \<one>")
         case True
         from xs less.prems have "length as < n" by auto
         from less.IH[OF this _ True] xs show ?thesis by auto
       next
         case False
         from len_decomp[OF xs] have "len m i i xs = len m i i as + len m i i bs" by auto
         with False less.prems have *: "len m i i bs < \<one>"
         by (metis add_lt_neutral local.dual_order.strict_trans local.neqE)
         from xs less.prems have "length bs < n" by auto
         from less.IH[OF this _ *] xs show ?thesis by auto
       qed
     next
       assume i: "i \<notin> set xs"
       show ?thesis
       proof (cases "distinct xs")
         case True
         with i less.prems show ?thesis by auto
       next
         case False
         from not_distinct_decomp[OF this] obtain a as bs cs where xs:
           "xs = as @ a # bs @ a # cs"
         by auto
         show ?thesis
         proof (cases "len m a a bs < \<one>")
           case True
           from xs less.prems have "length bs < n" by auto
           from less.IH[OF this _ True] xs show ?thesis by auto
         next
           case False
           from len_decomp[OF xs, of m  i i] len_decomp[of "bs @ a # cs" bs a cs m a i]
           have *:"len m i i xs = len m i a as + (len m a a bs + len m a i cs)" by auto
           from False have "len m a a bs \<ge> \<one>" by auto
           with add_mono have "len m a a bs + len m a i cs \<ge> len m a i cs" by fastforce
           with * have "len m i i xs \<ge> len m i a as + len m a i cs" by (simp add: add_mono)
           with less.prems(2) have "len m i a as + len m a i cs < \<one>" by auto
           with len_comp have "len m i i (as @ a # cs) < \<one>" by auto
           from less.IH[OF _ _ this, of "length (as @ a # cs)"] xs less.prems
           show ?thesis by auto
         qed
       qed
     qed
   qed
 qed
 
 theorem FW_neg_cycle_detect:
   "\<not> cycle_free m n \<Longrightarrow> \<exists> i \<le> n. fw m n n n n i i < \<one>"
 proof -
   assume A: "\<not> cycle_free m n"
   let ?K = "{k. k \<le> n \<and> \<not> cycle_free_up_to m k n}"
   let ?k = "Min ?K"
   have not_empty_K: "?K \<noteq> {}" using not_cylce_free_dest[OF A(1)] by auto
   have "finite ?K" by auto
   with not_empty_K have *:
     "\<forall> k' < ?k. cycle_free_up_to m k' n"
   by (auto, metis le_trans less_or_eq_imp_le preorder_class.less_irrefl)
   from linorder_class.Min_in[OF \<open>finite ?K\<close> \<open>?K \<noteq> {}\<close>] have
     "\<not> cycle_free_up_to m ?k n" "?k \<le> n"
   by auto
   then have "\<exists> xs j. j \<le> n \<and> len m j j xs < \<one> \<and> set xs \<subseteq> {0..?k}" unfolding cycle_free_up_to_def
   proof (auto, goal_cases)
     case (2 i xs) then have "len m i i xs < \<one>" by auto
     with 2 show ?case by auto
   next
     case (1 i xs j)
     then have "len m i j (rem_cycles i j xs) > len m i j xs" by auto
     from negative_cycle_dest[OF this]
     obtain i' ys where ys: "i' \<in> set (i # j # xs)" "len m i' i' ys < \<one>" "set ys \<subseteq> set xs" by blast
     from ys(1) 1(2-4) show ?case
     proof (auto, goal_cases)
       case 1
       with ys(2,3) show ?case by auto
     next
       case 2
       with ys(2,3) show ?case by auto
     next
       case 3
       with \<open>?k \<le> n\<close> have "i' \<le> n" unfolding cycle_free_up_to_def by auto
       with 3 ys(2,3) show ?case by auto
     qed
   qed
   then obtain a as where a_as: "a \<le> n \<and> len m a a as < \<one> \<and> set as \<subseteq> {0..?k}" by auto
   with negative_len_shortest[of as "length as" m a] obtain j xs where j_xs:
   "distinct (j # xs) \<and> len m j j xs < \<one> \<and> j \<in> set (a # as) \<and> set xs \<subseteq> set as" by auto
   with a_as \<open>?k \<le> n\<close> have cyc: "j \<le> n" "set xs \<subseteq> {0..?k}" "len m j j xs < \<one>" "distinct (j # xs)"
   by auto
   { assume "?k > 0"
     then have "?k - 1 < ?k" by simp
     with * have **:"cycle_free_up_to m (?k - 1) n" by blast
     have "?k \<in> set xs"
     proof (rule ccontr, goal_cases)
       case 1
       with \<open>set xs \<subseteq> {0..?k}\<close> nat_upto_subs_top_removal have "set xs \<subseteq> {0..?k-1}" by auto
       from cycle_free_up_to_loop_dest[OF \<open>j \<le> n\<close> this \<open>cycle_free_up_to m (?k - 1) n\<close>] cyc(3)
       show ?case by auto
     qed
     with cyc(4) have "j \<noteq> ?k" by auto
     from \<open>?k \<in> set xs\<close> obtain ys zs where "xs = ys @ ?k # zs" by (meson split_list)
     with \<open>distinct (j # xs)\<close>
     have xs: "xs = ys @ ?k # zs" "distinct ys" "distinct zs" "?k \<notin> set ys" "?k \<notin> set zs"
              "j \<notin> set ys" "j \<notin> set zs" by auto
     from xs(1,4) \<open>set xs \<subseteq> {0..?k}\<close> nat_upto_subs_top_removal have ys: "set ys \<subseteq> {0..?k-1}" by auto
     from xs(1,5) \<open>set xs \<subseteq> {0..?k}\<close> nat_upto_subs_top_removal have zs: "set zs \<subseteq> {0..?k-1}" by auto
     have "D m j ?k (?k - 1) = fw m n (?k - 1) n n j ?k"
     using \<open>?k \<le> n\<close> \<open>j \<le> n\<close> fw_shortest_path_up_to[OF **, of j n ?k n] by auto
     moreover have "D m ?k j (?k - 1) = fw m n (?k - 1) n n ?k j"
     using \<open>?k \<le> n\<close> \<open>j \<le> n\<close> fw_shortest_path_up_to[OF **, of ?k n j n] by auto
     ultimately have "fw m n (?k - 1) n n j ?k + fw m n (?k - 1) n n ?k j \<le> len m j ?k ys + len m ?k j zs"
     using D_not_diag_le'[OF zs(1) xs(5,7,3), of m]
           D_not_diag_le'[OF ys(1) xs(6,4,2), of m] by (auto simp: add_mono)
     then have neg: "fw m n (?k - 1) n n j ?k + fw m n (?k - 1) n n ?k j < \<one>"
     using xs(1) \<open>len m j j xs < \<one>\<close> len_comp by auto
     have "fw m n ?k j j j j \<le> fw m n (?k - 1) n n j ?k + fw m n (?k - 1) n n ?k j"
     proof (cases "j = 0")
       case True
       with\<open>?k > 0\<close> fw.simps(2)[of m n "?k - 1"]
       have "fw m n ?k j j = fw_upd (fw m n (?k - 1) n n) ?k j j" by auto
       then have "fw m n ?k j j j j \<le> fw m n (?k - 1) n n j ?k + fw m n (?k - 1) n n ?k j"
       by (simp add: fw_upd_def upd_def)
       then show ?thesis by auto
     next
       case False
       with fw.simps(4)[of m n ?k j "j - 1"]
       have "fw m n ?k j j = fw_upd (fw m n ?k j (j -1)) ?k j j" by simp
       then have *: "fw m n ?k j j j j \<le> fw m n ?k j (j -1) j ?k + fw m n ?k j (j -1) ?k j"
       by (simp add: fw_upd_def upd_def)
       have "j - 1 < n" using \<open>j \<le> n\<close> False by auto
       then have "fw m n ?k j (j -1) j ?k \<le> fw m n (?k - 1) n n j ?k"
       using fw_Suc[of j n ?k j "j - 1" m "?k - 1"] \<open>j \<le> n\<close> \<open>?k \<le> n\<close> \<open>?k > 0\<close> by auto
       moreover have "fw m n ?k j (j -1) ?k j \<le> fw m n (?k - 1) n n ?k j"
       using fw_Suc[of ?k n j j "j - 1" m "?k - 1"] \<open>j \<le> n\<close> \<open>?k \<le> n\<close> \<open>?k > 0\<close> by auto
       ultimately have "fw m n ?k j j j j \<le> fw m n (?k - 1) n n j ?k + fw m n (?k - 1) n n ?k j"
       using * add_mono by fastforce
       then show ?thesis by auto
     qed
     with neg have "fw m n ?k j j j j < \<one>" by auto
     moreover have "fw m n n n n j j \<le> fw m n ?k j j j j" using fw_invariant \<open>j\<le>n\<close> \<open>?k \<le> n\<close> by auto
     ultimately have "fw m n n n n j j < \<one>" using neg by auto
     with \<open>j\<le>n\<close> have ?thesis by auto
   }
   moreover
   { assume "?k = 0"
     with cyc(2,4) have "xs = [] \<or> xs = [0]"
       apply safe
       apply (case_tac xs)
        apply fastforce
       apply (rename_tac ys)
       apply (case_tac ys)
        apply auto
     done
     then have ?thesis
     proof
       assume "xs = []"
       with cyc have "m j j < \<one>" by auto
       with fw_mono[of n n n j j m n] \<open>j \<le> n\<close> have "fw m n n n n j j < \<one>" by auto
       with \<open>j \<le> n\<close> show ?thesis by auto
     next
       assume xs: "xs = [0]"
       with cyc have "m j 0 + m 0 j < \<one>" by auto
       then have "fw m n 0 j j j j < \<one>"
       proof (cases "j = 0", goal_cases)
         case 1
         have "m j j < \<one>"
         proof (rule ccontr)
           assume "\<not> m j j < \<one>"
           with 1 have "m 0 0 \<ge> \<one>" by simp
           with add_mono have "m 0 0 + m 0 0 \<ge> \<one>" by fastforce
           with 1 show False by simp
         qed
         with fw_mono[of j n j j j m 0] \<open>j \<le> n\<close> show ?thesis by auto
       next
         case 2
         with fw.simps(4)[of m n 0 j "j - 1"]
         have "fw m n 0 j j = fw_upd (fw m n 0 j (j - 1)) 0 j j" by simp
         then have "fw m n 0 j j j j \<le> fw m n 0 j (j - 1) j 0 + fw m n 0 j (j - 1) 0 j"
         by (simp add: fw_upd_def upd_def)
         also have "\<dots> \<le> m j 0 + m 0 j" using \<open>j \<le> n\<close> add_mono fw_mono by auto
         finally show ?thesis using 2 by auto
       qed
       then have "fw m n 0 n n j j < \<one>" by (metis cyc(1) less_or_eq_imp_le single_iteration_inv) 
       with fw_invariant[of 0 n n n n n n m j j] \<open>j \<le> n\<close> have "fw m n n n n j j < \<one>" by auto
       with \<open>j \<le> n\<close> show ?thesis by blast
     qed
   }
   ultimately show ?thesis by auto
 qed
 
 end (* End of local class context *)
 end (* End of theory *)
diff --git a/thys/Universal_Hash_Families/Universal_Hash_Families_More_Finite_Fields.thy b/thys/Universal_Hash_Families/Universal_Hash_Families_More_Finite_Fields.thy
--- a/thys/Universal_Hash_Families/Universal_Hash_Families_More_Finite_Fields.thy
+++ b/thys/Universal_Hash_Families/Universal_Hash_Families_More_Finite_Fields.thy
@@ -1,253 +1,109 @@
 section \<open>Finite Fields\<close>
 
 theory Universal_Hash_Families_More_Finite_Fields
-  imports
-    Finite_Fields.Ring_Characteristic
-    "HOL-Algebra.Ring_Divisibility"
-    "HOL-Algebra.IntRing"
+  imports Finite_Fields.Finite_Fields_Mod_Ring_Code
 begin
 
-text \<open>In some applications it is more convenient to work with natural numbers instead of
-@{term "ZFact p"} whose elements are cosets. To support that use case the following definition
-introduces an additive and multiplicative structure on @{term "{..<p}"}. After verifying that
-the function @{term "zfact_iso"} and its inverse are homomorphisms, the ring and field property
-can be transfered from @{term "ZFact p"} to to the structure on @{term "{..<p}"}.\<close>
+text \<open>This theory have been moved to @{theory "Finite_Fields.Finite_Fields_Mod_Ring_Code"}, where
+@{term "mod_ring n"} corresponds to @{term "ring_of (mod_ring n)"}. The lemmas and definitions here
+are kept to prevent merge-conflicts.\<close>
 
-lemma zfact_iso_0:
-  assumes "n > 0"
-  shows "zfact_iso n 0 = \<zero>\<^bsub>ZFact (int n)\<^esub>"
-proof -
-  let ?I = "Idl\<^bsub>\<Z>\<^esub> {int n}"
-  have ideal_I: "ideal ?I \<Z>"
-    by (simp add: int.genideal_ideal)
+lemmas zfact_iso_0 = zfact_iso_0
+lemmas zfact_prime_is_field = zfact_prime_is_field
 
-  interpret i:ideal "?I" "\<Z>" using ideal_I by simp
-  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) ?I"
-   using i.rcos_ring_hom_ring ZFact_def by auto
-
-  show ?thesis
-    by (simp add:zfact_iso_def ZFact_def)
-qed
-
-lemma zfact_prime_is_field:
-  assumes "Factorial_Ring.prime (p :: nat)"
-  shows "field (ZFact (int p))"
-  using zfact_prime_is_finite_field[OF assms] finite_field_def by auto
+hide_const (open) Multiset.mult
 
 definition mod_ring :: "nat => nat ring"
   where "mod_ring n = \<lparr>
     carrier = {..<n},
     mult = (\<lambda> x y. (x * y) mod n),
     one = 1,
     zero = 0,
     add = (\<lambda> x y. (x + y) mod n) \<rparr>"
 
 definition zfact_iso_inv :: "nat \<Rightarrow> int set \<Rightarrow> nat" where
   "zfact_iso_inv p = inv_into {..<p} (zfact_iso p)"
 
+lemma zfact_iso_inv_compat:
+  assumes "n > 0"
+  assumes "x \<in> carrier (ZFact (int n))"
+  shows "zfact_iso_inv n x = Finite_Fields_Mod_Ring_Code.zfact_iso_inv n x"
+proof -
+  have "Finite_Fields_Mod_Ring_Code.zfact_iso_inv n x \<in> {..<n}"
+    using bij_betw_apply[OF zfact_iso_inv_bij[OF assms(1)] assms(2)]
+    by (simp add:Finite_Fields_Mod_Ring_Code.mod_ring_def ring_of_def)
+  moreover have "zfact_iso n (Finite_Fields_Mod_Ring_Code.zfact_iso_inv n x) = x"
+    unfolding Finite_Fields_Mod_Ring_Code.zfact_iso_inv_def
+    using zfact_iso_bij[OF assms(1)] assms(2)
+    by (intro f_the_inv_into_f) (simp_all add:bij_betw_def)
+  ultimately show ?thesis
+    unfolding zfact_iso_inv_def by (intro inv_into_f_eq zfact_iso_inj assms) auto
+qed
+
+lemma mod_ring_compat:
+  "mod_ring n = ring_of (Finite_Fields_Mod_Ring_Code.mod_ring n)"
+  unfolding mod_ring_def Finite_Fields_Mod_Ring_Code.mod_ring_def ring_of_def by auto
+
 lemma zfact_iso_inv_0:
   assumes n_ge_0: "n > 0"
-  shows "zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> = 0"
-  unfolding zfact_iso_inv_def zfact_iso_0[OF n_ge_0, symmetric] using n_ge_0
-  by (rule inv_into_f_f[OF zfact_iso_inj], simp add:mod_ring_def)
+  shows "zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> = 0" (is "?L = ?R")
+proof -
+  interpret r:cring "(ZFact (int n))" using ZFact_is_cring by simp
+
+  have "?L = Finite_Fields_Mod_Ring_Code.zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub>"
+    by (intro zfact_iso_inv_compat[OF assms]) simp
+  also have "... = 0" using zfact_iso_inv_0[OF assms] by simp
+  finally show ?thesis by simp
+qed
 
 lemma zfact_coset:
   assumes n_ge_0: "n > 0"
   assumes "x \<in> carrier (ZFact (int n))"
   defines "I \<equiv> Idl\<^bsub>\<Z>\<^esub> {int n}"
   shows "x = I +>\<^bsub>\<Z>\<^esub> (int (zfact_iso_inv n x))"
 proof -
-  have "x \<in> zfact_iso n ` {..<n}"
-    using assms zfact_iso_ran by simp
-  hence "zfact_iso n (zfact_iso_inv n x) = x"
-    unfolding zfact_iso_inv_def by (rule f_inv_into_f)
-  thus ?thesis unfolding zfact_iso_def I_def by blast
+  have "x = I +>\<^bsub>\<Z>\<^esub> (int (Finite_Fields_Mod_Ring_Code.zfact_iso_inv n x))"
+    unfolding I_def by (intro zfact_coset[OF assms(1,2)])
+  also have "... = I +>\<^bsub>\<Z>\<^esub> (int (zfact_iso_inv n x))"
+    using zfact_iso_inv_compat[OF assms(1,2)] by simp
+  finally show ?thesis by simp
 qed
 
 lemma zfact_iso_inv_is_ring_iso:
   assumes n_ge_1: "n > 1"
   shows "zfact_iso_inv n \<in> ring_iso (ZFact (int n)) (mod_ring n)"
-proof (rule ring_iso_memI)
-  interpret r:cring "(ZFact (int n))"
-    using ZFact_is_cring by simp
-
-  define I where "I = Idl\<^bsub>\<Z>\<^esub> {int n}"
-
-  have n_ge_0: "n > 0" using n_ge_1 by simp
-
-  interpret i:ideal "I" "\<Z>"
-    unfolding I_def using int.genideal_ideal by simp
-
-  interpret s:ring_hom_ring "\<Z>" "ZFact (int n)" "(+>\<^bsub>\<Z>\<^esub>) I"
-   using i.rcos_ring_hom_ring ZFact_def I_def by auto
-
-  show
-    "\<And>x. x \<in> carrier (ZFact (int n)) \<Longrightarrow> zfact_iso_inv n x \<in> carrier (mod_ring n)"
-  proof -
-    fix x
-    assume "x \<in> carrier (ZFact (int n))"
-    hence "zfact_iso_inv n x \<in> {..<n}"
-      unfolding zfact_iso_inv_def
-      using zfact_iso_ran[OF n_ge_0] inv_into_into by metis
-
-    thus "zfact_iso_inv n x \<in> carrier (mod_ring n)"
-      unfolding mod_ring_def by simp
-  qed
+proof -
+  interpret r:cring "(ZFact (int n))" using ZFact_is_cring by simp
 
-  show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
-    zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
-    zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
-  proof -
-    fix x y
-    assume x_carr: "x \<in> carrier (ZFact (int n))"
-    define x' where "x' = zfact_iso_inv n x"
-    assume y_carr: "y \<in> carrier (ZFact (int n))"
-    define y' where "y' = zfact_iso_inv n y"
-    have "x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<otimes>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
-      unfolding x'_def y'_def
-      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' * int y'))"
-      by simp
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' * y') mod n)))"
-      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<otimes>\<^bsub>mod_ring n\<^esub> y'))"
-      unfolding mod_ring_def by simp
-    also have "... = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
-      unfolding zfact_iso_def I_def by simp
-    finally have a:"x \<otimes>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')"
-      by simp
-    have b:"x' \<otimes>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
-      using mod_ring_def n_ge_0 by auto
-    have "zfact_iso_inv n (zfact_iso n (x' \<otimes>\<^bsub>mod_ring n\<^esub> y')) = x' \<otimes>\<^bsub>mod_ring n\<^esub> y'"
-      unfolding zfact_iso_inv_def
-      by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
-    thus
-      "zfact_iso_inv n (x \<otimes>\<^bsub>ZFact (int n)\<^esub> y) =
-      zfact_iso_inv n x \<otimes>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
-      using a x'_def y'_def by simp
-  qed
-
-  show "\<And>x y. x \<in> carrier (ZFact (int n)) \<Longrightarrow> y \<in> carrier (ZFact (int n)) \<Longrightarrow>
-    zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
-    zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
-  proof -
-    fix x y
-    assume x_carr: "x \<in> carrier (ZFact (int n))"
-    define x' where "x' = zfact_iso_inv n x"
-    assume y_carr: "y \<in> carrier (ZFact (int n))"
-    define y' where "y' = zfact_iso_inv n y"
-    have "x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = (I +>\<^bsub>\<Z>\<^esub> (int x')) \<oplus>\<^bsub>ZFact (int n)\<^esub> (I +>\<^bsub>\<Z>\<^esub> (int y'))"
-      unfolding x'_def y'_def
-      using x_carr y_carr zfact_coset[OF n_ge_0] I_def by simp
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int x' + int y'))"
-      by simp
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (int ((x' + y') mod n)))"
-      unfolding I_def zmod_int by (rule int_cosetI[OF n_ge_0],simp)
-    also have "... = (I +>\<^bsub>\<Z>\<^esub> (x' \<oplus>\<^bsub>mod_ring n\<^esub> y'))"
-      unfolding mod_ring_def by simp
-    also have "... = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
-      unfolding zfact_iso_def I_def by simp
-    finally have a:"x \<oplus>\<^bsub>ZFact (int n)\<^esub> y = zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')"
-      by simp
-    have b:"x' \<oplus>\<^bsub>mod_ring n\<^esub> y' \<in> {..<n}"
-      using mod_ring_def n_ge_0 by auto
-    have "zfact_iso_inv n (zfact_iso n (x' \<oplus>\<^bsub>mod_ring n\<^esub> y')) = x' \<oplus>\<^bsub>mod_ring n\<^esub> y'"
-      unfolding zfact_iso_inv_def
-      by (rule inv_into_f_f[OF zfact_iso_inj[OF n_ge_0] b])
-    thus
-      "zfact_iso_inv n (x \<oplus>\<^bsub>ZFact (int n)\<^esub> y) =
-      zfact_iso_inv n x \<oplus>\<^bsub>mod_ring n\<^esub> zfact_iso_inv n y"
-      using a x'_def y'_def by simp
-  qed
-
-  have "\<one>\<^bsub>ZFact (int n)\<^esub> = zfact_iso n (\<one>\<^bsub>mod_ring n\<^esub>)"
-    by (simp add:zfact_iso_def ZFact_def I_def[symmetric] mod_ring_def)
-
-  thus "zfact_iso_inv n \<one>\<^bsub>ZFact (int n)\<^esub> = \<one>\<^bsub>mod_ring n\<^esub>"
-    unfolding zfact_iso_inv_def mod_ring_def
-    using inv_into_f_f[OF zfact_iso_inj] n_ge_1 by simp
-
-  show "bij_betw (zfact_iso_inv n) (carrier (ZFact (int n))) (carrier (mod_ring n))"
-    using zfact_iso_inv_def mod_ring_def zfact_iso_bij[OF n_ge_0] bij_betw_inv_into
-    by force
+  show ?thesis
+    unfolding mod_ring_compat using assms
+    by (intro r.ring_iso_restrict[OF zfact_iso_inv_is_ring_iso[OF n_ge_1]]
+        zfact_iso_inv_compat[symmetric]) auto
 qed
 
 lemma mod_ring_finite:
   "finite (carrier (mod_ring n))"
-  by (simp add:mod_ring_def)
+  using mod_ring_finite mod_ring_compat by auto
 
 lemma mod_ring_carr:
   "x \<in> carrier (mod_ring n) \<longleftrightarrow>  x < n"
-  by (simp add:mod_ring_def)
+  using mod_ring_carr mod_ring_compat by auto
 
 lemma mod_ring_is_cring:
   assumes n_ge_1: "n > 1"
   shows "cring (mod_ring n)"
-proof -
-  have n_ge_0: "n > 0" using n_ge_1 by simp
-
-  interpret cring "ZFact (int n)"
-    using ZFact_is_cring by simp
-
-  have "cring ((mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr>)"
-    by (rule ring_iso_imp_img_cring[OF zfact_iso_inv_is_ring_iso[OF n_ge_1]])
-  moreover have
-    "(mod_ring n) \<lparr> zero := zfact_iso_inv n \<zero>\<^bsub>ZFact (int n)\<^esub> \<rparr> = mod_ring n"
-    using zfact_iso_inv_0[OF n_ge_0]
-    by (simp add:mod_ring_def)
-  ultimately show ?thesis by simp
-qed
+  using mod_ring_is_cring[OF assms] mod_ring_compat by auto
 
 lemma zfact_iso_is_ring_iso:
   assumes n_ge_1: "n > 1"
   shows "zfact_iso n \<in> ring_iso (mod_ring n) (ZFact (int n))"
-proof -
-  have r:"ring (ZFact (int n))"
-    using ZFact_is_cring cring.axioms(1) by blast
-
-  interpret s: ring "(mod_ring n)"
-    using mod_ring_is_cring cring.axioms(1) n_ge_1 by blast
-  have n_ge_0: "n > 0" using n_ge_1 by linarith
-
-  have
-    "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n)
-      \<in> ring_iso (mod_ring n) (ZFact (int n))"
-    using ring_iso_set_sym[OF r zfact_iso_inv_is_ring_iso[OF n_ge_1]] by simp
-  moreover have "\<And>x. x \<in> carrier (mod_ring n) \<Longrightarrow>
-    inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
-  proof -
-    fix x
-    assume "x \<in> carrier (mod_ring n)"
-    hence "x \<in> {..<n}" by (simp add:mod_ring_def)
-    thus "inv_into (carrier (ZFact (int n))) (zfact_iso_inv n) x = zfact_iso n x"
-      unfolding zfact_iso_inv_def
-      by (simp add:inv_into_inv_into_eq[OF zfact_iso_bij[OF n_ge_0]])
-  qed
-
-  ultimately show ?thesis
-    using s.ring_iso_restrict by blast
-qed
+  using zfact_iso_is_ring_iso[OF assms] mod_ring_compat by auto
 
 text \<open>If @{term "p"} is a prime than @{term "mod_ring p"} is a field:\<close>
 
 lemma mod_ring_is_field:
   assumes"Factorial_Ring.prime p"
   shows "field (mod_ring p)"
-proof -
-  have p_ge_0: "p > 0" using assms prime_gt_0_nat by blast
-  have p_ge_1: "p > 1" using assms prime_gt_1_nat by blast
-
-  interpret field "ZFact (int p)"
-    using zfact_prime_is_field[OF assms] by simp
-
-  have "field ((mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr>)"
-    by (rule ring_iso_imp_img_field[OF zfact_iso_inv_is_ring_iso[OF p_ge_1]])
-
-  moreover have
-    "(mod_ring p) \<lparr> zero := zfact_iso_inv p \<zero>\<^bsub>ZFact (int p)\<^esub> \<rparr> = mod_ring p"
-    using zfact_iso_inv_0[OF p_ge_0]
-    by (simp add:mod_ring_def)
-  ultimately show ?thesis by simp
-qed
+  using mod_ring_is_field[OF assms] mod_ring_compat by auto
 
 end
diff --git a/thys/Word_Lib/Guide.thy b/thys/Word_Lib/Guide.thy
--- a/thys/Word_Lib/Guide.thy
+++ b/thys/Word_Lib/Guide.thy
@@ -1,432 +1,432 @@
 (*
  * Copyright Florian Haftmann
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 (*<*)
 theory Guide
   imports Word_Lib_Sumo Machine_Word_32 Machine_Word_64
 begin
 
 context semiring_bit_operations
 begin
 
 lemma bit_eq_iff:
   \<open>a = b \<longleftrightarrow> (\<forall>n. 2 ^ n \<noteq> 0 \<longrightarrow> bit a n \<longleftrightarrow> bit b n)\<close>
   using bit_eq_iff [of a b] by (simp add: possible_bit_def)
 
 end
 
 notation (output)  Generic_set_bit.set_bit (\<open>Generic'_set'_bit.set'_bit\<close>)
 
 hide_const (open) Generic_set_bit.set_bit
 
 no_notation bit  (infixl \<open>!!\<close> 100)
 
 (*>*)
 section \<open>A short overview over bit operations and word types\<close>
 
 subsection \<open>Key principles\<close>
 
 text \<open>
   When formalizing bit operations, it is tempting to represent
   bit values as explicit lists over a binary type. This however
   is a bad idea, mainly due to the inherent ambiguities in
   representation concerning repeating leading bits.
 
   Hence this approach avoids such explicit lists altogether
   following an algebraic path:
 
     \<^item> Bit values are represented by numeric types: idealized
       unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
       bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.
 
     \<^item> (A special case are idealized unbounded bit values ending
       in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
       only support a restricted set of operations).
 
   The fundamental principles are developed in theory \<^theory>\<open>HOL.Bit_Operations\<close>
   (which is part of \<^theory>\<open>Main\<close>):
 
     \<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and
 
     \<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.
 
     \<^item> Concerning bounded bit values, iterated shifts to the left
     may result in eliminating all bits by shifting them all
     beyond the boundary.  The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
     represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.
 
     \<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.
 
     \<^item> This leads to the most fundamental properties of bit values:
 
       \<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}
 
-      \<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}
+      \<^item> Induction rule: @{thm [display, mode=iff] bit_induct [where ?'a = int, no_vars]}
 
     \<^item> Characteristic properties @{prop [source] \<open>bit (f x) n \<longleftrightarrow> P x n\<close>}
       are available in fact collection \<^text>\<open>bit_simps\<close>.
 
   On top of this, the following generic operations are provided:
 
     \<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>
 
     \<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}
 
     \<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}
 
     \<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}
 
     \<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}
 
     \<^item> Bitwise negation: @{thm [mode=iff] bit_not_iff_eq [where ?'a = int, no_vars]}
 
     \<^item> Bitwise conjunction: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}
 
     \<^item> Bitwise disjunction: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}
 
     \<^item> Bitwise exclusive disjunction: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}
 
     \<^item> Setting a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Unsetting a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Flipping a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
         @{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}
 
     \<^item> (Bounded) conversion from and to a list of bits:
         @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
 
   Bit concatenation on \<^typ>\<open>int\<close> as given by
     @{thm [display] concat_bit_def [no_vars]}
   appears quite
   technical but is the logical foundation for the quite natural bit concatenation
   on \<^typ>\<open>'a word\<close> (see below).
 \<close>
 
 subsection \<open>Core word theory\<close>
 
 text \<open>
   Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
   the following specific operations:
 
     \<^item> Standard arithmetic:
         @{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
         @{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.
 
     \<^item> Standard bit operations: see above.
 
     \<^item> Conversion with unsigned interpretation of words:
 
         \<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}
 
             \<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Conversion with signed interpretation of words:
 
         \<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Operations with unsigned interpretation of words:
 
         \<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}
 
         \<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}
 
         \<^item> @{thm unat_div_distrib [no_vars]}
 
         \<^item> @{thm unat_drop_bit_eq [no_vars]}
 
         \<^item> @{thm unat_mod_distrib [no_vars]}
 
         \<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}
 
     \<^item> Operations with signed interpretation of words:
 
         \<^item> @{thm [mode=iff] word_sle_eq [no_vars]}
 
         \<^item> @{thm [mode=iff] word_sless_alt [no_vars]}
 
         \<^item> @{thm sint_signed_drop_bit_eq [no_vars]}
 
     \<^item> Rotation and reversal:
 
         \<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}
 
     \<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}
 
   For proofs about words the following default strategies are applicable:
 
     \<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_word_eqI\<close>; fact
       collection \<^text>\<open>bit_simps\<close>).
 
     \<^item> Using the @{method transfer} method.
 \<close>
 
 
 subsection \<open>More library theories\<close>
 
 text \<open>
   Note: currently, most theories listed here are hardly separate
   entities since they import each other in various ways.
   Always inspect them to understand what you pull in if you
   want to import one.
 
     \<^descr>[Syntax]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Syntax_Bundles\<close>]
         Bundles to provide alternative syntax for various bit operations.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
         Printing word numerals as hexadecimal numerals.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
         Pretty type-sensitive syntax for cast operations.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
         Specific ASCII syntax for prominent bit operations on word.
 
     \<^descr>[Proof tools]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
         Rewriting word numerals to normal forms.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
         Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bitwise_Signed\<close>]
         Method @{method word_bitwise_signed} decomposes word equalities and inequalities into bit propositions.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
         Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.
 
     \<^descr>[Operations]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]
 
         Signed division on word:
 
           \<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
           \<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \
 
           \<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]
 
         The least significant bit as an alias:
         @{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]
 
         The most significant bit:
 
           \<^item> @{thm [mode=iff] msb_int_def [of k]}
 
           \<^item> @{thm [mode=iff] word_msb_sint [no_vars]}
 
           \<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}
 
           \<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bit_Shifts_Infix_Syntax\<close>]
 
         Bit shifts decorated with infix syntax:
 
           \<^item> @{thm Bit_Shifts_Infix_Syntax.shiftl_def [no_vars]}
 
           \<^item> @{thm Bit_Shifts_Infix_Syntax.shiftr_def [no_vars]}
 
           \<^item> @{thm Bit_Shifts_Infix_Syntax.sshiftr_def [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \
 
           \<^item> @{thm word_next_unfold [no_vars]}
 
           \<^item> @{thm word_prev_unfold [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]
 
         More on explicit enumeration of word types.
 
       \<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]
 
         Even more operations on word.
 
     \<^descr>[Types]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]
 
           Formal tagging of word types with a \<^text>\<open>signed\<close> marker.
 
     \<^descr>[Lemmas]
 
       \<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]
 
           More lemmas on words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]
 
           More lemmas on words, covering many other theories mentioned here.
 
     \<^descr>[Words of popular lengths].
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]
 
           for 8-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]
 
           for 16-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]
 
           for 32-bit words.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]
 
           for 64-bit words. This theory is not part of  \<^text>\<open>Word_Lib_Sumo\<close>, because it shadows
           names from \<^theory>\<open>Word_Lib.Word_32\<close>. They can be used together, but then will have
           to use qualified names in applications.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Machine_Word_32\<close> and \<^theory>\<open>Word_Lib.Machine_Word_64\<close>]
 
           provide lemmas for 32-bit words and 64-bit words under the same name,
           which can help to organize applications relying on some form
           of genericity.
 \<close>
 
 
 subsection \<open>More library sessions\<close>
 
 text \<open>
   \<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
   It provides a common abstraction that hides the differences between the different target languages.
   The code generator maps these operations to the APIs of the target languages.
 \<close>
 
 subsection \<open>Legacy theories\<close>
 
 text \<open>
   The following theories contain material which has been
   factored out since it is not recommended to use it in
   new applications, mostly because matters can be expressed
   succinctly using already existing operations.
 
   This section gives some indication how to migrate away
   from those theories.  However theorem coverage may still
   be terse in some cases.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]
 
     An entry point importing any relevant theory in that session.  Intended
     for backward compatibility: start importing this theory when
     migrating applications to Isabelle2021, and later sort out
     what you really need. You may need to include
    \<^theory>\<open>Word_Lib.Word_64\<close> separately.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]
 
     Kind of an alias: @{thm set_bit_eq [no_vars]}
 
   \<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]
 
     A low-level extension to HOL typedef providing
     conversions along type morphisms.  The @{method transfer} method
     seems to be sufficient for most applications though.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]
 
     Comprehension syntax for bit values over predicates
     \<^typ>\<open>nat \<Rightarrow> bool\<close>, for \<^typ>\<open>'a::len word\<close>; straightforward
     alternatives exist.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension_Int\<close>]
 
     Comprehension syntax for bit values over predicates
     \<^typ>\<open>nat \<Rightarrow> bool\<close>, for \<^typ>\<open>int\<close>; inherently non-computational.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]
 
     Representation of bit values as explicit list in
     \<^emph>\<open>reversed\<close> order.
 
     This should rarely be necessary: the \<^const>\<open>bit\<close> projection
     should be sufficient in most cases.  In case explicit lists
     are needed, existing operations can be used:
 
     @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
 
   \<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]
 
     Collection of operations and theorems which are kept for backward
     compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
     They are used in applications of \<^text>\<open>Word_Lib\<close>, but should be migrated to there.
 \<close>
 
 section \<open>Changelog\<close>
 
 text \<open>
   \<^descr>[Changes since AFP 2022] ~
 
     \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> has been removed from session.
 
     \<^item> Bit comprehension syntax for \<^typ>\<open>int\<close> moved to separate theory
       \<^theory>\<open>Word_Lib.Bit_Comprehension_Int\<close>.
 
   \<^descr>[Changes since AFP 2021] ~
 
     \<^item> Theory \<^text>\<open>Word_Lib.Ancient_Numeral\<close> is not part of \<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>
       any longer.
 
     \<^item> Infix syntax for \<^term>\<open>(AND)\<close>, \<^term>\<open>(OR)\<close>, \<^term>\<open>(XOR)\<close> organized in
       syntax bundle \<^bundle>\<open>bit_operations_syntax\<close>.
 
     \<^item> Abbreviation \<^abbrev>\<open>max_word\<close> moved from distribution into theory
       \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.
 
     \<^item> Operation \<^const>\<open>test_bit\<close> replaced by input abbreviation \<^abbrev>\<open>test_bit\<close>.
 
     \<^item> Abbreviations \<^abbrev>\<open>bin_nth\<close>, \<^abbrev>\<open>bin_last\<close>, \<^abbrev>\<open>bin_rest\<close>,
       \<^abbrev>\<open>bintrunc\<close>, \<^abbrev>\<open>sbintrunc\<close>, \<^abbrev>\<open>norm_sint\<close>,
       \<^abbrev>\<open>bin_cat\<close> moved into theory \<^theory>\<open>Word_Lib.Legacy_Aliases\<close>.
 
     \<^item> Operations \<^abbrev>\<open>bshiftr1\<close>,
       \<^abbrev>\<open>setBit\<close>, \<^abbrev>\<open>clearBit\<close> moved from distribution into theory
       \<^theory>\<open>Word_Lib.Legacy_Aliases\<close> and replaced by input abbreviations.
 
     \<^item> Operations \<^const>\<open>shiftl1\<close>, \<^const>\<open>shiftr1\<close>, \<^const>\<open>sshiftr1\<close>
       moved here from distribution.
 
     \<^item> Operation \<^const>\<open>complement\<close> replaced by input abbreviation \<^abbrev>\<open>complement\<close>.
 \<close>
 
 (*<*)
 end
 (*>*)
diff --git a/thys/Word_Lib/Reversed_Bit_Lists.thy b/thys/Word_Lib/Reversed_Bit_Lists.thy
--- a/thys/Word_Lib/Reversed_Bit_Lists.thy
+++ b/thys/Word_Lib/Reversed_Bit_Lists.thy
@@ -1,2229 +1,2228 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 (* Author: Jeremy Dawson, NICTA *)
 
 section \<open>Bit values as reversed lists of bools\<close>
 
 theory Reversed_Bit_Lists
   imports
     "HOL-Library.Word"
     Typedef_Morphisms
     Least_significant_bit
     Most_significant_bit
     Even_More_List
     "HOL-Library.Sublist"
     Aligned
     Singleton_Bit_Shifts
     Legacy_Aliases
 begin
 
 context
   includes bit_operations_syntax
 begin
 
 lemma horner_sum_of_bool_2_concat:
   \<open>horner_sum of_bool 2 (concat (map (\<lambda>x. map (bit x) [0..<LENGTH('a)]) ws)) = horner_sum uint (2 ^ LENGTH('a)) ws\<close>
   for ws :: \<open>'a::len word list\<close>
 proof (induction ws)
   case Nil
   then show ?case
     by simp
 next
   case (Cons w ws)
   moreover have \<open>horner_sum of_bool 2 (map (bit w) [0..<LENGTH('a)]) = uint w\<close>
   proof transfer
     fix k :: int
     have \<open>map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)]
       = map (bit k) [0..<LENGTH('a)]\<close>
       by simp
     then show \<open>horner_sum of_bool 2 (map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)])
       = take_bit LENGTH('a) k\<close>
       by (simp only: horner_sum_bit_eq_take_bit)
   qed
   ultimately show ?case
     by (simp add: horner_sum_append)
 qed
 
 
 subsection \<open>Implicit augmentation of list prefixes\<close>
 
 primrec takefill :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
     Z: "takefill fill 0 xs = []"
   | Suc: "takefill fill (Suc n) xs =
       (case xs of
         [] \<Rightarrow> fill # takefill fill n xs
       | y # ys \<Rightarrow> y # takefill fill n ys)"
 
 lemma nth_takefill: "m < n \<Longrightarrow> takefill fill n l ! m = (if m < length l then l ! m else fill)"
   apply (induct n arbitrary: m l)
    apply clarsimp
   apply clarsimp
   apply (case_tac m)
    apply (simp split: list.split)
   apply (simp split: list.split)
   done
 
 lemma takefill_alt: "takefill fill n l = take n l @ replicate (n - length l) fill"
   by (induct n arbitrary: l) (auto split: list.split)
 
 lemma takefill_replicate [simp]: "takefill fill n (replicate m fill) = replicate n fill"
   by (simp add: takefill_alt replicate_add [symmetric])
 
 lemma takefill_le': "n = m + k \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
   by (induct m arbitrary: l n) (auto split: list.split)
 
 lemma length_takefill [simp]: "length (takefill fill n l) = n"
   by (simp add: takefill_alt)
 
 lemma take_takefill': "n = k + m \<Longrightarrow> take k (takefill fill n w) = takefill fill k w"
   by (induct k arbitrary: w n) (auto split: list.split)
 
 lemma drop_takefill: "drop k (takefill fill (m + k) w) = takefill fill m (drop k w)"
   by (induct k arbitrary: w) (auto split: list.split)
 
 lemma takefill_le [simp]: "m \<le> n \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
   by (auto simp: le_iff_add takefill_le')
 
 lemma take_takefill [simp]: "m \<le> n \<Longrightarrow> take m (takefill fill n w) = takefill fill m w"
   by (auto simp: le_iff_add take_takefill')
 
 lemma takefill_append: "takefill fill (m + length xs) (xs @ w) = xs @ (takefill fill m w)"
   by (induct xs) auto
 
 lemma takefill_same': "l = length xs \<Longrightarrow> takefill fill l xs = xs"
   by (induct xs arbitrary: l) auto
 
 lemmas takefill_same [simp] = takefill_same' [OF refl]
 
 lemma tf_rev:
   "n + k = m + length bl \<Longrightarrow> takefill x m (rev (takefill y n bl)) =
     rev (takefill y m (rev (takefill x k (rev bl))))"
   apply (rule nth_equalityI)
    apply (auto simp add: nth_takefill rev_nth)
   apply (rule_tac f = "\<lambda>n. bl ! n" in arg_cong)
   apply arith
   done
 
 lemma takefill_minus: "0 < n \<Longrightarrow> takefill fill (Suc (n - 1)) w = takefill fill n w"
   by auto
 
 lemmas takefill_Suc_cases =
   list.cases [THEN takefill.Suc [THEN trans]]
 
 lemmas takefill_Suc_Nil = takefill_Suc_cases (1)
 lemmas takefill_Suc_Cons = takefill_Suc_cases (2)
 
 lemmas takefill_minus_simps = takefill_Suc_cases [THEN [2]
   takefill_minus [symmetric, THEN trans]]
 
 lemma takefill_numeral_Nil [simp]:
   "takefill fill (numeral k) [] = fill # takefill fill (pred_numeral k) []"
   by (simp add: numeral_eq_Suc)
 
 lemma takefill_numeral_Cons [simp]:
   "takefill fill (numeral k) (x # xs) = x # takefill fill (pred_numeral k) xs"
   by (simp add: numeral_eq_Suc)
 
 
 subsection \<open>Range projection\<close>
 
 definition bl_of_nth :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
   where "bl_of_nth n f = map f (rev [0..<n])"
 
 lemma bl_of_nth_simps [simp, code]:
   "bl_of_nth 0 f = []"
   "bl_of_nth (Suc n) f = f n # bl_of_nth n f"
   by (simp_all add: bl_of_nth_def)
 
 lemma length_bl_of_nth [simp]: "length (bl_of_nth n f) = n"
   by (simp add: bl_of_nth_def)
 
 lemma nth_bl_of_nth [simp]: "m < n \<Longrightarrow> rev (bl_of_nth n f) ! m = f m"
   by (simp add: bl_of_nth_def rev_map)
 
 lemma bl_of_nth_inj: "(\<And>k. k < n \<Longrightarrow> f k = g k) \<Longrightarrow> bl_of_nth n f = bl_of_nth n g"
   by (simp add: bl_of_nth_def)
 
 lemma bl_of_nth_nth_le: "n \<le> length xs \<Longrightarrow> bl_of_nth n (nth (rev xs)) = drop (length xs - n) xs"
   apply (induct n arbitrary: xs)
    apply clarsimp
   apply clarsimp
   apply (rule trans [OF _ hd_Cons_tl])
    apply (frule Suc_le_lessD)
    apply (simp add: rev_nth trans [OF drop_Suc drop_tl, symmetric])
    apply (subst hd_drop_conv_nth)
     apply force
    apply simp_all
   apply (rule_tac f = "\<lambda>n. drop n xs" in arg_cong)
   apply simp
   done
 
 lemma bl_of_nth_nth [simp]: "bl_of_nth (length xs) ((!) (rev xs)) = xs"
   by (simp add: bl_of_nth_nth_le)
 
 
 subsection \<open>More\<close>
 
 definition rotater1 :: "'a list \<Rightarrow> 'a list"
   where "rotater1 ys =
     (case ys of [] \<Rightarrow> [] | x # xs \<Rightarrow> last ys # butlast ys)"
 
 definition rotater :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
   where "rotater n = rotater1 ^^ n"
 
 lemmas rotater_0' [simp] = rotater_def [where n = "0", simplified]
 
 lemma rotate1_rl': "rotater1 (l @ [a]) = a # l"
   by (cases l) (auto simp: rotater1_def)
 
 lemma rotate1_rl [simp] : "rotater1 (rotate1 l) = l"
   apply (unfold rotater1_def)
   apply (cases "l")
    apply (case_tac [2] "list")
     apply auto
   done
 
 lemma rotate1_lr [simp] : "rotate1 (rotater1 l) = l"
   by (cases l) (auto simp: rotater1_def)
 
 lemma rotater1_rev': "rotater1 (rev xs) = rev (rotate1 xs)"
   by (cases "xs") (simp add: rotater1_def, simp add: rotate1_rl')
 
 lemma rotater_rev': "rotater n (rev xs) = rev (rotate n xs)"
   by (induct n) (auto simp: rotater_def intro: rotater1_rev')
 
 lemma rotater_rev: "rotater n ys = rev (rotate n (rev ys))"
   using rotater_rev' [where xs = "rev ys"] by simp
 
 lemma rotater_drop_take:
   "rotater n xs =
     drop (length xs - n mod length xs) xs @
     take (length xs - n mod length xs) xs"
   by (auto simp: rotater_rev rotate_drop_take rev_take rev_drop)
 
 lemma rotater_Suc [simp]: "rotater (Suc n) xs = rotater1 (rotater n xs)"
   unfolding rotater_def by auto
 
 lemma nth_rotater:
   \<open>rotater m xs ! n = xs ! ((n + (length xs - m mod length xs)) mod length xs)\<close> if \<open>n < length xs\<close>
   using that by (simp add: rotater_drop_take nth_append not_less less_diff_conv ac_simps le_mod_geq)
 
 lemma nth_rotater1:
   \<open>rotater1 xs ! n = xs ! ((n + (length xs - 1)) mod length xs)\<close> if \<open>n < length xs\<close>
   using that nth_rotater [of n xs 1] by simp
 
 lemma rotate_inv_plus [rule_format]:
   "\<forall>k. k = m + n \<longrightarrow> rotater k (rotate n xs) = rotater m xs \<and>
     rotate k (rotater n xs) = rotate m xs \<and>
     rotater n (rotate k xs) = rotate m xs \<and>
     rotate n (rotater k xs) = rotater m xs"
   by (induct n) (auto simp: rotater_def rotate_def intro: funpow_swap1 [THEN trans])
 
 lemmas rotate_inv_rel = le_add_diff_inverse2 [symmetric, THEN rotate_inv_plus]
 
 lemmas rotate_inv_eq = order_refl [THEN rotate_inv_rel, simplified]
 
 lemmas rotate_lr [simp] = rotate_inv_eq [THEN conjunct1]
 lemmas rotate_rl [simp] = rotate_inv_eq [THEN conjunct2, THEN conjunct1]
 
 lemma rotate_gal: "rotater n xs = ys \<longleftrightarrow> rotate n ys = xs"
   by auto
 
 lemma rotate_gal': "ys = rotater n xs \<longleftrightarrow> xs = rotate n ys"
   by auto
 
 lemma length_rotater [simp]: "length (rotater n xs) = length xs"
   by (simp add : rotater_rev)
 
 lemma rotate_eq_mod: "m mod length xs = n mod length xs \<Longrightarrow> rotate m xs = rotate n xs"
   apply (rule box_equals)
     defer
     apply (rule rotate_conv_mod [symmetric])+
   apply simp
   done
 
 lemma restrict_to_left: "x = y \<Longrightarrow> x = z \<longleftrightarrow> y = z"
   by simp
 
 lemmas rotate_eqs =
   trans [OF rotate0 [THEN fun_cong] id_apply]
   rotate_rotate [symmetric]
   rotate_id
   rotate_conv_mod
   rotate_eq_mod
 
 lemmas rrs0 = rotate_eqs [THEN restrict_to_left,
   simplified rotate_gal [symmetric] rotate_gal' [symmetric]]
 lemmas rrs1 = rrs0 [THEN refl [THEN rev_iffD1]]
 lemmas rotater_eqs = rrs1 [simplified length_rotater]
 lemmas rotater_0 = rotater_eqs (1)
 lemmas rotater_add = rotater_eqs (2)
 
 lemma butlast_map: "xs \<noteq> [] \<Longrightarrow> butlast (map f xs) = map f (butlast xs)"
   by (induct xs) auto
 
 lemma rotater1_map: "rotater1 (map f xs) = map f (rotater1 xs)"
   by (cases xs) (auto simp: rotater1_def last_map butlast_map)
 
 lemma rotater_map: "rotater n (map f xs) = map f (rotater n xs)"
   by (induct n) (auto simp: rotater_def rotater1_map)
 
 lemma but_last_zip [rule_format] :
   "\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
     last (zip xs ys) = (last xs, last ys) \<and>
     butlast (zip xs ys) = zip (butlast xs) (butlast ys)"
   apply (induct xs)
    apply auto
      apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
   done
 
 lemma but_last_map2 [rule_format] :
   "\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
     last (map2 f xs ys) = f (last xs) (last ys) \<and>
     butlast (map2 f xs ys) = map2 f (butlast xs) (butlast ys)"
   apply (induct xs)
    apply auto
      apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
   done
 
 lemma rotater1_zip:
   "length xs = length ys \<Longrightarrow>
     rotater1 (zip xs ys) = zip (rotater1 xs) (rotater1 ys)"
   apply (unfold rotater1_def)
   apply (cases xs)
    apply auto
    apply ((case_tac ys, auto simp: neq_Nil_conv but_last_zip)[1])+
   done
 
 lemma rotater1_map2:
   "length xs = length ys \<Longrightarrow>
     rotater1 (map2 f xs ys) = map2 f (rotater1 xs) (rotater1 ys)"
   by (simp add: rotater1_map rotater1_zip)
 
 lemmas lrth =
   box_equals [OF asm_rl length_rotater [symmetric]
                  length_rotater [symmetric],
               THEN rotater1_map2]
 
 lemma rotater_map2:
   "length xs = length ys \<Longrightarrow>
     rotater n (map2 f xs ys) = map2 f (rotater n xs) (rotater n ys)"
   by (induct n) (auto intro!: lrth)
 
 lemma rotate1_map2:
   "length xs = length ys \<Longrightarrow>
     rotate1 (map2 f xs ys) = map2 f (rotate1 xs) (rotate1 ys)"
   by (cases xs; cases ys) auto
 
 lemmas lth = box_equals [OF asm_rl length_rotate [symmetric]
   length_rotate [symmetric], THEN rotate1_map2]
 
 lemma rotate_map2:
   "length xs = length ys \<Longrightarrow>
     rotate n (map2 f xs ys) = map2 f (rotate n xs) (rotate n ys)"
   by (induct n) (auto intro!: lth)
 
 
 subsection \<open>Explicit bit representation of \<^typ>\<open>int\<close>\<close>
 
 primrec bl_to_bin_aux :: "bool list \<Rightarrow> int \<Rightarrow> int"
   where
     Nil: "bl_to_bin_aux [] w = w"
   | Cons: "bl_to_bin_aux (b # bs) w = bl_to_bin_aux bs (of_bool b + 2 * w)"
 
 definition bl_to_bin :: "bool list \<Rightarrow> int"
   where "bl_to_bin bs = bl_to_bin_aux bs 0"
 
 primrec bin_to_bl_aux :: "nat \<Rightarrow> int \<Rightarrow> bool list \<Rightarrow> bool list"
   where
     Z: "bin_to_bl_aux 0 w bl = bl"
   | Suc: "bin_to_bl_aux (Suc n) w bl = bin_to_bl_aux n (w div 2) (odd w # bl)"
 
 definition bin_to_bl :: "nat \<Rightarrow> int \<Rightarrow> bool list"
   where "bin_to_bl n w = bin_to_bl_aux n w []"
 
 lemma bin_to_bl_aux_zero_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n 0 bl = bin_to_bl_aux (n - 1) 0 (False # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_minus1_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n (- 1) bl = bin_to_bl_aux (n - 1) (- 1) (True # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_one_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n 1 bl = bin_to_bl_aux (n - 1) 0 (True # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_Bit0_minus_simp [simp]:
   "0 < n \<Longrightarrow>
     bin_to_bl_aux n (numeral (Num.Bit0 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (False # bl)"
   by (cases n) simp_all
 
 lemma bin_to_bl_aux_Bit1_minus_simp [simp]:
   "0 < n \<Longrightarrow>
     bin_to_bl_aux n (numeral (Num.Bit1 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (True # bl)"
   by (cases n) simp_all
 
 lemma bl_to_bin_aux_append: "bl_to_bin_aux (bs @ cs) w = bl_to_bin_aux cs (bl_to_bin_aux bs w)"
   by (induct bs arbitrary: w) auto
 
 lemma bin_to_bl_aux_append: "bin_to_bl_aux n w bs @ cs = bin_to_bl_aux n w (bs @ cs)"
   by (induct n arbitrary: w bs) auto
 
 lemma bl_to_bin_append: "bl_to_bin (bs @ cs) = bl_to_bin_aux cs (bl_to_bin bs)"
   unfolding bl_to_bin_def by (rule bl_to_bin_aux_append)
 
 lemma bin_to_bl_aux_alt: "bin_to_bl_aux n w bs = bin_to_bl n w @ bs"
   by (simp add: bin_to_bl_def bin_to_bl_aux_append)
 
 lemma bin_to_bl_0 [simp]: "bin_to_bl 0 bs = []"
   by (auto simp: bin_to_bl_def)
 
 lemma size_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
   by (induct n arbitrary: w bs) auto
 
 lemma size_bin_to_bl [simp]: "length (bin_to_bl n w) = n"
   by (simp add: bin_to_bl_def size_bin_to_bl_aux)
 
 lemma bl_bin_bl': "bin_to_bl (n + length bs) (bl_to_bin_aux bs w) = bin_to_bl_aux n w bs"
   apply (induct bs arbitrary: w n)
    apply auto
     apply (simp_all only: add_Suc [symmetric])
     apply (auto simp add: bin_to_bl_def)
   done
 
 lemma bl_bin_bl [simp]: "bin_to_bl (length bs) (bl_to_bin bs) = bs"
   unfolding bl_to_bin_def
   apply (rule box_equals)
     apply (rule bl_bin_bl')
    prefer 2
    apply (rule bin_to_bl_aux.Z)
   apply simp
   done
 
 lemma bl_to_bin_inj: "bl_to_bin bs = bl_to_bin cs \<Longrightarrow> length bs = length cs \<Longrightarrow> bs = cs"
   apply (rule_tac box_equals)
     defer
     apply (rule bl_bin_bl)
    apply (rule bl_bin_bl)
   apply simp
   done
 
 lemma bl_to_bin_False [simp]: "bl_to_bin (False # bl) = bl_to_bin bl"
   by (auto simp: bl_to_bin_def)
 
 lemma bl_to_bin_Nil [simp]: "bl_to_bin [] = 0"
   by (auto simp: bl_to_bin_def)
 
 lemma bin_to_bl_zero_aux: "bin_to_bl_aux n 0 bl = replicate n False @ bl"
   by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)
 
 lemma bin_to_bl_zero: "bin_to_bl n 0 = replicate n False"
   by (simp add: bin_to_bl_def bin_to_bl_zero_aux)
 
 lemma bin_to_bl_minus1_aux: "bin_to_bl_aux n (- 1) bl = replicate n True @ bl"
   by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)
 
 lemma bin_to_bl_minus1: "bin_to_bl n (- 1) = replicate n True"
   by (simp add: bin_to_bl_def bin_to_bl_minus1_aux)
 
 
 subsection \<open>Semantic interpretation of \<^typ>\<open>bool list\<close> as \<^typ>\<open>int\<close>\<close>
 
 lemma bin_bl_bin': "bl_to_bin (bin_to_bl_aux n w bs) = bl_to_bin_aux bs (take_bit n w)"
   by (induct n arbitrary: w bs) (auto simp: bl_to_bin_def take_bit_Suc ac_simps mod_2_eq_odd)
 
 lemma bin_bl_bin [simp]: "bl_to_bin (bin_to_bl n w) = take_bit n w"
   by (auto simp: bin_to_bl_def bin_bl_bin')
 
 lemma bl_to_bin_rep_F: "bl_to_bin (replicate n False @ bl) = bl_to_bin bl"
   by (simp add: bin_to_bl_zero_aux [symmetric] bin_bl_bin') (simp add: bl_to_bin_def)
 
 lemma bin_to_bl_trunc [simp]: "n \<le> m \<Longrightarrow> bin_to_bl n (take_bit m w) = bin_to_bl n w"
   by (auto intro: bl_to_bin_inj)
 
 lemma bin_to_bl_aux_bintr:
   "bin_to_bl_aux n (take_bit m bin) bl =
     replicate (n - m) False @ bin_to_bl_aux (min n m) bin bl"
   apply (induct n arbitrary: m bin bl)
    apply clarsimp
   apply clarsimp
   apply (case_tac "m")
    apply (clarsimp simp: bin_to_bl_zero_aux)
    apply (erule thin_rl)
    apply (induct_tac n)
     apply (auto simp add: take_bit_Suc)
   done
 
 lemma bin_to_bl_bintr:
   "bin_to_bl n (take_bit m bin) = replicate (n - m) False @ bin_to_bl (min n m) bin"
   unfolding bin_to_bl_def by (rule bin_to_bl_aux_bintr)
 
 lemma bl_to_bin_rep_False: "bl_to_bin (replicate n False) = 0"
   by (induct n) auto
 
 lemma len_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
   by (fact size_bin_to_bl_aux)
 
 lemma len_bin_to_bl: "length (bin_to_bl n w) = n"
   by (fact size_bin_to_bl) (* FIXME: duplicate *)
 
 lemma sign_bl_bin': "bin_sign (bl_to_bin_aux bs w) = bin_sign w"
   by (induction bs arbitrary: w) (simp_all add: bin_sign_def)
 
 lemma sign_bl_bin: "bin_sign (bl_to_bin bs) = 0"
   by (simp add: bl_to_bin_def sign_bl_bin')
 
 lemma bl_sbin_sign_aux: "hd (bin_to_bl_aux (Suc n) w bs) = (bin_sign (signed_take_bit n w) = -1)"
   by (induction n arbitrary: w bs) (auto simp add: bin_sign_def even_iff_mod_2_eq_zero bit_Suc)
 
 lemma bl_sbin_sign: "hd (bin_to_bl (Suc n) w) = (bin_sign (signed_take_bit n w) = -1)"
   unfolding bin_to_bl_def by (rule bl_sbin_sign_aux)
 
 lemma bin_nth_of_bl_aux:
   "bit (bl_to_bin_aux bl w) n =
     (n < size bl \<and> rev bl ! n \<or> n \<ge> length bl \<and> bit w (n - size bl))"
   apply (induction bl arbitrary: w)
    apply simp_all
   apply safe
                       apply (simp_all add: not_le nth_append bit_double_iff even_bit_succ_iff split: if_splits)
   done
 
 lemma bin_nth_of_bl: "bit (bl_to_bin bl) n = (n < length bl \<and> rev bl ! n)"
   by (simp add: bl_to_bin_def bin_nth_of_bl_aux)
 
 lemma bin_nth_bl: "n < m \<Longrightarrow> bit w n = nth (rev (bin_to_bl m w)) n"
   by (metis bin_bl_bin bin_nth_of_bl nth_bintr size_bin_to_bl)
 
 lemma nth_bin_to_bl_aux:
   "n < m + length bl \<Longrightarrow> (bin_to_bl_aux m w bl) ! n =
     (if n < m then bit w (m - 1 - n) else bl ! (n - m))"
   apply (induction bl arbitrary: w)
    apply simp_all
    apply (simp add: bin_nth_bl [of \<open>m - Suc n\<close> m] rev_nth flip: bin_to_bl_def)
    apply (metis One_nat_def Suc_pred add_diff_cancel_left'
      add_diff_cancel_right' bin_to_bl_aux_alt bin_to_bl_def
      diff_Suc_Suc diff_is_0_eq diff_zero less_Suc_eq_0_disj
      less_antisym less_imp_Suc_add list.size(3) nat_less_le nth_append size_bin_to_bl_aux)
   done
 
 lemma nth_bin_to_bl: "n < m \<Longrightarrow> (bin_to_bl m w) ! n = bit w (m - Suc n)"
   by (simp add: bin_to_bl_def nth_bin_to_bl_aux)
 
 lemma takefill_bintrunc: "takefill False n bl = rev (bin_to_bl n (bl_to_bin (rev bl)))"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp: nth_takefill rev_nth nth_bin_to_bl bin_nth_of_bl)
   done
 
 lemma bl_bin_bl_rtf: "bin_to_bl n (bl_to_bin bl) = rev (takefill False n (rev bl))"
   by (simp add: takefill_bintrunc)
 
 lemma bl_to_bin_lt2p_aux: "bl_to_bin_aux bs w < (w + 1) * (2 ^ length bs)"
 proof (induction bs arbitrary: w)
   case Nil
   then show ?case
     by simp
 next
   case (Cons b bs)
   from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
   show ?case
     apply (auto simp add: algebra_simps)
     apply (subst mult_2 [of \<open>2 ^ length bs\<close>])
     apply (simp only: add.assoc)
     apply (rule pos_add_strict)
      apply simp_all
     done
 qed
 
 lemma bl_to_bin_lt2p_drop: "bl_to_bin bs < 2 ^ length (dropWhile Not bs)"
 proof (induct bs)
   case Nil
   then show ?case by simp
 next
   case (Cons b bs)
   with bl_to_bin_lt2p_aux[where w=1] show ?case
     by (simp add: bl_to_bin_def)
 qed
 
 lemma bl_to_bin_lt2p: "bl_to_bin bs < 2 ^ length bs"
   by (metis bin_bl_bin bintr_lt2p bl_bin_bl)
 
 lemma bl_to_bin_ge2p_aux: "bl_to_bin_aux bs w \<ge> w * (2 ^ length bs)"
 proof (induction bs arbitrary: w)
   case Nil
   then show ?case
     by simp
 next
   case (Cons b bs)
   from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
   show ?case
     apply (auto simp add: algebra_simps)
     apply (rule add_le_imp_le_left [of \<open>2 ^ length bs\<close>])
     apply (rule add_increasing)
     apply simp_all
     done
 qed
 
 lemma bl_to_bin_ge0: "bl_to_bin bs \<ge> 0"
   apply (unfold bl_to_bin_def)
   apply (rule xtrans(4))
    apply (rule bl_to_bin_ge2p_aux)
   apply simp
   done
 
 lemma butlast_rest_bin: "butlast (bin_to_bl n w) = bin_to_bl (n - 1) (w div 2)"
   apply (unfold bin_to_bl_def)
   apply (cases n, clarsimp)
   apply clarsimp
   apply (auto simp add: bin_to_bl_aux_alt)
   done
 
 lemma butlast_bin_rest: "butlast bl = bin_to_bl (length bl - Suc 0) (bl_to_bin bl div 2)"
   using butlast_rest_bin [where w="bl_to_bin bl" and n="length bl"] by simp
 
 lemma butlast_rest_bl2bin_aux:
   "bl \<noteq> [] \<Longrightarrow> bl_to_bin_aux (butlast bl) w = bl_to_bin_aux bl w div 2"
   by (induct bl arbitrary: w) auto
 
 lemma butlast_rest_bl2bin: "bl_to_bin (butlast bl) = bl_to_bin bl div 2"
   by (cases bl) (auto simp: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma trunc_bl2bin_aux:
   "take_bit m (bl_to_bin_aux bl w) =
     bl_to_bin_aux (drop (length bl - m) bl) (take_bit (m - length bl) w)"
 proof (induct bl arbitrary: w)
   case Nil
   show ?case by simp
 next
   case (Cons b bl)
   show ?case
   proof (cases "m - length bl")
     case 0
     then have "Suc (length bl) - m = Suc (length bl - m)" by simp
     with Cons show ?thesis by simp
   next
     case (Suc n)
     then have "m - Suc (length bl) = n" by simp
     with Cons Suc show ?thesis by (simp add: take_bit_Suc ac_simps)
   qed
 qed
 
 lemma trunc_bl2bin: "take_bit m (bl_to_bin bl) = bl_to_bin (drop (length bl - m) bl)"
   by (simp add: bl_to_bin_def trunc_bl2bin_aux)
 
 lemma trunc_bl2bin_len [simp]: "take_bit (length bl) (bl_to_bin bl) = bl_to_bin bl"
   by (simp add: trunc_bl2bin)
 
 lemma bl2bin_drop: "bl_to_bin (drop k bl) = take_bit (length bl - k) (bl_to_bin bl)"
   apply (rule trans)
    prefer 2
    apply (rule trunc_bl2bin [symmetric])
   apply (cases "k \<le> length bl")
    apply auto
   done
 
 lemma take_rest_power_bin: "m \<le> n \<Longrightarrow> take m (bin_to_bl n w) = bin_to_bl m (((\<lambda>w. w div 2) ^^ (n - m)) w)"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
   done
 
 lemma last_bin_last': "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> odd (bl_to_bin_aux xs w)"
   by (induct xs arbitrary: w) auto
 
 lemma last_bin_last: "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> odd (bl_to_bin xs)"
   unfolding bl_to_bin_def by (erule last_bin_last')
 
 lemma bin_last_last: "odd w \<longleftrightarrow> last (bin_to_bl (Suc n) w)"
   by (simp add: bin_to_bl_def) (auto simp: bin_to_bl_aux_alt)
 
 lemma drop_bin2bl_aux:
   "drop m (bin_to_bl_aux n bin bs) =
     bin_to_bl_aux (n - m) bin (drop (m - n) bs)"
   apply (induction n arbitrary: m bin bs)
    apply auto
   apply (case_tac "m \<le> n")
    apply (auto simp add: not_le Suc_diff_le)
   apply (case_tac "m - n")
    apply auto
   apply (use Suc_diff_Suc in fastforce)
   done
 
 lemma drop_bin2bl: "drop m (bin_to_bl n bin) = bin_to_bl (n - m) bin"
   by (simp add: bin_to_bl_def drop_bin2bl_aux)
 
 lemma take_bin2bl_lem1: "take m (bin_to_bl_aux m w bs) = bin_to_bl m w"
   apply (induct m arbitrary: w bs)
    apply clarsimp
   apply clarsimp
   apply (simp add: bin_to_bl_aux_alt)
   apply (simp add: bin_to_bl_def)
   apply (simp add: bin_to_bl_aux_alt)
   done
 
 lemma take_bin2bl_lem: "take m (bin_to_bl_aux (m + n) w bs) = take m (bin_to_bl (m + n) w)"
   by (induct n arbitrary: w bs) (simp_all (no_asm) add: bin_to_bl_def take_bin2bl_lem1, simp)
 
 lemma bin_split_take: "bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl (m + n) c)"
   apply (induct n arbitrary: b c)
    apply clarsimp
   apply (clarsimp simp: Let_def split: prod.split_asm)
   apply (simp add: bin_to_bl_def)
   apply (simp add: take_bin2bl_lem drop_bit_Suc)
   done
 
 lemma bin_to_bl_drop_bit:
   "k = m + n \<Longrightarrow> bin_to_bl m (drop_bit n c) = take m (bin_to_bl k c)"
   using bin_split_take by simp
 
 lemma bin_split_take1:
   "k = m + n \<Longrightarrow> bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl k c)"
   using bin_split_take by simp
 
 lemma bl_bin_bl_rep_drop:
   "bin_to_bl n (bl_to_bin bl) =
     replicate (n - length bl) False @ drop (length bl - n) bl"
   by (simp add: bl_to_bin_inj bl_to_bin_rep_F trunc_bl2bin)
 
 lemma bl_to_bin_aux_cat:
   "bl_to_bin_aux bs (concat_bit nv v w) =
     concat_bit (nv + length bs) (bl_to_bin_aux bs v) w"
   by (rule bit_eqI)
     (auto simp add: bin_nth_of_bl_aux bin_nth_cat algebra_simps)
 
 lemma bin_to_bl_aux_cat:
   "bin_to_bl_aux (nv + nw) (concat_bit nw w v) bs =
     bin_to_bl_aux nv v (bin_to_bl_aux nw w bs)"
   by (induction nw arbitrary: w bs) (simp_all add: concat_bit_Suc)
 
 lemma bl_to_bin_aux_alt: "bl_to_bin_aux bs w = concat_bit (length bs) (bl_to_bin bs) w"
   using bl_to_bin_aux_cat [where nv = "0" and v = "0"]
   by (simp add: bl_to_bin_def [symmetric])
 
 lemma bin_to_bl_cat:
   "bin_to_bl (nv + nw) (concat_bit nw w v) =
     bin_to_bl_aux nv v (bin_to_bl nw w)"
   by (simp add: bin_to_bl_def bin_to_bl_aux_cat)
 
 lemmas bl_to_bin_aux_app_cat =
   trans [OF bl_to_bin_aux_append bl_to_bin_aux_alt]
 
 lemmas bin_to_bl_aux_cat_app =
   trans [OF bin_to_bl_aux_cat bin_to_bl_aux_alt]
 
 lemma bl_to_bin_app_cat:
   "bl_to_bin (bsa @ bs) = concat_bit (length bs) (bl_to_bin bs) (bl_to_bin bsa)"
   by (simp only: bl_to_bin_aux_app_cat bl_to_bin_def)
 
 lemma bin_to_bl_cat_app:
   "bin_to_bl (n + nw) (concat_bit nw wa w) = bin_to_bl n w @ bin_to_bl nw wa"
   by (simp only: bin_to_bl_def bin_to_bl_aux_cat_app)
 
 text \<open>\<open>bl_to_bin_app_cat_alt\<close> and \<open>bl_to_bin_app_cat\<close> are easily interderivable.\<close>
 lemma bl_to_bin_app_cat_alt: "concat_bit n w (bl_to_bin cs) = bl_to_bin (cs @ bin_to_bl n w)"
   by (simp add: bl_to_bin_app_cat)
 
 lemma mask_lem: "(bl_to_bin (True # replicate n False)) = bl_to_bin (replicate n True) + 1"
   apply (unfold bl_to_bin_def)
   apply (induct n)
    apply simp
   apply (simp only: Suc_eq_plus1 replicate_add append_Cons [symmetric] bl_to_bin_aux_append)
   apply simp
   done
 
 lemma bin_exhaust:
   "(\<And>x b. bin = of_bool b + 2 * x \<Longrightarrow> Q) \<Longrightarrow> Q" for bin :: int
   apply (cases \<open>even bin\<close>)
    apply (auto elim!: evenE oddE)
    apply fastforce
   apply fastforce
   done
 
 primrec rbl_succ :: "bool list \<Rightarrow> bool list"
   where
     Nil: "rbl_succ Nil = Nil"
   | Cons: "rbl_succ (x # xs) = (if x then False # rbl_succ xs else True # xs)"
 
 primrec rbl_pred :: "bool list \<Rightarrow> bool list"
   where
     Nil: "rbl_pred Nil = Nil"
   | Cons: "rbl_pred (x # xs) = (if x then False # xs else True # rbl_pred xs)"
 
 primrec rbl_add :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
   where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
     Nil: "rbl_add Nil x = Nil"
   | Cons: "rbl_add (y # ys) x =
       (let ws = rbl_add ys (tl x)
        in (y \<noteq> hd x) # (if hd x \<and> y then rbl_succ ws else ws))"
 
 primrec rbl_mult :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
   where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
     Nil: "rbl_mult Nil x = Nil"
   | Cons: "rbl_mult (y # ys) x =
       (let ws = False # rbl_mult ys x
        in if y then rbl_add ws x else ws)"
 
 lemma size_rbl_pred: "length (rbl_pred bl) = length bl"
   by (induct bl) auto
 
 lemma size_rbl_succ: "length (rbl_succ bl) = length bl"
   by (induct bl) auto
 
 lemma size_rbl_add: "length (rbl_add bl cl) = length bl"
   by (induct bl arbitrary: cl) (auto simp: Let_def size_rbl_succ)
 
 lemma size_rbl_mult: "length (rbl_mult bl cl) = length bl"
   by (induct bl arbitrary: cl) (auto simp add: Let_def size_rbl_add)
 
 lemmas rbl_sizes [simp] =
   size_rbl_pred size_rbl_succ size_rbl_add size_rbl_mult
 
 lemmas rbl_Nils =
   rbl_pred.Nil rbl_succ.Nil rbl_add.Nil rbl_mult.Nil
 
 lemma rbl_add_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_add bla (blb @ blc) = rbl_add bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def)
   done
 
 lemma rbl_add_take2:
   "length blb \<ge> length bla \<Longrightarrow> rbl_add bla (take (length bla) blb) = rbl_add bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def)
   done
 
 lemma rbl_mult_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (blb @ blc) = rbl_mult bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def rbl_add_app2)
   done
 
 lemma rbl_mult_take2:
   "length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (take (length bla) blb) = rbl_mult bla blb"
   apply (rule trans)
    apply (rule rbl_mult_app2 [symmetric])
    apply simp
   apply (rule_tac f = "rbl_mult bla" in arg_cong)
   apply (rule append_take_drop_id)
   done
 
 lemma rbl_add_split:
   "P (rbl_add (y # ys) (x # xs)) =
     (\<forall>ws. length ws = length ys \<longrightarrow> ws = rbl_add ys xs \<longrightarrow>
       (y \<longrightarrow> ((x \<longrightarrow> P (False # rbl_succ ws)) \<and> (\<not> x \<longrightarrow> P (True # ws)))) \<and>
       (\<not> y \<longrightarrow> P (x # ws)))"
   by (cases y) (auto simp: Let_def)
 
 lemma rbl_mult_split:
   "P (rbl_mult (y # ys) xs) =
     (\<forall>ws. length ws = Suc (length ys) \<longrightarrow> ws = False # rbl_mult ys xs \<longrightarrow>
       (y \<longrightarrow> P (rbl_add ws xs)) \<and> (\<not> y \<longrightarrow> P ws))"
   by (auto simp: Let_def)
 
 lemma rbl_pred: "rbl_pred (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin - 1))"
 proof (unfold bin_to_bl_def, induction n arbitrary: bin)
   case 0
   then show ?case
     by simp
 next
   case (Suc n)
   obtain b k where \<open>bin = of_bool b + 2 * k\<close>
     using bin_exhaust by blast
   moreover have \<open>(2 * k - 1) div 2 = k - 1\<close>
-    using even_succ_div_2 [of \<open>2 * (k - 1)\<close>]
     by simp
   ultimately show ?case
     using Suc [of \<open>bin div 2\<close>]
     by simp (auto simp add: bin_to_bl_aux_alt)
 qed
 
 lemma rbl_succ: "rbl_succ (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin + 1))"
   apply (unfold bin_to_bl_def)
   apply (induction n arbitrary: bin)
    apply simp_all
   apply (case_tac bin rule: bin_exhaust)
    apply (simp_all add: bin_to_bl_aux_alt ac_simps)
   done
 
 lemma rbl_add:
   "\<And>bina binb. rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
     rev (bin_to_bl n (bina + binb))"
   apply (unfold bin_to_bl_def)
   apply (induct n)
    apply simp
   apply clarsimp
   apply (case_tac bina rule: bin_exhaust)
   apply (case_tac binb rule: bin_exhaust)
   apply (case_tac b)
    apply (case_tac [!] "ba")
      apply (auto simp: rbl_succ bin_to_bl_aux_alt Let_def ac_simps)
   done
 
 lemma rbl_add_long:
   "m \<ge> n \<Longrightarrow> rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
     rev (bin_to_bl n (bina + binb))"
   apply (rule box_equals [OF _ rbl_add_take2 rbl_add])
    apply (rule_tac f = "rbl_add (rev (bin_to_bl n bina))" in arg_cong)
    apply (rule rev_swap [THEN iffD1])
    apply (simp add: rev_take drop_bin2bl)
   apply simp
   done
 
 lemma rbl_mult_gt1:
   "m \<ge> length bl \<Longrightarrow>
     rbl_mult bl (rev (bin_to_bl m binb)) =
     rbl_mult bl (rev (bin_to_bl (length bl) binb))"
   apply (rule trans)
    apply (rule rbl_mult_take2 [symmetric])
    apply simp_all
   apply (rule_tac f = "rbl_mult bl" in arg_cong)
   apply (rule rev_swap [THEN iffD1])
   apply (simp add: rev_take drop_bin2bl)
   done
 
 lemma rbl_mult_gt:
   "m > n \<Longrightarrow>
     rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
     rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb))"
   by (auto intro: trans [OF rbl_mult_gt1])
 
 lemmas rbl_mult_Suc = lessI [THEN rbl_mult_gt]
 
 lemma rbbl_Cons: "b # rev (bin_to_bl n x) = rev (bin_to_bl (Suc n) (of_bool b + 2 * x))"
   by (simp add: bin_to_bl_def) (simp add: bin_to_bl_aux_alt)
 
 lemma rbl_mult:
   "rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
     rev (bin_to_bl n (bina * binb))"
   apply (induct n arbitrary: bina binb)
    apply simp_all
   apply (unfold bin_to_bl_def)
   apply clarsimp
   apply (case_tac bina rule: bin_exhaust)
   apply (case_tac binb rule: bin_exhaust)
   apply (simp_all add: bin_to_bl_aux_alt)
   apply (simp_all add: rbbl_Cons rbl_mult_Suc rbl_add algebra_simps)
   done
 
 lemma sclem: "size (concat (map (bin_to_bl n) xs)) = length xs * n"
   by (simp add: length_concat comp_def sum_list_triv)
 
 lemma bin_cat_foldl_lem:
   "foldl (\<lambda>u k. concat_bit n k u) x xs =
     concat_bit (size xs * n) (foldl (\<lambda>u k. concat_bit n k u) y xs) x"
   apply (induct xs arbitrary: x)
    apply simp
   apply (simp (no_asm))
   apply (frule asm_rl)
   apply (drule meta_spec)
   apply (erule trans)
   apply (drule_tac x = "concat_bit n a y" in meta_spec)
   apply (simp add: bin_cat_assoc_sym)
   done
 
 lemma bin_rcat_bl: "bin_rcat n wl = bl_to_bin (concat (map (bin_to_bl n) wl))"
   apply (unfold bin_rcat_eq_foldl)
   apply (rule sym)
   apply (induct wl)
    apply (auto simp add: bl_to_bin_append)
   apply (simp add: bl_to_bin_aux_alt sclem)
   apply (simp add: bin_cat_foldl_lem [symmetric])
   done
 
 lemma bin_last_bl_to_bin: "odd (bl_to_bin bs) \<longleftrightarrow> bs \<noteq> [] \<and> last bs"
 by(cases "bs = []")(auto simp add: bl_to_bin_def last_bin_last'[where w=0])
 
 lemma bin_rest_bl_to_bin: "bl_to_bin bs div 2 = bl_to_bin (butlast bs)"
 by(cases "bs = []")(simp_all add: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma bl_xor_aux_bin:
   "map2 (\<lambda>x y. x \<noteq> y) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v XOR w) (map2 (\<lambda>x y. x \<noteq> y) bs cs)"
   apply (induction n arbitrary: v w bs cs)
    apply auto
   apply (case_tac v rule: bin_exhaust)
   apply (case_tac w rule: bin_exhaust)
   apply clarsimp
   done
 
 lemma bl_or_aux_bin:
   "map2 (\<or>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v OR w) (map2 (\<or>) bs cs)"
   by (induct n arbitrary: v w bs cs) simp_all
 
 lemma bl_and_aux_bin:
   "map2 (\<and>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v AND w) (map2 (\<and>) bs cs)"
   by (induction n arbitrary: v w bs cs) simp_all
 
 lemma bl_not_aux_bin: "map Not (bin_to_bl_aux n w cs) = bin_to_bl_aux n (NOT w) (map Not cs)"
   by (induct n arbitrary: w cs) auto
 
 lemma bl_not_bin: "map Not (bin_to_bl n w) = bin_to_bl n (NOT w)"
   by (simp add: bin_to_bl_def bl_not_aux_bin)
 
 lemma bl_and_bin: "map2 (\<and>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v AND w)"
   by (simp add: bin_to_bl_def bl_and_aux_bin)
 
 lemma bl_or_bin: "map2 (\<or>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v OR w)"
   by (simp add: bin_to_bl_def bl_or_aux_bin)
 
 lemma bl_xor_bin: "map2 (\<noteq>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v XOR w)"
   using bl_xor_aux_bin by (simp add: bin_to_bl_def)
 
 
 subsection \<open>Type \<^typ>\<open>'a word\<close>\<close>
 
 lift_definition of_bl :: \<open>bool list \<Rightarrow> 'a::len word\<close>
   is bl_to_bin .
 
 lift_definition to_bl :: \<open>'a::len word \<Rightarrow> bool list\<close>
   is \<open>bin_to_bl LENGTH('a)\<close>
   by (simp add: bl_to_bin_inj)
 
 lemma to_bl_eq:
   \<open>to_bl w = bin_to_bl (LENGTH('a)) (uint w)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma bit_of_bl_iff [bit_simps]:
   \<open>bit (of_bl bs :: 'a word) n \<longleftrightarrow> rev bs ! n \<and> n < LENGTH('a::len) \<and> n < length bs\<close>
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma rev_to_bl_eq:
   \<open>rev (to_bl w) = map (bit w) [0..<LENGTH('a)]\<close>
   for w :: \<open>'a::len word\<close>
   apply (rule nth_equalityI)
    apply (simp add: to_bl.rep_eq)
   apply (simp add: bin_nth_bl bit_word.rep_eq to_bl.rep_eq)
   done
 
 lemma to_bl_eq_rev:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a)])\<close>
   for w :: \<open>'a::len word\<close>
   using rev_to_bl_eq [of w]
   apply (subst rev_is_rev_conv [symmetric])
   apply (simp add: rev_map)
   done
 
 lemma of_bl_rev_eq:
   \<open>of_bl (rev bs) = horner_sum of_bool 2 bs\<close>
   apply (rule bit_word_eqI)
   apply (simp add: bit_of_bl_iff)
   apply transfer
   apply (simp add: bit_horner_sum_bit_iff ac_simps)
   done
 
 lemma of_bl_eq:
   \<open>of_bl bs = horner_sum of_bool 2 (rev bs)\<close>
   using of_bl_rev_eq [of \<open>rev bs\<close>] by simp
 
 lemma bshiftr1_eq:
   \<open>bshiftr1 b w = of_bl (b # butlast (to_bl w))\<close>
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps to_bl_eq_rev nth_append rev_nth nth_butlast not_less simp flip: bit_Suc)
   apply (metis Suc_pred len_gt_0 less_eq_decr_length_iff not_bit_length verit_la_disequality)
   done
 
 lemma length_to_bl_eq:
   \<open>length (to_bl w) = LENGTH('a)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma word_rotr_eq:
   \<open>word_rotr n w = of_bl (rotater n (to_bl w))\<close>
   apply (rule bit_word_eqI)
   subgoal for n
     apply (cases \<open>n < LENGTH('a)\<close>)
      apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff rotater_rev length_to_bl_eq nth_rotate rev_to_bl_eq ac_simps)
     done
   done
 
 lemma word_rotl_eq:
   \<open>word_rotl n w = of_bl (rotate n (to_bl w))\<close>
 proof -
   have \<open>rotate n (to_bl w) = rev (rotater n (rev (to_bl w)))\<close>
     by (simp add: rotater_rev')
   then show ?thesis
     apply (simp add: word_rotl_eq_word_rotr bit_of_bl_iff length_to_bl_eq rev_to_bl_eq)
     apply (rule bit_word_eqI)
     subgoal for n
       apply (cases \<open>n < LENGTH('a)\<close>)
        apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff nth_rotater)
       done
     done
 qed
 
 lemma to_bl_def': "(to_bl :: 'a::len word \<Rightarrow> bool list) = bin_to_bl (LENGTH('a)) \<circ> uint"
   by transfer (simp add: fun_eq_iff)
 
 \<comment> \<open>type definitions theorem for in terms of equivalent bool list\<close>
 lemma td_bl:
   "type_definition
     (to_bl :: 'a::len word \<Rightarrow> bool list)
     of_bl
     {bl. length bl = LENGTH('a)}"
   apply (standard; transfer)
   apply (auto dest: sym)
   done
 
 global_interpretation word_bl:
   type_definition
     "to_bl :: 'a::len word \<Rightarrow> bool list"
     of_bl
     "{bl. length bl = LENGTH('a::len)}"
   by (fact td_bl)
 
 lemmas word_bl_Rep' = word_bl.Rep [unfolded mem_Collect_eq, iff]
 
 lemma word_size_bl: "size w = size (to_bl w)"
   by (auto simp: word_size)
 
 lemma to_bl_use_of_bl: "to_bl w = bl \<longleftrightarrow> w = of_bl bl \<and> length bl = length (to_bl w)"
   by (fastforce elim!: word_bl.Abs_inverse [unfolded mem_Collect_eq])
 
 lemma length_bl_gt_0 [iff]: "0 < length (to_bl x)"
   for x :: "'a::len word"
   unfolding word_bl_Rep' by (rule len_gt_0)
 
 lemma bl_not_Nil [iff]: "to_bl x \<noteq> []"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [unfolded length_greater_0_conv])
 
 lemma length_bl_neq_0 [iff]: "length (to_bl x) \<noteq> 0"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [THEN gr_implies_not0])
 
 lemma hd_to_bl_iff:
   \<open>hd (to_bl w) \<longleftrightarrow> bit w (LENGTH('a) - 1)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: to_bl_eq_rev hd_map hd_rev)
 
 lemma hd_bl_sign_sint: "hd (to_bl w) = (bin_sign (sint w) = -1)"
   by (simp add: hd_to_bl_iff bit_last_iff bin_sign_def)
 
 lemma of_bl_drop':
   "lend = length bl - LENGTH('a::len) \<Longrightarrow>
     of_bl (drop lend bl) = (of_bl bl :: 'a word)"
   by transfer (simp flip: trunc_bl2bin)
 
 lemma test_bit_of_bl:
   "bit (of_bl bl::'a::len word) n = (rev bl ! n \<and> n < LENGTH('a) \<and> n < length bl)"
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma no_of_bl: "(numeral bin ::'a::len word) = of_bl (bin_to_bl (LENGTH('a)) (numeral bin))"
   by transfer simp
 
 lemma uint_bl: "to_bl w = bin_to_bl (size w) (uint w)"
   by transfer simp
 
 lemma to_bl_bin: "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma to_bl_of_bin: "to_bl (word_of_int bin::'a::len word) = bin_to_bl (LENGTH('a)) bin"
   by (auto simp: uint_bl word_ubin.eq_norm word_size)
 
 lemma to_bl_numeral [simp]:
   "to_bl (numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (numeral bin)"
   unfolding word_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_neg_numeral [simp]:
   "to_bl (- numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (- numeral bin)"
   unfolding word_neg_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_to_bin [simp] : "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma uint_bl_bin: "bl_to_bin (bin_to_bl (LENGTH('a)) (uint x)) = uint x"
   for x :: "'a::len word"
   by (rule trans [OF bin_bl_bin word_ubin.norm_Rep])
 
 lemma ucast_bl: "ucast w = of_bl (to_bl w)"
   by transfer simp
 
 lemma ucast_down_bl:
   \<open>(ucast :: 'a::len word \<Rightarrow> 'b::len word) (of_bl bl) = of_bl bl\<close>
     if \<open>is_down (ucast :: 'a::len word \<Rightarrow> 'b::len word)\<close>
   using that by transfer simp
 
 lemma of_bl_append_same: "of_bl (X @ to_bl w) = w"
   by transfer (simp add: bl_to_bin_app_cat)
 
 lemma ucast_of_bl_up:
   \<open>ucast (of_bl bl :: 'a::len word) = of_bl bl\<close>
   if \<open>size bl \<le> size (of_bl bl :: 'a::len word)\<close>
   using that
   apply transfer
   apply (rule bit_eqI)
   apply (auto simp add: bit_take_bit_iff)
   apply (subst (asm) trunc_bl2bin_len [symmetric])
   apply (auto simp only: bit_take_bit_iff)
   done
 
 lemma word_rev_tf:
   "to_bl (of_bl bl::'a::len word) =
     rev (takefill False (LENGTH('a)) (rev bl))"
   by transfer (simp add: bl_bin_bl_rtf)
 
 lemma word_rep_drop:
   "to_bl (of_bl bl::'a::len word) =
     replicate (LENGTH('a) - length bl) False @
     drop (length bl - LENGTH('a)) bl"
   by (simp add: word_rev_tf takefill_alt rev_take)
 
 lemma to_bl_ucast:
   "to_bl (ucast (w::'b::len word) ::'a::len word) =
     replicate (LENGTH('a) - LENGTH('b)) False @
     drop (LENGTH('b) - LENGTH('a)) (to_bl w)"
   apply (unfold ucast_bl)
   apply (rule trans)
    apply (rule word_rep_drop)
   apply simp
   done
 
 lemma ucast_up_app:
   \<open>to_bl (ucast w :: 'b::len word) = replicate n False @ (to_bl w)\<close>
     if \<open>source_size (ucast :: 'a word \<Rightarrow> 'b word) + n = target_size (ucast :: 'a word \<Rightarrow> 'b word)\<close>
     for w :: \<open>'a::len word\<close>
   using that
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma ucast_down_drop [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow>
     to_bl (uc w) = drop n (to_bl w)"
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma scast_down_drop [OF refl]:
   "sc = scast \<Longrightarrow> source_size sc = target_size sc + n \<Longrightarrow>
     to_bl (sc w) = drop n (to_bl w)"
   apply (subgoal_tac "sc = ucast")
    apply safe
    apply simp
    apply (erule ucast_down_drop)
   apply (rule down_cast_same [symmetric])
   apply (simp add : source_size target_size is_down)
   done
 
 lemma word_0_bl [simp]: "of_bl [] = 0"
   by transfer simp
 
 lemma word_1_bl: "of_bl [True] = 1"
   by transfer (simp add: bl_to_bin_def)
 
 lemma of_bl_0 [simp]: "of_bl (replicate n False) = 0"
   by transfer (simp add: bl_to_bin_rep_False)
 
 lemma to_bl_0 [simp]: "to_bl (0::'a::len word) = replicate (LENGTH('a)) False"
   by (simp add: uint_bl word_size bin_to_bl_zero)
 
 \<comment> \<open>links with \<open>rbl\<close> operations\<close>
 lemma word_succ_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_succ w) = rev (rbl_succ (rev bl))"
   by transfer (simp add: rbl_succ)
 
 lemma word_pred_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_pred w) = rev (rbl_pred (rev bl))"
   by transfer (simp add: rbl_pred)
 
 lemma word_add_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v + w) = rev (rbl_add (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_add)
   done
 
 lemma word_mult_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v * w) = rev (rbl_mult (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_mult)
   done
 
 lemma rtb_rbl_ariths:
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_succ w)) = rbl_succ ys"
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_pred w)) = rbl_pred ys"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v * w)) = rbl_mult ys xs"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v + w)) = rbl_add ys xs"
   by (auto simp: rev_swap [symmetric] word_succ_rbl word_pred_rbl word_mult_rbl word_add_rbl)
 
 lemma of_bl_length_less:
   \<open>(of_bl x :: 'a::len word) < 2 ^ k\<close>
     if \<open>length x = k\<close> \<open>k < LENGTH('a)\<close>
 proof -
   from that have \<open>length x < LENGTH('a)\<close>
     by simp
   then have \<open>(of_bl x :: 'a::len word) < 2 ^ length x\<close>
     apply (simp add: of_bl_eq)
     apply transfer
     apply (simp add: take_bit_horner_sum_bit_eq)
     apply (subst length_rev [symmetric])
     apply (simp only: horner_sum_of_bool_2_less)
     done
   with that show ?thesis
     by simp
 qed
 
 lemma word_eq_rbl_eq: "x = y \<longleftrightarrow> rev (to_bl x) = rev (to_bl y)"
   by simp
 
 lemma bl_word_not: "to_bl (NOT w) = map Not (to_bl w)"
   by transfer (simp add: bl_not_bin)
 
 lemma bl_word_xor: "to_bl (v XOR w) = map2 (\<noteq>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_xor_bin)
 
 lemma bl_word_or: "to_bl (v OR w) = map2 (\<or>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_or_bin)
 
 lemma bl_word_and: "to_bl (v AND w) = map2 (\<and>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_and_bin)
 
 lemma bin_nth_uint': "bit (uint w) n \<longleftrightarrow> rev (bin_to_bl (size w) (uint w)) ! n \<and> n < size w"
   apply (unfold word_size)
   apply (safe elim!: bin_nth_uint_imp)
    apply (frule bin_nth_uint_imp)
    apply (fast dest!: bin_nth_bl)+
   done
 
 lemmas bin_nth_uint = bin_nth_uint' [unfolded word_size]
 
 lemma test_bit_bl: "bit w n \<longleftrightarrow> rev (to_bl w) ! n \<and> n < size w"
   by transfer (auto simp add: bin_nth_bl)
 
 lemma to_bl_nth: "n < size w \<Longrightarrow> to_bl w ! n = bit w (size w - Suc n)"
   by (simp add: word_size rev_nth test_bit_bl)
 
 lemma map_bit_interval_eq:
   \<open>map (bit w) [0..<n] = takefill False n (rev (to_bl w))\<close> for w :: \<open>'a::len word\<close>
 proof (rule nth_equalityI)
   show \<open>length (map (bit w) [0..<n]) =
     length (takefill False n (rev (to_bl w)))\<close>
     by simp
   fix m
   assume \<open>m < length (map (bit w) [0..<n])\<close>
   then have \<open>m < n\<close>
     by simp
   then have \<open>bit w m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by (auto simp add: nth_takefill not_less rev_nth to_bl_nth word_size dest: bit_imp_le_length)
   with \<open>m < n \<close>show \<open>map (bit w) [0..<n] ! m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by simp
 qed
 
 lemma to_bl_unfold:
   \<open>to_bl w = rev (map (bit w) [0..<LENGTH('a)])\<close> for w :: \<open>'a::len word\<close>
   by (simp add: map_bit_interval_eq takefill_bintrunc to_bl_def flip: bin_to_bl_def)
 
 lemma nth_rev_to_bl:
   \<open>rev (to_bl w) ! n \<longleftrightarrow> bit w n\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold)
 
 lemma nth_to_bl:
   \<open>to_bl w ! n \<longleftrightarrow> bit w (LENGTH('a) - Suc n)\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold rev_nth)
 
 lemma of_bl_rep_False: "of_bl (replicate n False @ bs) = of_bl bs"
   by (auto simp: of_bl_def bl_to_bin_rep_F)
 
 lemma [code abstract]:
   \<open>Word.the_int (of_bl bs :: 'a word) = horner_sum of_bool 2 (take LENGTH('a::len) (rev bs))\<close>
   apply (simp add: of_bl_eq flip: take_bit_horner_sum_bit_eq)
   apply transfer
   apply simp
   done
 
 lemma [code]:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a::len)])\<close>
   for w :: \<open>'a::len word\<close>
   by (fact to_bl_eq_rev)
 
 lemma word_reverse_eq_of_bl_rev_to_bl:
   \<open>word_reverse w = of_bl (rev (to_bl w))\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_word_reverse_iff bit_of_bl_iff nth_to_bl)
 
 lemmas word_reverse_no_def [simp] =
   word_reverse_eq_of_bl_rev_to_bl [of "numeral w"] for w
 
 lemma to_bl_word_rev: "to_bl (word_reverse w) = rev (to_bl w)"
   by (rule nth_equalityI) (simp_all add: nth_rev_to_bl word_reverse_def word_rep_drop flip: of_bl_eq)
 
 lemma to_bl_n1 [simp]: "to_bl (-1::'a::len word) = replicate (LENGTH('a)) True"
   apply (rule word_bl.Abs_inverse')
    apply simp
   apply (rule word_eqI)
   apply (clarsimp simp add: word_size)
   apply (auto simp add: word_bl.Abs_inverse test_bit_bl word_size)
   done
 
 lemma rbl_word_or: "rev (to_bl (x OR y)) = map2 (\<or>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_or rev_map)
 
 lemma rbl_word_and: "rev (to_bl (x AND y)) = map2 (\<and>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_and rev_map)
 
 lemma rbl_word_xor: "rev (to_bl (x XOR y)) = map2 (\<noteq>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_xor rev_map)
 
 lemma rbl_word_not: "rev (to_bl (NOT x)) = map Not (rev (to_bl x))"
   by (simp add: bl_word_not rev_map)
 
 lemma bshiftr1_numeral [simp]:
   \<open>bshiftr1 b (numeral w :: 'a word) = of_bl (b # butlast (bin_to_bl LENGTH('a::len) (numeral w)))\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps rev_nth nth_append nth_butlast nth_bin_to_bl simp flip: bit_Suc)
 
 lemma bshiftr1_bl: "to_bl (bshiftr1 b w) = b # butlast (to_bl w)"
   unfolding bshiftr1_eq by (rule word_bl.Abs_inverse) simp
 
 lemma shiftl1_of_bl: "shiftl1 (of_bl bl) = of_bl (bl @ [False])"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   subgoal for n
     apply (cases n)
      apply simp_all
     done
   done
 
 lemma shiftl1_bl: "shiftl1 w = of_bl (to_bl w @ [False])"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   subgoal for n
     apply (cases n)
      apply (simp_all add: nth_rev_to_bl)
     done
   done
 
 lemma bl_shiftl1: "to_bl (shiftl1 w) = tl (to_bl w) @ [False]"
   for w :: "'a::len word"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc drop_Cons') (fast intro!: Suc_leI)
 
 lemma to_bl_double_eq:
   \<open>to_bl (2 * w) = tl (to_bl w) @ [False]\<close>
   using bl_shiftl1 [of w] by (simp add: shiftl1_def ac_simps)
 
 \<comment> \<open>Generalized version of \<open>bl_shiftl1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftl1': "to_bl (shiftl1 w) = tl (to_bl w @ [False])"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc del: drop_append)
 
 lemma shiftr1_bl:
   \<open>shiftr1 w = of_bl (butlast (to_bl w))\<close>
 proof (rule bit_word_eqI)
   fix n
   assume \<open>n < LENGTH('a)\<close>
   show \<open>bit (shiftr1 w) n \<longleftrightarrow> bit (of_bl (butlast (to_bl w)) :: 'a word) n\<close>
   proof (cases \<open>n = LENGTH('a) - 1\<close>)
     case True
     then show ?thesis
       by (simp add: bit_shiftr1_iff bit_of_bl_iff)
   next
     case False
     with \<open>n < LENGTH('a)\<close>
     have \<open>n < LENGTH('a) - 1\<close>
       by simp
     with \<open>n < LENGTH('a)\<close> show ?thesis
       by (simp add: bit_shiftr1_iff bit_of_bl_iff rev_nth nth_butlast
         word_size to_bl_nth)
   qed
 qed
 
 lemma bl_shiftr1: "to_bl (shiftr1 w) = False # butlast (to_bl w)"
   for w :: "'a::len word"
   by (simp add: shiftr1_bl word_rep_drop len_gt_0 [THEN Suc_leI])
 
 \<comment> \<open>Generalized version of \<open>bl_shiftr1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftr1': "to_bl (shiftr1 w) = butlast (False # to_bl w)"
   apply (rule word_bl.Abs_inverse')
    apply (simp del: butlast.simps)
   apply (simp add: shiftr1_bl of_bl_def)
   done
 
 lemma bl_sshiftr1: "to_bl (sshiftr1 w) = hd (to_bl w) # butlast (to_bl w)"
   for w :: "'a::len word"
 proof (rule nth_equalityI)
   fix n
   assume \<open>n < length (to_bl (sshiftr1 w))\<close>
   then have \<open>n < LENGTH('a)\<close>
     by simp
   then show \<open>to_bl (sshiftr1 w) ! n \<longleftrightarrow> (hd (to_bl w) # butlast (to_bl w)) ! n\<close>
     apply (cases n)
      apply (simp_all add: to_bl_nth word_size hd_conv_nth bit_sshiftr1_iff nth_butlast Suc_diff_Suc nth_to_bl)
     done
 qed simp
 
 lemma drop_shiftr: "drop n (to_bl (w >> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
   apply (rule nth_equalityI)
    apply (simp_all add: word_size to_bl_nth bit_simps)
   done
 
 lemma drop_sshiftr: "drop n (to_bl (w >>> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
   apply (rule nth_equalityI)
    apply (simp_all add: word_size nth_to_bl bit_simps)
   done
 
 lemma take_shiftr: "n \<le> size w \<Longrightarrow> take n (to_bl (w >> n)) = replicate n False"
   apply (rule nth_equalityI)
    apply (auto simp add: word_size to_bl_nth bit_simps dest: bit_imp_le_length)
   done
 
 lemma take_sshiftr':
   "n \<le> size w \<Longrightarrow> hd (to_bl (w >>> n)) = hd (to_bl w) \<and>
     take n (to_bl (w >>> n)) = replicate n (hd (to_bl w))"
   for w :: "'a::len word"
   apply (cases n)
    apply (auto simp add: hd_to_bl_iff bit_simps not_less word_size)
   apply (rule nth_equalityI)
    apply (auto simp add: nth_to_bl bit_simps nth_Cons split: nat.split)
   done
 
 lemmas hd_sshiftr = take_sshiftr' [THEN conjunct1]
 lemmas take_sshiftr = take_sshiftr' [THEN conjunct2]
 
 lemma atd_lem: "take n xs = t \<Longrightarrow> drop n xs = d \<Longrightarrow> xs = t @ d"
   by (auto intro: append_take_drop_id [symmetric])
 
 lemmas bl_shiftr = atd_lem [OF take_shiftr drop_shiftr]
 lemmas bl_sshiftr = atd_lem [OF take_sshiftr drop_sshiftr]
 
 lemma shiftl_of_bl: "of_bl bl << n = of_bl (bl @ replicate n False)"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps nth_append)
   done
 
 lemma shiftl_bl: "w << n = of_bl (to_bl w @ replicate n False)"
   for w :: "'a::len word"
   by (simp flip: shiftl_of_bl)
 
 lemma bl_shiftl: "to_bl (w << n) = drop n (to_bl w) @ replicate (min (size w) n) False"
   by (simp add: shiftl_bl word_rep_drop word_size)
 
 lemma shiftr1_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
     shiftr1 (of_bl bl::'a::len word) = of_bl (butlast bl)"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   apply (cases bl rule: rev_cases)
   apply auto
   done
 
 lemma shiftr_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
      (of_bl bl::'a::len word) >> n = of_bl (take (length bl - n) bl)"
   by (rule bit_word_eqI) (auto simp add: bit_simps rev_nth)
 
 lemma shiftr_bl: "x >> n \<equiv> of_bl (take (LENGTH('a) - n) (to_bl x))"
   for x :: "'a::len word"
   using shiftr_bl_of [where 'a='a, of "to_bl x"] by simp
 
 lemma aligned_bl_add_size [OF refl]:
   "size x - n = m \<Longrightarrow> n \<le> size x \<Longrightarrow> drop m (to_bl x) = replicate n False \<Longrightarrow>
     take m (to_bl y) = replicate m False \<Longrightarrow>
     to_bl (x + y) = take m (to_bl x) @ drop m (to_bl y)" for x :: \<open>'a::len word\<close>
   apply (subgoal_tac "x AND y = 0")
    prefer 2
    apply (rule word_bl.Rep_eqD)
    apply (simp add: bl_word_and)
    apply (rule align_lem_and [THEN trans])
        apply (simp_all add: word_size)[5]
    apply simp
   apply (subst word_plus_and_or [symmetric])
   apply (simp add : bl_word_or)
   apply (rule align_lem_or)
      apply (simp_all add: word_size)
   done
 
 lemma mask_bl: "mask n = of_bl (replicate n True)"
   by (auto simp add: bit_simps intro!: word_eqI)
 
 lemma bl_and_mask':
   "to_bl (w AND mask n :: 'a::len word) =
     replicate (LENGTH('a) - n) False @
     drop (LENGTH('a) - n) (to_bl w)"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: to_bl_nth word_size bit_simps)
   apply (auto simp add: word_size test_bit_bl nth_append rev_nth)
   done
 
 lemma slice1_eq_of_bl:
   \<open>(slice1 n w :: 'b::len word) = of_bl (takefill False n (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
 proof (rule bit_word_eqI)
   fix m
   assume \<open>m < LENGTH('b)\<close>
   show \<open>bit (slice1 n w :: 'b::len word) m \<longleftrightarrow> bit (of_bl (takefill False n (to_bl w)) :: 'b word) m\<close>
     by (cases \<open>m \<ge> n\<close>; cases \<open>LENGTH('a) \<ge> n\<close>)
       (auto simp add: bit_slice1_iff bit_of_bl_iff not_less rev_nth not_le nth_takefill nth_to_bl algebra_simps)
 qed
 
 lemma slice1_no_bin [simp]:
   "slice1 n (numeral w :: 'b word) = of_bl (takefill False n (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice1_eq_of_bl) (* TODO: neg_numeral *)
 
 lemma slice_no_bin [simp]:
   "slice n (numeral w :: 'b word) = of_bl (takefill False (LENGTH('b::len) - n)
     (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice_def) (* TODO: neg_numeral *)
 
 lemma slice_take': "slice n w = of_bl (take (size w - n) (to_bl w))"
   by (simp add: slice_def word_size slice1_eq_of_bl takefill_alt)
 
 lemmas slice_take = slice_take' [unfolded word_size]
 
 \<comment> \<open>shiftr to a word of the same size is just slice,
     slice is just shiftr then ucast\<close>
 lemmas shiftr_slice = trans [OF shiftr_bl [THEN meta_eq_to_obj_eq] slice_take [symmetric]]
 
 lemma slice1_down_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs + k = n \<Longrightarrow>
     to_bl sl = takefill False fs (drop k (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop)
   using drop_takefill
   apply force
   done
 
 lemma slice1_up_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs = n + k \<Longrightarrow>
     to_bl sl = takefill False fs (replicate k False @ (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop flip: takefill_append)
   apply (metis diff_add_inverse)
   done
 
 lemmas sd1 = slice1_down_alt' [OF refl refl, unfolded word_size]
 lemmas su1 = slice1_up_alt' [OF refl refl, unfolded word_size]
 lemmas slice1_down_alt = le_add_diff_inverse [THEN sd1]
 lemmas slice1_up_alts =
   le_add_diff_inverse [symmetric, THEN su1]
   le_add_diff_inverse2 [symmetric, THEN su1]
 
 lemma slice1_tf_tf':
   "to_bl (slice1 n w :: 'a::len word) =
     rev (takefill False (LENGTH('a)) (rev (takefill False n (to_bl w))))"
   unfolding slice1_eq_of_bl by (rule word_rev_tf)
 
 lemmas slice1_tf_tf = slice1_tf_tf' [THEN word_bl.Rep_inverse', symmetric]
 
 lemma revcast_eq_of_bl:
   \<open>(revcast w :: 'b::len word) = of_bl (takefill False (LENGTH('b)) (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: revcast_def slice1_eq_of_bl)
 
 lemmas revcast_no_def [simp] = revcast_eq_of_bl [where w="numeral w", unfolded word_size] for w
 
 lemma to_bl_revcast:
   "to_bl (revcast w :: 'a::len word) = takefill False (LENGTH('a)) (to_bl w)"
   apply (rule nth_equalityI)
   apply simp
   apply (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
    apply (auto simp add: nth_to_bl nth_takefill bit_revcast_iff)
   done
 
 lemma word_cat_bl: "word_cat a b = of_bl (to_bl a @ to_bl b)"
   apply (rule bit_word_eqI)
   apply (simp add: bit_word_cat_iff bit_of_bl_iff nth_append not_less nth_rev_to_bl)
   apply (meson bit_word.rep_eq less_diff_conv2 nth_rev_to_bl)
   done
 
 lemma of_bl_append:
   "(of_bl (xs @ ys) :: 'a::len word) = of_bl xs * 2^(length ys) + of_bl ys"
   apply transfer
   apply (simp add: bl_to_bin_app_cat bin_cat_num)
   done
 
 lemma of_bl_False [simp]: "of_bl (False#xs) = of_bl xs"
   by (rule word_eqI) (auto simp: test_bit_of_bl nth_append)
 
 lemma of_bl_True [simp]: "(of_bl (True # xs) :: 'a::len word) = 2^length xs + of_bl xs"
   by (subst of_bl_append [where xs="[True]", simplified]) (simp add: word_1_bl)
 
 lemma of_bl_Cons: "of_bl (x#xs) = of_bool x * 2^length xs + of_bl xs"
   by (cases x) simp_all
 
 lemma word_split_bl':
   "std = size c - size b \<Longrightarrow> (word_split c = (a, b)) \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c)))"
   apply (simp add: word_split_def)
   apply transfer
   apply (cases \<open>LENGTH('b) \<le> LENGTH('a)\<close>)
    apply (auto simp add: drop_bit_take_bit drop_bin2bl bin_to_bl_drop_bit [symmetric, of \<open>LENGTH('a)\<close> \<open>LENGTH('a) - LENGTH('b)\<close> \<open>LENGTH('b)\<close>] min_absorb2)
   done
 
 lemma word_split_bl: "std = size c - size b \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c))) \<longleftrightarrow>
     word_split c = (a, b)"
   apply (rule iffI)
    defer
    apply (erule (1) word_split_bl')
   apply (case_tac "word_split c")
   apply (auto simp add: word_size)
   apply (frule word_split_bl' [rotated])
    apply (auto simp add: word_size)
   done
 
 lemma word_split_bl_eq:
   "(word_split c :: ('c::len word \<times> 'd::len word)) =
     (of_bl (take (LENGTH('a::len) - LENGTH('d::len)) (to_bl c)),
      of_bl (drop (LENGTH('a) - LENGTH('d)) (to_bl c)))"
   for c :: "'a::len word"
   apply (rule word_split_bl [THEN iffD1])
    apply (unfold word_size)
    apply (rule refl conjI)+
   done
 
 lemma word_rcat_bl:
   \<open>word_rcat wl = of_bl (concat (map to_bl wl))\<close>
 proof -
   define ws where \<open>ws = rev wl\<close>
   moreover have \<open>word_rcat (rev ws) = of_bl (concat (map to_bl (rev ws)))\<close>
     apply (simp add: word_rcat_def of_bl_eq rev_concat rev_map comp_def rev_to_bl_eq flip: horner_sum_of_bool_2_concat)
     apply transfer
     apply simp
     done
   ultimately show ?thesis
     by simp
 qed
 
 lemma size_rcat_lem': "size (concat (map to_bl wl)) = length wl * size (hd wl)"
   by (induct wl) (auto simp: word_size)
 
 lemmas size_rcat_lem = size_rcat_lem' [unfolded word_size]
 
 lemma nth_rcat_lem:
   "n < length (wl::'a word list) * LENGTH('a::len) \<Longrightarrow>
     rev (concat (map to_bl wl)) ! n =
     rev (to_bl (rev wl ! (n div LENGTH('a)))) ! (n mod LENGTH('a))"
   apply (induct wl)
    apply clarsimp
   apply (clarsimp simp add : nth_append size_rcat_lem)
   apply (simp flip: mult_Suc minus_div_mult_eq_mod add: less_Suc_eq_le not_less)
   apply (metis (no_types, lifting) diff_is_0_eq div_le_mono len_not_eq_0 less_Suc_eq less_mult_imp_div_less nonzero_mult_div_cancel_right not_le nth_Cons_0)
   done
 
 lemma foldl_eq_foldr: "foldl (+) x xs = foldr (+) (x # xs) 0"
   for x :: "'a::comm_monoid_add"
   by (induct xs arbitrary: x) (auto simp: add.assoc)
 
 lemmas word_cat_bl_no_bin [simp] =
   word_cat_bl [where a="numeral a" and b="numeral b", unfolded to_bl_numeral]
   for a b (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_split_bl_no_bin [simp] =
   word_split_bl_eq [where c="numeral c", unfolded to_bl_numeral] for c
 
 lemmas word_rot_defs = word_roti_eq_word_rotr_word_rotl word_rotr_eq word_rotl_eq
 
 lemma to_bl_rotl: "to_bl (word_rotl n w) = rotate n (to_bl w)"
   by (simp add: word_rotl_eq to_bl_use_of_bl)
 
 lemmas blrs0 = rotate_eqs [THEN to_bl_rotl [THEN trans]]
 
 lemmas word_rotl_eqs =
   blrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotl [symmetric]]
 
 lemma to_bl_rotr: "to_bl (word_rotr n w) = rotater n (to_bl w)"
   by (simp add: word_rotr_eq to_bl_use_of_bl)
 
 lemmas brrs0 = rotater_eqs [THEN to_bl_rotr [THEN trans]]
 
 lemmas word_rotr_eqs =
   brrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotr [symmetric]]
 
 declare word_rotr_eqs (1) [simp]
 declare word_rotl_eqs (1) [simp]
 
 lemmas abl_cong = arg_cong [where f = "of_bl"]
 
 end
 
 locale word_rotate
 begin
 
 lemmas word_rot_defs' = to_bl_rotl to_bl_rotr
 
 lemmas blwl_syms [symmetric] = bl_word_not bl_word_and bl_word_or bl_word_xor
 
 lemmas lbl_lbl = trans [OF word_bl_Rep' word_bl_Rep' [symmetric]]
 
 lemmas ths_map2 [OF lbl_lbl] = rotate_map2 rotater_map2
 
 lemmas ths_map [where xs = "to_bl v"] = rotate_map rotater_map for v
 
 lemmas th1s [simplified word_rot_defs' [symmetric]] = ths_map2 ths_map
 
 end
 
 lemmas bl_word_rotl_dt = trans [OF to_bl_rotl rotate_drop_take,
   simplified word_bl_Rep']
 
 lemmas bl_word_rotr_dt = trans [OF to_bl_rotr rotater_drop_take,
   simplified word_bl_Rep']
 
 lemma bl_word_roti_dt':
   "n = nat ((- i) mod int (size (w :: 'a::len word))) \<Longrightarrow>
     to_bl (word_roti i w) = drop n (to_bl w) @ take n (to_bl w)"
   apply (unfold word_roti_eq_word_rotr_word_rotl)
   apply (simp add: bl_word_rotl_dt bl_word_rotr_dt word_size)
   apply safe
    apply (simp add: zmod_zminus1_eq_if)
    apply safe
     apply (auto simp add: nat_mult_distrib nat_mod_distrib)
   using nat_0_le nat_minus_as_int zmod_int apply presburger
   done
 
 lemmas bl_word_roti_dt = bl_word_roti_dt' [unfolded word_size]
 
 lemmas word_rotl_dt = bl_word_rotl_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_rotr_dt = bl_word_rotr_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_roti_dt = bl_word_roti_dt [THEN word_bl.Rep_inverse' [symmetric]]
 
 lemmas word_rotr_dt_no_bin' [simp] =
   word_rotr_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_rotl_dt_no_bin' [simp] =
   word_rotl_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemma max_word_bl: "to_bl (- 1::'a::len word) = replicate LENGTH('a) True"
   by (fact to_bl_n1)
 
 lemma to_bl_mask:
   "to_bl (mask n :: 'a::len word) =
   replicate (LENGTH('a) - n) False @
     replicate (min (LENGTH('a)) n) True"
   by (simp add: mask_bl word_rep_drop min_def)
 
 lemma map_replicate_True:
   "n = length xs \<Longrightarrow>
     map (\<lambda>(x,y). x \<and> y) (zip xs (replicate n True)) = xs"
   by (induct xs arbitrary: n) auto
 
 lemma map_replicate_False:
   "n = length xs \<Longrightarrow> map (\<lambda>(x,y). x \<and> y)
     (zip xs (replicate n False)) = replicate n False"
   by (induct xs arbitrary: n) auto
 
 context
   includes bit_operations_syntax
 begin
 
 lemma bl_and_mask:
   fixes w :: "'a::len word"
     and n :: nat
   defines "n' \<equiv> LENGTH('a) - n"
   shows "to_bl (w AND mask n) = replicate n' False @ drop n' (to_bl w)"
 proof -
   note [simp] = map_replicate_True map_replicate_False
   have "to_bl (w AND mask n) = map2 (\<and>) (to_bl w) (to_bl (mask n::'a::len word))"
     by (simp add: bl_word_and)
   also have "to_bl w = take n' (to_bl w) @ drop n' (to_bl w)"
     by simp
   also have "map2 (\<and>) \<dots> (to_bl (mask n::'a::len word)) =
       replicate n' False @ drop n' (to_bl w)"
     unfolding to_bl_mask n'_def by (subst zip_append) auto
   finally show ?thesis .
 qed
 
 lemma drop_rev_takefill:
   "length xs \<le> n \<Longrightarrow>
     drop (n - length xs) (rev (takefill False n (rev xs))) = xs"
   by (simp add: takefill_alt rev_take)
 
 declare bin_to_bl_def [simp]
 
 lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append
 
 lemma uint_of_bl_is_bl_to_bin_drop:
   "length (dropWhile Not l) \<le> LENGTH('a) \<Longrightarrow> uint (of_bl l :: 'a::len word) = bl_to_bin l"
   apply transfer
   apply (simp add: take_bit_eq_mod)
   apply (rule Divides.mod_less)
    apply (rule bl_to_bin_ge0)
   using bl_to_bin_lt2p_drop apply (rule order.strict_trans2)
   apply simp
   done
 
 corollary uint_of_bl_is_bl_to_bin:
   "length l\<le>LENGTH('a) \<Longrightarrow> uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
   apply(rule uint_of_bl_is_bl_to_bin_drop)
   using le_trans length_dropWhile_le by blast
 
 lemma bin_to_bl_or:
   "bin_to_bl n (a OR b) = map2 (\<or>) (bin_to_bl n a) (bin_to_bl n b)"
   using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
   by simp
 
 lemma word_and_1_bl:
   fixes x::"'a::len word"
   shows "(x AND 1) = of_bl [bit x 0]"
   by (simp add: word_and_1)
 
 lemma word_1_and_bl:
   fixes x::"'a::len word"
   shows "(1 AND x) = of_bl [bit x 0]"
   using word_and_1_bl [of x] by (simp add: ac_simps)
 
 lemma of_bl_drop:
   "of_bl (drop n xs) = (of_bl xs AND mask (length xs - n))"
   apply (rule bit_word_eqI)
   apply (auto simp: rev_nth bit_simps cong: rev_conj_cong)
   done
 
 lemma to_bl_1:
   "to_bl (1::'a::len word) = replicate (LENGTH('a) - 1) False @ [True]"
   by (rule nth_equalityI) (auto simp add: to_bl_unfold nth_append rev_nth bit_1_iff not_less not_le)
 
 lemma eq_zero_set_bl:
   "(w = 0) = (True \<notin> set (to_bl w))"
   apply (auto simp add: to_bl_unfold)
   apply (rule bit_word_eqI)
   apply auto
   done
 
 lemma of_drop_to_bl:
   "of_bl (drop n (to_bl x)) = (x AND mask (size x - n))"
   by (simp add: of_bl_drop word_size_bl)
 
 lemma unat_of_bl_length:
   "unat (of_bl xs :: 'a::len word) < 2 ^ (length xs)"
 proof (cases "length xs < LENGTH('a)")
   case True
   then have "(of_bl xs::'a::len word) < 2 ^ length xs"
     by (simp add: of_bl_length_less)
   with True
   show ?thesis
     by (simp add: word_less_nat_alt unat_of_nat)
 next
   case False
   have "unat (of_bl xs::'a::len word) < 2 ^ LENGTH('a)"
     by (simp split: unat_split)
   also
   from False
   have "LENGTH('a) \<le> length xs" by simp
   then have "2 ^ LENGTH('a) \<le> (2::nat) ^ length xs"
     by (rule power_increasing) simp
   finally
   show ?thesis .
 qed
 
 lemma word_msb_alt: "msb w \<longleftrightarrow> hd (to_bl w)"
   for w :: "'a::len word"
   apply (simp add: msb_word_eq)
   apply (subst hd_conv_nth)
    apply simp
   apply (subst nth_to_bl)
    apply simp
   apply simp
   done
 
 lemma word_lsb_last:
   \<open>lsb w \<longleftrightarrow> last (to_bl w)\<close>
   for w :: \<open>'a::len word\<close>
   using nth_to_bl [of \<open>LENGTH('a) - Suc 0\<close> w]
   by (simp add: last_conv_nth bit_0 lsb_odd)
 
 lemma is_aligned_to_bl:
   "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
   by (simp add: is_aligned_mask eq_zero_set_bl bl_and_mask word_size)
 
 lemma is_aligned_replicate:
   fixes w::"'a::len word"
   assumes aligned: "is_aligned w n"
   and          nv: "n \<le> LENGTH('a)"
   shows   "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
   apply (rule nth_equalityI)
   using assms apply (simp_all add: nth_append not_less word_size to_bl_nth is_aligned_imp_not_bit)
   done
 
 lemma is_aligned_drop:
   fixes w::"'a::len word"
   assumes "is_aligned w n" "n \<le> LENGTH('a)"
   shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
 proof -
   have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
     by (rule is_aligned_replicate) fact+
   then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
   also have "\<dots> = replicate n False" by simp
   finally show ?thesis .
 qed
 
 lemma less_is_drop_replicate:
   fixes x::"'a::len word"
   assumes lt: "x < 2 ^ n"
   shows   "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
   by (metis assms bl_and_mask' less_mask_eq)
 
 lemma is_aligned_add_conv:
   fixes off::"'a::len word"
   assumes aligned: "is_aligned w n"
   and        offv: "off < 2 ^ n"
   shows    "to_bl (w + off) =
    (take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
 proof cases
   assume nv: "n \<le> LENGTH('a)"
   show ?thesis
   proof (subst aligned_bl_add_size, simp_all only: word_size)
     show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
       by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)
 
     from offv show "take (LENGTH('a) - n) (to_bl off) =
                     replicate (LENGTH('a) - n) False"
       by (subst less_is_drop_replicate, assumption) simp
   qed fact
 next
   assume "\<not> n \<le> LENGTH('a)"
   with offv show ?thesis by (simp add: power_overflow)
 qed
 
 lemma is_aligned_replicateI:
   "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
   apply (simp add: is_aligned_to_bl word_size)
   apply (subgoal_tac "length addr = LENGTH('a) - n")
    apply (simp add: replicate_not_True)
   apply (drule arg_cong [where f=length])
   apply simp
   done
 
 lemma to_bl_2p:
   "n < LENGTH('a) \<Longrightarrow>
    to_bl ((2::'a::len word) ^ n) =
    replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
   apply (rule nth_equalityI)
    apply (auto simp add: nth_append to_bl_nth word_size bit_simps not_less nth_Cons le_diff_conv)
   subgoal for i
   apply (cases \<open>Suc (i + n) - LENGTH('a)\<close>)
   apply simp_all
     done
   done
 
 lemma xor_2p_to_bl:
   fixes x::"'a::len word"
   shows "to_bl (x XOR 2^n) =
   (if n < LENGTH('a)
    then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
    else to_bl x)"
   apply (auto simp add: to_bl_eq_rev take_map drop_map take_rev drop_rev bit_simps)
   apply (rule nth_equalityI)
    apply (auto simp add: bit_simps rev_nth nth_append Suc_diff_Suc)
   done
 
 lemma is_aligned_replicateD:
   "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
      \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
                \<and> length xs = size w - n"
   apply (subst is_aligned_replicate, assumption+)
   apply (rule exI, rule conjI, rule refl)
   apply (simp add: word_size)
   done
 
 text \<open>right-padding a word to a certain length\<close>
 
 definition
   "bl_pad_to bl sz \<equiv> bl @ (replicate (sz - length bl) False)"
 
 lemma bl_pad_to_length:
   assumes lbl: "length bl \<le> sz"
   shows   "length (bl_pad_to bl sz) = sz"
   using lbl by (simp add: bl_pad_to_def)
 
 lemma bl_pad_to_prefix:
   "prefix bl (bl_pad_to bl sz)"
   by (simp add: bl_pad_to_def)
 
 
 lemma of_bl_length:
   "length xs < LENGTH('a) \<Longrightarrow> of_bl xs < (2 :: 'a::len word) ^ length xs"
   by (simp add: of_bl_length_less)
 
 lemma of_bl_mult_and_not_mask_eq:
   "\<lbrakk>is_aligned (a :: 'a::len word) n; length b + m \<le> n\<rbrakk>
    \<Longrightarrow> a + of_bl b * (2^m) AND NOT(mask n) = a"
   apply (simp flip: push_bit_eq_mult subtract_mask(1) take_bit_eq_mask)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (simp add: take_bit_push_bit)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   done
 
 lemma bin_to_bl_of_bl_eq:
   "\<lbrakk>is_aligned (a::'a::len word) n; length b + c \<le> n; length b + c < LENGTH('a)\<rbrakk>
   \<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 2^c) >> c)) = b"
   apply (simp flip: push_bit_eq_mult take_bit_eq_mask)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less unsigned_or_eq unsigned_drop_bit_eq
      unsigned_push_bit_eq bin_to_bl_or simp flip: bin_to_bl_def)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (rule nth_equalityI)
    apply (auto simp add: nth_bin_to_bl bit_simps rev_nth simp flip: bin_to_bl_def)
   done
 
 (* casting a long word to a shorter word and casting back to the long word
    is equal to the original long word -- if the word is small enough.
   'l is the longer word.
   's is the shorter word.
 *)
 lemma bl_cast_long_short_long_ingoreLeadingZero_generic:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (of_bl :: _ \<Rightarrow> 'l::len word) (to_bl ((of_bl::_ \<Rightarrow> 's::len word) (to_bl w))) = w"
   by (rule word_uint_eqI) (simp add: uint_of_bl_is_bl_to_bin uint_of_bl_is_bl_to_bin_drop)
 
 (*
  Casting between longer and shorter word.
   'l is the longer word.
   's is the shorter word.
  For example: 'l::len word is 128 word (full ipv6 address)
               's::len word is 16 word (address piece of ipv6 address in colon-text-representation)
 *)
 corollary ucast_short_ucast_long_ingoreLeadingZero:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (ucast:: 's::len word \<Rightarrow> 'l::len word) ((ucast:: 'l::len word \<Rightarrow> 's::len word) w) = w"
   apply (subst ucast_bl)+
   apply (rule bl_cast_long_short_long_ingoreLeadingZero_generic; simp)
   done
 
 lemma length_drop_mask:
   fixes w::"'a::len word"
   shows "length (dropWhile Not (to_bl (w AND mask n))) \<le> n"
 proof -
   have "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
     for ls n by(subst takeWhile_append2) simp+
   then show ?thesis
     unfolding bl_and_mask by (simp add: dropWhile_eq_drop)
 qed
 
 lemma map_bits_rev_to_bl:
   "map (bit x) [0..<size x] = rev (to_bl x)"
   by (auto simp: list_eq_iff_nth_eq test_bit_bl word_size)
 
 lemma of_bl_length2:
   "length xs + c < LENGTH('a) \<Longrightarrow> of_bl xs * 2^c < (2::'a::len word) ^ (length xs + c)"
   by (simp add: of_bl_length word_less_power_trans2)
 
 lemma of_bl_max:
   "(of_bl xs :: 'a::len word) \<le> mask (length xs)"
 proof -
   define ys where \<open>ys = rev xs\<close>
   have \<open>take_bit (length ys) (horner_sum of_bool 2 ys :: 'a word) = horner_sum of_bool 2 ys\<close>
     by transfer (simp add: take_bit_horner_sum_bit_eq min_def)
   then have \<open>(of_bl (rev ys) :: 'a word) \<le> mask (length ys)\<close>
     by (simp only: of_bl_rev_eq less_eq_mask_iff_take_bit_eq_self)
   with ys_def show ?thesis
     by simp
 qed
 
 text\<open>Some auxiliaries for sign-shifting by the entire word length or more\<close>
 
 lemma sshiftr_clamp_pos:
   assumes
     "LENGTH('a) \<le> n"
     "0 \<le> sint x"
   shows "(x::'a::len word) >>> n = 0"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 lemma sshiftr_clamp_neg:
   assumes
     "LENGTH('a) \<le> n"
     "sint x < 0"
   shows "(x::'a::len word) >>> n = -1"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 lemma sshiftr_clamp:
   assumes "LENGTH('a) \<le> n"
   shows "(x::'a::len word) >>> n = x >>> LENGTH('a)"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 text\<open>
 Like @{thm shiftr1_bl_of}, but the precondition is stronger because we need to pick the msb out of
 the list.
 \<close>
 lemma sshiftr1_bl_of:
   "length bl = LENGTH('a) \<Longrightarrow>
     sshiftr1 (of_bl bl::'a::len word) = of_bl (hd bl # butlast bl)"
   apply (rule word_bl.Rep_eqD)
   apply (subst bl_sshiftr1[of "of_bl bl :: 'a word"])
   by (simp add: word_bl.Abs_inverse)
 
 text\<open>
 Like @{thm sshiftr1_bl_of}, with a weaker precondition.
 We still get a direct equation for @{term \<open>sshiftr1 (of_bl bl)\<close>}, it's just uglier.
 \<close>
 lemma sshiftr1_bl_of':
   "LENGTH('a) \<le> length bl \<Longrightarrow>
     sshiftr1 (of_bl bl::'a::len word) =
     of_bl (hd (drop (length bl - LENGTH('a)) bl) # butlast (drop (length bl - LENGTH('a)) bl))"
   apply (subst of_bl_drop'[symmetric, of "length bl - LENGTH('a)"])
   using sshiftr1_bl_of[of "drop (length bl - LENGTH('a)) bl"]
   by auto
 
 text\<open>
 Like @{thm shiftr_bl_of}.
 \<close>
 lemma sshiftr_bl_of:
   assumes "length bl = LENGTH('a)"
   shows "(of_bl bl::'a::len word) >>> n = of_bl (replicate n (hd bl) @ take (length bl - n) bl)"
 proof -
   from assms obtain b bs where \<open>bl = b # bs\<close>
     by (cases bl) simp_all
   then have *: \<open>bl ! 0 \<longleftrightarrow> b\<close> \<open>hd bl \<longleftrightarrow> b\<close>
     by simp_all
   show ?thesis
   apply (rule bit_word_eqI)
     using assms * by (auto simp add: bit_simps nth_append rev_nth not_less)
 qed
 
 text\<open>Like @{thm shiftr_bl}\<close>
 lemma sshiftr_bl: "x >>> n \<equiv> of_bl (replicate n (msb x) @ take (LENGTH('a) - n) (to_bl x))"
   for x :: "'a::len word"
   unfolding word_msb_alt
   by (smt (z3) length_to_bl_eq sshiftr_bl_of word_bl.Rep_inverse)
 
 end
 
 lemma of_bl_drop_eq_take_bit:
   \<open>of_bl (drop n xs) = take_bit (length xs - n) (of_bl xs)\<close>
   by (simp add: of_bl_drop take_bit_eq_mask)
 
 lemma of_bl_take_to_bl_eq_drop_bit:
   \<open>of_bl (take n (to_bl w)) = drop_bit (LENGTH('a) - n) w\<close>
     if \<open>n \<le> LENGTH('a)\<close>
     for w :: \<open>'a::len word\<close>
   using that shiftr_bl [of w \<open>LENGTH('a) - n\<close>] by (simp add: shiftr_def)
 
 end