diff --git a/thys/Auto2_HOL/HOL/Lists_Thms.thy b/thys/Auto2_HOL/HOL/Lists_Thms.thy
--- a/thys/Auto2_HOL/HOL/Lists_Thms.thy
+++ b/thys/Auto2_HOL/HOL/Lists_Thms.thy
@@ -1,300 +1,302 @@
 (*
   File: Lists_Thms.thy
   Author: Bohua Zhan
 
   Setup for proof steps related to lists.
 *)
 
 section \<open>Setup for lists\<close>
 
 theory Lists_Thms
   imports Set_Thms
 begin
 
 subsection \<open>Definition of lists\<close>
 
 setup \<open>add_resolve_prfstep @{thm list.distinct(2)}\<close>
 setup \<open>add_forward_prfstep (equiv_forward_th @{thm list.simps(1)})\<close>
 setup \<open>fold add_rewrite_rule @{thms List.list.sel}\<close>
 setup \<open>add_rewrite_rule @{thm list.collapse}\<close>
 setup \<open>add_var_induct_rule @{thm list.induct}\<close>
 
 subsection \<open>Length\<close>
 
 setup \<open>add_rewrite_rule @{thm List.list.size(3)}\<close>
 lemma length_one [rewrite]: "length [x] = 1" by simp
 lemma length_Cons [rewrite]: "length (a # b) = length b + 1" by simp
 lemma length_snoc [rewrite]: "length (xs @ [x]) = length xs + 1" by auto
 lemma length_zero_is_nil [forward]: "length xs = 0 \<Longrightarrow> xs = []" by simp
 lemma length_gt_zero [forward]: "length xs > 0 \<Longrightarrow> xs \<noteq> []" by simp
 
 subsection \<open>Append\<close>
 
 setup \<open>add_rewrite_rule @{thm List.length_append}\<close>
 setup \<open>add_rewrite_rule_cond @{thm List.append.simps(2)} [with_cond "?xs \<noteq> []"]\<close>
 setup \<open>add_rewrite_rule @{thm List.hd_append2}\<close>
 lemma append_is_empty [forward]: "xs @ ys = [] \<Longrightarrow> xs = [] \<and> ys = []" by simp
 
 lemma cons_to_append [rewrite_back]: "a # b = [a] @ b" by simp
 
 ML_file \<open>list_ac.ML\<close>
 ML_file \<open>list_ac_test.ML\<close>
 
 subsection \<open>Showing two lists are equal\<close>
 
 setup \<open>add_backward2_prfstep_cond @{thm nth_equalityI} [with_filt (order_filter "xs" "ys")]\<close>
 
 subsection \<open>Set of elements of a list\<close>
 
 setup \<open>add_rewrite_rule @{thm List.set_simps(1)}\<close>
 lemma set_one [rewrite]: "set [u] = {u}" by simp
 lemma set_two [rewrite]: "set [u, v] = {u, v}" by simp
 lemma set_simps2: "set (x # xs) = {x} \<union> set xs" by simp
 setup \<open>add_rewrite_rule_cond @{thm set_simps2} [with_cond "?xs \<noteq> []", with_cond "?xs \<noteq> [?y]"]\<close>
 setup \<open>add_rewrite_rule @{thm List.set_append}\<close>
 setup \<open>add_rewrite_rule @{thm List.set_rev}\<close>
 setup \<open>add_resolve_prfstep @{thm List.finite_set}\<close>
 setup \<open>add_backward_prfstep (equiv_forward_th @{thm in_set_conv_nth})\<close>
 
 subsection \<open>hd\<close>
 
 setup \<open>register_wellform_data ("hd xs", ["xs \<noteq> []"])\<close>
 setup \<open>add_forward_prfstep_cond @{thm List.hd_in_set} [with_term "hd ?xs"]\<close>
 
 subsection \<open>tl\<close>
 
 setup \<open>add_rewrite_rule @{thm length_tl}\<close>
 lemma nth_tl' [rewrite]: "i < length (tl xs) \<Longrightarrow> tl xs ! i = xs ! (i + 1)"
   by (simp add: nth_tl)
 lemma set_tl_subset [forward_arg1]: "set (tl xs) \<subseteq> set xs"
   by (metis list.set_sel(2) subsetI tl_Nil)
 
 subsection \<open>nth\<close>
 
 setup \<open>register_wellform_data ("xs ! i", ["i < length xs"])\<close>
 setup \<open>add_prfstep_check_req ("xs ! i", "i < length xs")\<close>
 setup \<open>add_rewrite_rule_back @{thm hd_conv_nth}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_Cons'}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_append}\<close>
 setup \<open>add_forward_prfstep_cond @{thm nth_mem} [with_term "?xs ! ?n"]\<close>
 
 subsection \<open>sorted\<close>
 
 lemma sorted_Nil [resolve]: "sorted []" by simp
 lemma sorted_single [resolve]: "sorted [x]" by simp
-setup \<open>add_backward_prfstep (equiv_backward_th @{thm sorted.simps(2)})\<close>
+setup \<open>add_backward_prfstep (equiv_backward_th @{thm sorted_simps(2)})\<close>
 
 lemma sorted_ConsD1 [forward]: "sorted (x # xs) \<Longrightarrow> sorted xs"
-  using sorted.simps(2) by blast
+  by simp
 lemma sorted_ConsD2 [forward, backward2]: "sorted (x # xs) \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<le> y"
-  using sorted.simps(2) by blast
+  by simp
 
 lemma sorted_appendI [backward]:
   "sorted xs \<and> sorted ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<le> y) \<Longrightarrow> sorted (xs @ ys)"
   by (simp add: sorted_append)
 
 lemma sorted_appendE [forward]: "sorted (xs @ ys) \<Longrightarrow> sorted xs \<and> sorted ys"
   by (simp add: sorted_append)
 
 lemma sorted_appendE2 [forward]:
   "sorted (xs @ ys) \<Longrightarrow> x \<in> set xs \<Longrightarrow> \<forall>y\<in>set ys. x \<le> y"
   using sorted_append by blast
 
 lemma sorted_nth_mono' [backward]:
   "sorted xs \<Longrightarrow> j < length xs \<Longrightarrow> i \<le> j \<Longrightarrow> xs ! i \<le> xs ! j" using sorted_nth_mono by auto
 
+(*NOT CLEAR WHY THIS THEOREM IS CURRENTLY REJECTED WHEN IT WAS ALLOWED BEFORE:
+  "gen_prfstep: new schematic variable in pats_r / cases"
 lemma sorted_nth_mono_less [forward]:
   "sorted xs \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i < xs ! j \<Longrightarrow> i < j" by (meson leD not_le_imp_less sorted_nth_mono)
-
+*)
 subsection \<open>sort\<close>
 
 setup \<open>add_forward_prfstep_cond @{thm sorted_sort} [with_term "sort ?xs"]\<close>
 setup \<open>add_rewrite_rule @{thm length_sort}\<close>
 setup \<open>add_rewrite_rule @{thm mset_sort}\<close>
 setup \<open>add_rewrite_rule @{thm set_sort}\<close>
 setup \<open>add_backward_prfstep @{thm properties_for_sort}\<close>
 lemma sort_Nil [rewrite]: "sort [] = []" by auto
 lemma sort_singleton [rewrite]: "sort [a] = [a]" by auto
 
 subsection \<open>distinct\<close>
   
 lemma distinct_Nil [resolve]: "distinct []" by simp
 setup \<open>add_resolve_prfstep @{thm List.distinct_singleton}\<close>
 setup \<open>add_rewrite_rule_cond @{thm distinct.simps(2)} [with_cond "?xs \<noteq> []"]\<close>
 setup \<open>add_rewrite_rule @{thm distinct_append}\<close>
 setup \<open>add_rewrite_rule @{thm distinct_rev}\<close>
 setup \<open>add_rewrite_rule @{thm distinct_sort}\<close>
 setup \<open>add_resolve_prfstep (equiv_backward_th @{thm distinct_conv_nth})\<close>
 
 lemma distinct_nthE [forward]:
   "distinct xs \<Longrightarrow> i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> xs ! i = xs ! j \<Longrightarrow> i = j"
   using nth_eq_iff_index_eq by blast
 
 subsection \<open>map function\<close>
 
 setup \<open>fold add_rewrite_rule @{thms List.list.map}\<close>
 setup \<open>add_rewrite_rule @{thm List.length_map}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_map}\<close>
 setup \<open>add_rewrite_rule @{thm List.map_append}\<close>
 
 subsection \<open>Replicate\<close>
 
 setup \<open>add_rewrite_arg_rule @{thm length_replicate}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_replicate}\<close>
 
 subsection \<open>last\<close>
 
 setup \<open>register_wellform_data ("last xs", ["xs \<noteq> []"])\<close>
 lemma last_eval1 [rewrite]: "last [x] = x" by simp
 lemma last_eval2 [rewrite]: "last [u, v] = v" by simp
 setup \<open>add_rewrite_rule @{thm List.last_ConsR}\<close>
 setup \<open>add_rewrite_rule @{thm List.last_appendR}\<close>
 setup \<open>add_rewrite_rule @{thm List.last_snoc}\<close>
 setup \<open>add_rewrite_rule_back @{thm last_conv_nth}\<close>
 setup \<open>add_forward_prfstep_cond @{thm List.last_in_set} [with_term "last ?as"]\<close>
 
 subsection \<open>butlast\<close>
 
 setup \<open>add_rewrite_arg_rule @{thm List.length_butlast}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_butlast}\<close>
 setup \<open>add_rewrite_rule_back @{thm List.butlast_conv_take}\<close>
 setup \<open>add_rewrite_rule @{thm List.butlast_snoc}\<close>
 lemma butlast_eval1 [rewrite]: "butlast [x] = []" by simp
 lemma butlast_eval2 [rewrite]: "butlast [x, y] = [x]" by simp
 lemma butlast_cons [rewrite]: "as \<noteq> [] \<Longrightarrow> butlast (a # as) = a # butlast as" by simp
 lemma butlast_append' [rewrite]: "bs \<noteq> [] \<Longrightarrow> butlast (as @ bs) = as @ butlast bs"
   by (simp add: butlast_append)
 
 setup \<open>add_rewrite_rule @{thm List.append_butlast_last_id}\<close>
 lemma set_butlast_is_subset: "set (butlast xs) \<subseteq> set xs" by (simp add: in_set_butlastD subsetI)
 setup \<open>add_forward_arg1_prfstep @{thm set_butlast_is_subset}\<close>
 
 subsection \<open>List update\<close>
 
 setup \<open>register_wellform_data ("xs[i := x]", ["i < length xs"])\<close>
 setup \<open>add_rewrite_arg_rule @{thm List.length_list_update}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_list_update_eq}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_list_update_neq}\<close>
 setup \<open>add_rewrite_rule @{thm List.nth_list_update}\<close>
 
 subsection \<open>take\<close>
 
 setup \<open>register_wellform_data ("take n xs", ["n \<le> length xs"])\<close>
 setup \<open>add_prfstep_check_req ("take n xs", "n \<le> length xs")\<close>
 
 lemma length_take [rewrite_arg]: "n \<le> length xs \<Longrightarrow> length (take n xs) = n" by simp
 lemma nth_take [rewrite]: "i < length (take n xs) \<Longrightarrow> take n xs ! i = xs ! i" by simp
 
 setup \<open>add_rewrite_rule @{thm List.take_0}\<close>
 setup \<open>add_rewrite_rule @{thm List.take_Suc_conv_app_nth}\<close>
 lemma take_length [rewrite]: "take (length xs) xs = xs" by simp
 
 setup \<open>add_forward_arg1_prfstep @{thm List.set_take_subset}\<close>
 
 lemma take_Suc [rewrite]: "Suc n \<le> length xs \<Longrightarrow> take (Suc n) xs = take n xs @ [nth xs n]"
   using Suc_le_lessD take_Suc_conv_app_nth by blast
 
 setup \<open>add_rewrite_rule @{thm List.take_update_cancel}\<close>
 setup \<open>add_rewrite_rule @{thm List.append_take_drop_id}\<close>
 setup \<open>add_rewrite_rule @{thm List.take_all}\<close>
 
 subsection \<open>drop\<close>
 
 setup \<open>add_rewrite_arg_rule @{thm List.length_drop}\<close>
 lemma nth_drop [rewrite]:
   "i < length (drop n xs) \<Longrightarrow> drop n xs ! i = xs ! (n + i)" by simp
 
 setup \<open>add_rewrite_rule @{thm List.drop_0}\<close>
 setup \<open>add_rewrite_rule @{thm List.drop_all}\<close>
 setup \<open>add_rewrite_rule_back @{thm List.take_drop}\<close>
 setup \<open>add_rewrite_rule @{thm List.drop_drop}\<close>
 
 subsection \<open>rev\<close>
 
 setup \<open>add_rewrite_arg_rule @{thm List.length_rev}\<close>
 setup \<open>fold add_rewrite_rule @{thms List.rev.simps}\<close>
 setup \<open>add_rewrite_rule @{thm List.rev_append}\<close>
 setup \<open>add_rewrite_rule @{thm List.rev_rev_ident}\<close>
 
 subsection \<open>filter\<close>
 
 setup \<open>fold add_rewrite_rule @{thms filter.simps}\<close>
 setup \<open>add_rewrite_rule @{thm filter_append}\<close>
 setup \<open>add_rewrite_rule_bidir @{thm rev_filter}\<close>
 
 subsection \<open>concat\<close>
 
 setup \<open>fold add_rewrite_rule @{thms concat.simps}\<close>
 
 subsection \<open>mset\<close>
 
 setup \<open>add_rewrite_rule @{thm mset.simps(1)}\<close>
 lemma mset_simps_2 [rewrite]: "mset (a # x) = mset x + {#a#}" by simp
 setup \<open>add_rewrite_rule @{thm mset_append}\<close>
 
 setup \<open>add_rewrite_rule @{thm mset_eq_setD}\<close>
 setup \<open>add_rewrite_rule_cond @{thm in_multiset_in_set} [with_term "set ?xs"]\<close>
 setup \<open>add_rewrite_rule_back_cond @{thm in_multiset_in_set} [with_term "mset ?xs"]\<close>
 setup \<open>add_backward_prfstep @{thm Multiset.nth_mem_mset}\<close>
 
 lemma in_mset_conv_nth [resolve]: "x \<in># mset xs \<Longrightarrow> \<exists>i<length xs. x = xs ! i"
   by (metis in_multiset_in_set in_set_conv_nth)
 
 lemma hd_in_mset: "xs \<noteq> [] \<Longrightarrow> hd xs \<in># mset xs" by simp
 setup \<open>add_forward_prfstep_cond @{thm hd_in_mset} [with_term "hd ?xs", with_term "mset ?xs"]\<close>
 
 lemma last_in_mset: "xs \<noteq> [] \<Longrightarrow> last xs \<in># mset xs" by simp
 setup \<open>add_forward_prfstep_cond @{thm last_in_mset} [with_term "last ?xs", with_term "mset ?xs"]\<close>
 
 subsection \<open>Relationship between mset and set of lists\<close>
 
 lemma mset_butlast [rewrite]: "xs \<noteq> [] \<Longrightarrow> mset (butlast xs) = mset xs - {# last xs #}"
   by (metis add_diff_cancel_right' append_butlast_last_id mset.simps(1) mset.simps(2) union_code)
 
 lemma insert_mset_to_set [rewrite]: "mset xs' = mset xs + {# x #} \<Longrightarrow> set xs' = set xs \<union> {x}"
   by (metis set_mset_mset set_mset_single set_mset_union)
 
 lemma delete_mset_to_set [rewrite]:
   "distinct xs \<Longrightarrow> mset xs' = mset xs - {# x #} \<Longrightarrow> set xs' = set xs - {x}"
   by (metis mset_eq_setD mset_remove1 set_remove1_eq)
 
 lemma update_mset_to_set [rewrite]:
   "distinct xs \<Longrightarrow> mset xs' = {# y #} + (mset xs - {# x #}) \<Longrightarrow> set xs' = (set xs - {x}) \<union> {y}"
   by (metis insert_mset_to_set mset_remove1 set_remove1_eq union_commute)
 
 lemma mset_update' [rewrite]:
   "i < length ls \<Longrightarrow> mset (ls[i := v]) = {#v#} + (mset ls - {# ls ! i #})"
   using mset_update by fastforce
 
 subsection \<open>swap\<close>
 
 setup \<open>add_rewrite_rule @{thm mset_swap}\<close>
 setup \<open>add_rewrite_rule @{thm set_swap}\<close>
 
 subsection \<open>upto lists\<close>
 
 lemma upt_zero_length [rewrite]: "length [0..<n] = n" by simp
 lemma nth_upt_zero [rewrite]: "i < length [0..<n] \<Longrightarrow> [0..<n] ! i = i" by simp
 
 subsection \<open>Lambda lists\<close>
 
 definition list :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list" where
   "list s n = map s [0 ..< n]"
 
 lemma list_length [rewrite_arg]: "length (list s n) = n" by (simp add: list_def)
 lemma list_nth [rewrite]: "i < length (list s n) \<Longrightarrow> (list s n) ! i = s i" by (simp add: list_def)
 
 subsection \<open>Splitting of lists\<close>
 
 setup \<open>add_resolve_prfstep @{thm split_list}\<close>
 setup \<open>add_backward_prfstep @{thm not_distinct_decomp}\<close>
 
 subsection \<open>Finiteness\<close>
 
 setup \<open>add_resolve_prfstep @{thm finite_lists_length_le}\<close>
 
 subsection \<open>Cardinality\<close>
 
 setup \<open>add_rewrite_rule @{thm distinct_card}\<close>
 
 end
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,4525 +1,4523 @@
 (*  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] guess ll ll' .
     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)+
     
     
     
 subsubsection \<open>Lattice Syntax\<close>    
 (* Providing the syntax in a locale makes it more usable, without polluting the global namespace*)    
 locale Lattice_Syntax begin
   notation
     bot ("\<bottom>") and
     top ("\<top>") and
     inf  (infixl "\<sqinter>" 70) and
     sup  (infixl "\<squnion>" 65) and
     Inf  ("\<Sqinter>_" [900] 900) and
     Sup  ("\<Squnion>_" [900] 900)
 
 end
     
     
     
 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
 
 
 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.simps(2))
+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_sorted_wrt sorted_wrt_rev)
+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_sorted_wrt sorted_wrt_map)
+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)"
-unfolding sorted_sorted_wrt
-by (rule sorted_wrt_quicksort_by_rel) auto
+  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)"
-unfolding sorted_sorted_wrt
 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 (hide_lams, 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/CakeML/generated/LemExtraDefs.thy b/thys/CakeML/generated/LemExtraDefs.thy
--- a/thys/CakeML/generated/LemExtraDefs.thy
+++ b/thys/CakeML/generated/LemExtraDefs.thy
@@ -1,1257 +1,1258 @@
 (*========================================================================*)
 (*                        Lem                                             *)
 (*                                                                        *)
 (*          Dominic Mulligan, University of Cambridge                     *)
 (*          Francesco Zappa Nardelli, INRIA Paris-Rocquencourt            *)
 (*          Gabriel Kerneis, University of Cambridge                      *)
 (*          Kathy Gray, University of Cambridge                           *)
 (*          Peter Boehm, University of Cambridge (while working on Lem)   *)
 (*          Peter Sewell, University of Cambridge                         *)
 (*          Scott Owens, University of Kent                               *)
 (*          Thomas Tuerk, University of Cambridge                         *)
 (*          Brian Campbell, University of Edinburgh                       *)
 (*          Shaked Flur, University of Cambridge                          *)
 (*          Thomas Bauereiss, University of Cambridge                     *)
 (*          Stephen Kell, University of Cambridge                         *)
 (*          Thomas Williams                                               *)
 (*          Lars Hupel                                                    *)
 (*          Basile Clement                                                *)
 (*                                                                        *)
 (*  The Lem sources are copyright 2010-2018                               *)
 (*  by the authors above and Institut National de Recherche en            *)
 (*  Informatique et en Automatique (INRIA).                               *)
 (*                                                                        *)
 (*  All files except ocaml-lib/pmap.{ml,mli} and ocaml-libpset.{ml,mli}   *)
 (*  are distributed under the license below.  The former are distributed  *)
 (*  under the LGPLv2, as in the LICENSE file.                             *)
 (*                                                                        *)
 (*                                                                        *)
 (*  Redistribution and use in source and binary forms, with or without    *)
 (*  modification, are permitted provided that the following conditions    *)
 (*  are met:                                                              *)
 (*  1. Redistributions of source code must retain the above copyright     *)
 (*  notice, this list of conditions and the following disclaimer.         *)
 (*  2. Redistributions in binary form must reproduce the above copyright  *)
 (*  notice, this list of conditions and the following disclaimer in the   *)
 (*  documentation and/or other materials provided with the distribution.  *)
 (*  3. The names of the authors may not be used to endorse or promote     *)
 (*  products derived from this software without specific prior written    *)
 (*  permission.                                                           *)
 (*                                                                        *)
 (*  THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS    *)
 (*  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED     *)
 (*  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE    *)
 (*  ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY       *)
 (*  DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL    *)
 (*  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE     *)
 (*  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS         *)
 (*  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER  *)
 (*  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR       *)
 (*  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN   *)
 (*  IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                         *)
 (*========================================================================*)
 
 chapter \<open>Auxiliary Definitions needed by Lem\<close>
 
 theory "LemExtraDefs"
 
 imports
   Main
   "HOL-Combinatorics.List_Permutation"
   "HOL-Library.While_Combinator"
 begin
 
 hide_const (open) sign
 
 subsection \<open>General\<close>
 
 consts failwith :: " 'a \<Rightarrow> 'b"
 
 subsection \<open>Lists\<close>
 
 fun index :: " 'a list \<Rightarrow> nat \<Rightarrow> 'a option "  where
    "index [] n = None"
  | "index (x # xs) 0 = Some x"
  | "index (x # xs) (Suc n) = index xs n"
 
 lemma index_eq_some [simp]:
    "index l n = Some x \<longleftrightarrow> (n < length l \<and> (x = l ! n))"
 proof (induct l arbitrary: n x)
   case Nil thus ?case by simp
 next
   case (Cons e es n x)
   note ind_hyp = this
 
   show ?case
   proof (cases n)
     case 0 thus ?thesis by auto
   next
     case (Suc n')
     with ind_hyp show ?thesis by simp
   qed
 qed
 
 lemma index_eq_none [simp]:
    "index l n = None \<longleftrightarrow> length l \<le> n"
 by (rule iffD1[OF Not_eq_iff]) auto
 
 
 lemma index_simps [simp]:
    "length l \<le> n \<Longrightarrow> index l n = None"
    "n < length l \<Longrightarrow> index l n = Some (l ! n)"
 by (simp_all)
 
 fun find_indices :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat list" where
    "find_indices P [] = []"
  | "find_indices P (x # xs) = (if P x then 0 # (map Suc (find_indices P xs)) else (map Suc (find_indices P xs)))"
 
 lemma length_find_indices :
   "length (find_indices P l) \<le> length l"
 by (induct l) auto
 
 lemma sorted_map_suc :
   "sorted l \<Longrightarrow> sorted (map Suc l)"
 by (induct l) (simp_all)
 
 lemma sorted_find_indices :
   "sorted (find_indices P xs)"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   from sorted_map_suc[OF this]
   show ?case
     by (simp)
 qed
 
 lemma find_indices_set [simp] :
   "set (find_indices P l) = {i. i < length l \<and> P (l ! i)}"
 proof (intro set_eqI)
   fix i
   show "i \<in> set (find_indices P l) \<longleftrightarrow> (i \<in> {i. i < length l \<and> P (l ! i)})"
   proof (induct l arbitrary: i)
     case Nil thus ?case by simp
   next
     case (Cons x l' i)
     note ind_hyp = this
     show ?case
     proof (cases i)
       case 0 thus ?thesis by auto
     next
       case (Suc i') with ind_hyp[of i'] show ?thesis by auto
     qed
   qed
 qed
 
 definition find_index where
   "find_index P xs = (case find_indices P xs of
       []    \<Rightarrow> None
     | i # _ \<Rightarrow> Some i)"
 
 lemma find_index_eq_some [simp] :
   "(find_index P xs = Some ii) \<longleftrightarrow> (ii < length xs \<and> P (xs ! ii) \<and> (\<forall>i' < ii. \<not>(P (xs ! i'))))"
   (is "?lhs = ?rhs")
 proof (cases "find_indices P xs")
   case Nil
   with find_indices_set[of P xs]
   show ?thesis
     unfolding find_index_def by auto
 next
   case (Cons i il) note find_indices_eq = this
 
   from sorted_find_indices[of P xs] find_indices_eq
   have "sorted (i # il)" by simp
   hence i_leq: "\<And>i'. i' \<in> set (i # il) \<Longrightarrow> i \<le> i'" by auto
 
   from find_indices_set[of P xs, unfolded find_indices_eq]
   have set_i_il_eq:"\<And>i'. i' \<in> set (i # il) = (i' < length xs \<and> P (xs ! i'))"
     by simp
 
   have lhs_eq: "find_index P xs = Some i"
     unfolding find_index_def find_indices_eq by simp
 
   show ?thesis
   proof (intro iffI)
     assume ?lhs
     with lhs_eq have ii_eq[simp]: "ii = i" by simp
 
     from set_i_il_eq[of i] i_leq[unfolded set_i_il_eq]
     show ?rhs by auto (metis leD less_trans)
   next
     assume ?rhs
     with set_i_il_eq[of ii]
     have "ii \<in> set (i # il) \<and> (ii \<le> i)"
       by (metis leI length_pos_if_in_set nth_Cons_0 nth_mem set_i_il_eq)
 
     with i_leq [of ii] have "i = ii" by simp
     thus ?lhs unfolding lhs_eq by simp
   qed
 qed
 
 lemma find_index_eq_none [simp] :
   "(find_index P xs = None) \<longleftrightarrow> (\<forall>x \<in> set xs. \<not>(P x))" (is "?lhs = ?rhs")
 proof (rule iffD1[OF Not_eq_iff], intro iffI)
   assume "\<not> ?lhs"
   then obtain i where "find_index P xs = Some i" by auto
   hence "i < length xs \<and> P (xs ! i)" by simp
   thus "\<not> ?rhs" by auto
 next
   let ?p = "(\<lambda>i. i < length xs \<and> P(xs ! i))"
 
   assume "\<not> ?rhs"
   then obtain i where "?p i"
     by (metis in_set_conv_nth)
 
   from LeastI [of ?p, OF \<open>?p i\<close>]
   have "?p (Least ?p)" .
 
   hence "find_index P xs = Some (Least ?p)"
     by (subst find_index_eq_some) (metis (mono_tags) less_trans not_less_Least)
 
   thus "\<not> ?lhs" by blast
 qed
 
 definition genlist where
   "genlist f n = map f (upt 0 n)"
 
 lemma genlist_length [simp] :
   "length (genlist f n) = n"
 unfolding genlist_def by simp
 
 lemma genlist_simps [simp]:
    "genlist f 0 = []"
    "genlist f (Suc n) = genlist f n @ [f n]"
 unfolding genlist_def by auto
 
 definition split_at where
   "split_at n l = (take n l, drop n l)"
 
 fun delete_first :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list) option "  where
     "delete_first P [] = None"
   | "delete_first P (x # xs) =
      (if (P x) then Some xs else
       map_option (\<lambda>xs'. x # xs') (delete_first P xs))"
 declare delete_first.simps [simp del]
 
 lemma delete_first_simps [simp] :
    "delete_first P [] = None"
    "P x \<Longrightarrow> delete_first P (x # xs) = Some xs"
    "\<not>(P x) \<Longrightarrow> delete_first P (x # xs) = map_option (\<lambda>xs'. x # xs') (delete_first P xs)"
 unfolding delete_first.simps by auto
 
 lemmas delete_first_unroll = delete_first.simps(2)
 
 
 lemma delete_first_eq_none [simp] :
   "delete_first P l = None \<longleftrightarrow> (\<forall>x \<in> set l. \<not> (P x))"
 by (induct l) (auto simp add: delete_first_unroll)
 
 lemma delete_first_eq_some :
   "delete_first P l = (Some l') \<longleftrightarrow> (\<exists>l1 x l2. P x \<and> (\<forall>x \<in> set l1. \<not>(P x)) \<and> (l = l1 @ (x # l2)) \<and> (l' = l1 @ l2))"
   (is "?lhs l l' = (\<exists>l1 x l2. ?rhs_body l1 x l2 l l')")
 proof (induct l arbitrary: l')
   case Nil thus ?case by simp
 next
   case (Cons e l l')
   note ind_hyp = this
 
   show ?case
   proof (cases "P e")
     case True
     show ?thesis
     proof (rule iffI)
       assume "?lhs (e # l) l'"
       with \<open>P e\<close> have "l = l'" by simp
       with \<open>P e\<close> have "?rhs_body [] e l' (e # l) l'" by simp
       thus "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'" by blast
     next
       assume "\<exists>l1 x l2. ?rhs_body l1 x l2 (e # l) l'"
       then obtain l1 x l2 where body_ok: "?rhs_body l1 x l2 (e # l) l'" by blast
 
       from body_ok \<open>P e\<close> have l1_eq[simp]: "l = l'"
         by (cases l1) (simp_all)
       with \<open>P e\<close> show "?lhs (e # l) l'" by simp
     qed
   next
     case False
     define rhs_pred where "rhs_pred \<equiv> \<lambda>l1 x l2 l l'. ?rhs_body l1 x l2 l l'"
     have rhs_fold: "\<And>l1 x l2 l l'. ?rhs_body l1 x l2 l l' = rhs_pred l1 x l2 l l'"
        unfolding rhs_pred_def by simp
 
     have "(\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l') = (\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l')"
     proof (intro iffI)
       assume "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'"
       then obtain z l1 x l2 where "rhs_pred l1 x l2 l z" and l'_eq: "l' = e # z" by auto
       with \<open>\<not>(P e)\<close> have "rhs_pred (e # l1) x l2 (e # l) l'"
         unfolding rhs_pred_def by simp
       thus "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'" by blast
     next
       assume "\<exists>l1 x l2. rhs_pred l1 x l2 (e # l) l'"
       then obtain l1 x l2 where "rhs_pred l1 x l2 (e # l) l'" by blast
       with \<open>\<not> (P e)\<close> obtain l1' where l1_eq[simp]: "l1 = e # l1'"
         unfolding rhs_pred_def by (cases l1) (auto)
 
       with \<open>rhs_pred l1 x l2 (e # l) l'\<close>
       have "rhs_pred l1' x l2 l (l1' @ l2) \<and> e # (l1' @ l2) = l'"
         unfolding rhs_pred_def by (simp)
       thus "\<exists>z l1 x l2. rhs_pred l1 x l2 l z \<and> e # z = l'" by blast
     qed
     with \<open>\<not> P e\<close> show ?thesis
       unfolding rhs_fold
       by (simp add: ind_hyp[unfolded rhs_fold])
   qed
 qed
 
 
 lemma perm_eval [code] :
   "perm [] l \<longleftrightarrow> l = []" (is ?g1)
   "perm (x # xs) l \<longleftrightarrow> (case delete_first (\<lambda>e. e = x) l of
        None => False
      | Some l' => perm xs l')" (is ?g2)
 proof -
   show ?g1 by auto
 next
   show ?g2
   proof (cases "delete_first (\<lambda>e. e = x) l")
     case None note del_eq = this
     hence "x \<notin> set l" by auto
     with perm_set_eq [of "x # xs" l]
     have "\<not> perm (x # xs) l" by auto
     thus ?thesis unfolding del_eq by simp
   next
     case (Some l') note del_eq = this
 
     from del_eq[unfolded delete_first_eq_some]
     obtain l1 l2 where l_eq: "l = l1 @ [x] @ l2" and l'_eq: "l' = l1 @ l2" by auto
 
     have "(x # xs <~~> l1 @ x # l2) = (xs <~~> l1 @ l2)"
     proof -
       from perm_append_swap [of l1 "[x]"]
            perm_append2 [of "l1 @ [x]" "x # l1" l2]
       have "l1 @ x # l2 <~~> x # (l1 @ l2)" by simp
       hence "x # xs <~~> l1 @ x # l2 \<longleftrightarrow> x # xs <~~> x # (l1 @ l2)"
         by (metis perm.trans perm_sym)
       thus ?thesis by simp
     qed
     with del_eq l_eq l'_eq show ?thesis by simp
   qed
 qed
 
 
 fun sorted_by  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a list \<Rightarrow> bool "  where
    "sorted_by cmp [] = True"
  | "sorted_by cmp [_] = True"
  | "sorted_by cmp (x1 # x2 # xs) = ((cmp x1 x2) \<and> sorted_by cmp (x2 # xs))"
 
 lemma sorted_by_lesseq [simp] :
   "sorted_by ((\<le>) :: ('a::{linorder}) => 'a => bool) = sorted"
 proof (rule ext)
   fix l :: "'a list"
   show "sorted_by (\<le>) l = sorted l"
   proof (induct l)
     case Nil thus ?case by simp
   next
     case (Cons x xs)
-    thus ?case by (cases xs) (simp_all del: sorted.simps(2) add: sorted2_simps)
+    thus ?case
+      by (smt (verit, best) list.inject sorted1 sorted2 sorted_by.elims(1))
   qed
 qed
 
 lemma sorted_by_cons_imp :
   "sorted_by cmp (x # xs) \<Longrightarrow> sorted_by cmp xs"
 by (cases xs) simp_all
 
 lemma sorted_by_cons_trans :
   assumes trans_cmp: "transp cmp"
   shows "sorted_by cmp (x # xs) = ((\<forall>x' \<in> set xs . cmp x x') \<and> sorted_by cmp xs)"
 proof (induct xs arbitrary: x)
   case Nil thus ?case by simp
 next
   case (Cons x2 xs x1)
   note ind_hyp = this
 
   from trans_cmp
   show ?case
     by (auto simp add: ind_hyp transp_def)
 qed
 
 
 fun insert_sort_insert_by  :: "('a \<Rightarrow> 'a \<Rightarrow> bool)\<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
   "insert_sort_insert_by cmp e ([]) = ( [e])"
 | "insert_sort_insert_by cmp e (x # xs) = ( if cmp e x then (e # (x # xs)) else x # (insert_sort_insert_by cmp e xs))"
 
 
 lemma insert_sort_insert_by_length [simp] :
   "length (insert_sort_insert_by cmp e l) = Suc (length l)"
 by (induct l) auto
 
 lemma insert_sort_insert_by_set [simp] :
   "set (insert_sort_insert_by cmp e l) = insert e (set l)"
 by (induct l) auto
 
 lemma insert_sort_insert_by_perm :
   "(insert_sort_insert_by cmp e l) <~~> (e # l)"
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons e2 l')
   note ind_hyp = this
 
   have "e2 # e # l' <~~> e # e2 # l'" by (rule perm.swap)
   hence "e2 # insert_sort_insert_by cmp e l' <~~> e # e2 # l'"
     using ind_hyp by (metis cons_perm_eq perm.trans)
   thus ?case by simp
 qed
 
 
 lemma insert_sort_insert_by_sorted_by :
 assumes cmp_cases: "\<And>y. y \<in> set l \<Longrightarrow> \<not> (cmp e y) \<Longrightarrow> cmp y e"
 assumes cmp_trans: "transp cmp"
 shows "sorted_by cmp l \<Longrightarrow> sorted_by cmp (insert_sort_insert_by cmp e l)"
 using cmp_cases
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons x1 l')
   note ind_hyp = Cons(1)
   note sorted_x1_l' = Cons(2)
   note cmp_cases = Cons(3)
 
   show ?case
   proof (cases l')
     case Nil with cmp_cases show ?thesis by simp
   next
     case (Cons x2 l'') note l'_eq = this
 
     from l'_eq sorted_x1_l' have "cmp x1 x2" "sorted_by cmp l'" by simp_all
 
     show ?thesis
     proof (cases "cmp e x1")
       case True
       with \<open>cmp x1 x2\<close> \<open>sorted_by cmp l'\<close>
       have "sorted_by cmp (x1 # l')"
         unfolding l'_eq by (simp)
       with \<open>cmp e x1\<close>
       show ?thesis by simp
     next
       case False
 
       with cmp_cases have "cmp x1 e" by simp
       have "\<And>x'.  x' \<in> set l' \<Longrightarrow> cmp x1 x'"
       proof -
         fix x'
         assume "x' \<in> set l'"
         hence "x' = x2 \<or> cmp x2 x'"
           using \<open>sorted_by cmp l'\<close> l'_eq sorted_by_cons_trans [OF cmp_trans, of x2 l'']
           by auto
         with transpD[OF cmp_trans, of x1 x2 x'] \<open>cmp x1 x2\<close>
         show "cmp x1 x'" by blast
       qed
       hence "sorted_by cmp (x1 # insert_sort_insert_by cmp e l')"
         using ind_hyp [OF \<open>sorted_by cmp l'\<close>] \<open>cmp x1 e\<close> cmp_cases
         unfolding sorted_by_cons_trans[OF cmp_trans]
         by simp
       with \<open>\<not>(cmp e x1)\<close>
       show ?thesis by simp
     qed
   qed
 qed
 
 
 
 fun insert_sort_by :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list "  where
     "insert_sort_by cmp [] = []"
   | "insert_sort_by cmp (x # xs) = insert_sort_insert_by cmp x (insert_sort_by cmp xs)"
 
 
 lemma insert_sort_by_perm :
   "(insert_sort_by cmp l) <~~> l"
 proof (induct l)
   case Nil thus ?case by simp
 next
   case (Cons x l)
   thus ?case
    by simp (metis cons_perm_eq insert_sort_insert_by_perm perm.trans)
 qed
 
 lemma insert_sort_by_length [simp]:
   "length (insert_sort_by cmp l) = length l"
 by (induct l) auto
 
 lemma insert_sort_by_set [simp]:
   "set (insert_sort_by cmp l) = set l"
 by (induct l) auto
 
 definition sort_by where
   "sort_by = insert_sort_by"
 
 lemma sort_by_simps [simp]:
   "length (sort_by cmp l) = length l"
   "set (sort_by cmp l) = set l"
 unfolding sort_by_def by simp_all
 
 lemma sort_by_perm :
   "sort_by cmp l <~~> l"
 unfolding sort_by_def
 by (simp add: insert_sort_by_perm)
 
 subsection \<open>Maps\<close>
 
 definition map_image :: "('v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where
   "map_image f m = (\<lambda>k. map_option f (m k))"
 
 definition map_domain_image :: "('k \<Rightarrow> 'v \<Rightarrow> 'w) \<Rightarrow> ('k, 'v) map \<Rightarrow> ('k, 'w) map" where
   "map_domain_image f m = (\<lambda>k. map_option (f k) (m k))"
 
 
 lemma map_image_simps [simp]:
   "(map_image f m) k = None \<longleftrightarrow> m k = None"
   "(map_image f m) k = Some x \<longleftrightarrow> (\<exists>x'. (m k = Some x') \<and> (x = f x'))"
   "(map_image f Map.empty) = Map.empty"
   "(map_image f (m (k \<mapsto> v)) = (map_image f m) (k \<mapsto> f v))"
 unfolding map_image_def by auto
 
 lemma map_image_dom_ran [simp]:
   "dom (map_image f m) = dom m"
   "ran (map_image f m) = f ` (ran m)"
 unfolding dom_def ran_def by auto
 
 definition map_to_set :: "('k, 'v) map \<Rightarrow> ('k * 'v) set" where
   "map_to_set m = { (k, v) . m k = Some v }"
 
 lemma map_to_set_simps [simp] :
   "map_to_set Map.empty = {}"  (is ?g1)
   "map_to_set (m ((k::'k) \<mapsto> (v::'v))) = (insert (k, v) (map_to_set (m |` (- {k}))))" (is ?g2)
 proof -
   show ?g1 unfolding map_to_set_def by simp
 next
   show ?g2
   proof (rule set_eqI)
     fix kv :: "('k * 'v)"
     obtain k' v' where kv_eq[simp]: "kv = (k', v')" by (rule prod.exhaust)
 
     show "(kv \<in> map_to_set (m(k \<mapsto> v))) = (kv \<in> insert (k, v) (map_to_set (m |` (- {k}))))"
       by (auto simp add: map_to_set_def)
   qed
 qed
 
 
 subsection \<open>Sets\<close>
 
 definition "set_choose s \<equiv> (SOME x. (x \<in> s))"
   
 definition without_trans_edges :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
   "without_trans_edges S \<equiv>
      let ts = trancl S in
        { (x, y) \<in> S. \<forall>z \<in> snd ` S. x \<noteq> z \<and> y \<noteq> z \<longrightarrow> \<not> ((x, z) \<in> ts \<and> (z, y) \<in> ts)}"
   
 definition unbounded_lfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "unbounded_lfp S f \<equiv>
      while (\<lambda>x. x \<subset> S) f S"
   
 definition unbounded_gfp :: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "unbounded_gfp S f \<equiv>
      while (\<lambda>x. S \<subset> x) f S"
 
 lemma set_choose_thm[simp]:
   "s \<noteq> {} \<Longrightarrow> (set_choose s) \<in> s"
 unfolding set_choose_def
 by (rule someI_ex) auto
 
 lemma set_choose_sing [simp]:
   "set_choose {x} = x"
   unfolding set_choose_def
   by auto
 
 lemma set_choose_code [code]:
   "set_choose (set [x]) = x"
 by auto
 
 lemma set_choose_in [intro] :
   assumes "s \<noteq> {}"
   shows "set_choose s \<in> s"
 proof -
   from \<open>s \<noteq> {}\<close>
   obtain x where "x \<in> s" by auto
   thus ?thesis
     unfolding set_choose_def
     by (rule someI)
 qed
 
 
 definition set_case where
   "set_case s c_empty c_sing c_else =
     (if (s = {}) then c_empty else
     (if (card s = 1) then c_sing (set_choose s) else
        c_else))"
 
 lemma set_case_simps [simp] :
   "set_case {} c_empty c_sing c_else = c_empty"
   "set_case {x} c_empty c_sing c_else = c_sing x"
   "card s > 1 \<Longrightarrow> set_case s c_empty c_sing c_else = c_else"
   "\<not>(finite s) \<Longrightarrow> set_case s c_empty c_sing c_else = c_else"
 unfolding set_case_def by auto
 
 lemma set_case_simp_insert2 [simp] :
 assumes x12_neq: "x1 \<noteq> x2"
 shows "set_case (insert x1 (insert x2 xs))  c_empty c_sing c_else = c_else"
 proof (cases "finite xs")
   case False thus ?thesis by (simp)
 next
   case True note fin_xs = this
 
   have "card {x1,x2} \<le> card (insert x1 (insert x2 xs))"
     by (rule card_mono) (auto simp add: fin_xs)
   with x12_neq have "1 < card (insert x1 (insert x2 xs))" by simp
   thus ?thesis by auto
 qed
 
 lemma set_case_code [code] :
   "set_case (set []) c_empty c_sing c_else = c_empty"
   "set_case (set [x]) c_empty c_sing c_else = c_sing x"
   "set_case (set (x1 # x2 # xs)) c_empty c_sing c_else =
    (if (x1 = x2) then
      set_case (set (x2 # xs)) c_empty c_sing c_else
    else
      c_else)"
 by auto
 
 definition set_lfp:: "'a set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set" where
   "set_lfp s f = lfp (\<lambda>s'. f s' \<union> s)"
 
 lemma set_lfp_tail_rec_def :
 assumes mono_f: "mono f"
 shows "set_lfp s f = (if (f s) \<subseteq> s then s else (set_lfp (s \<union> f s) f))" (is "?ls = ?rs")
 proof (cases "f s \<subseteq> s")
   case True note fs_sub_s = this
 
   from fs_sub_s have "\<Inter>{u. f u \<union> s \<subseteq> u} = s" by auto
   hence "?ls = s" unfolding set_lfp_def lfp_def .
   with fs_sub_s show "?ls = ?rs" by simp
 next
   case False note not_fs_sub_s = this
 
   from mono_f have mono_f': "mono (\<lambda>s'. f s' \<union> s)"
     unfolding mono_def by auto
 
   have "\<Inter>{u. f u \<union> s \<subseteq> u} = \<Inter>{u. f u \<union> (s \<union> f s) \<subseteq> u}" (is "\<Inter>?S1 = \<Inter>?S2")
   proof
     have "?S2 \<subseteq> ?S1" by auto
     thus "\<Inter>?S1 \<subseteq> \<Inter>?S2" by (rule Inf_superset_mono)
   next
     { fix e
       assume "e \<in> \<Inter>?S2"
       hence S2_prop: "\<And>s'. f s' \<subseteq> s' \<Longrightarrow> s \<subseteq> s' \<Longrightarrow> f s \<subseteq> s' \<Longrightarrow> e \<in> s'" by simp
 
       { fix s'
         assume "f s' \<subseteq> s'" "s \<subseteq> s'"
 
         from mono_f \<open>s \<subseteq> s'\<close>
         have "f s \<subseteq> f s'" unfolding mono_def by simp
         with \<open>f s' \<subseteq> s'\<close> have "f s \<subseteq> s'" by simp
         with \<open>f s' \<subseteq> s'\<close> \<open>s \<subseteq> s'\<close> S2_prop
         have "e \<in> s'" by simp
       }
       hence "e \<in> \<Inter>?S1" by simp
     }
     thus "\<Inter>?S2 \<subseteq> \<Inter>?S1" by auto
   qed
   hence "?ls = (set_lfp (s \<union> f s) f)"
      unfolding set_lfp_def lfp_def .
   with not_fs_sub_s show "?ls = ?rs" by simp
 qed
 
 lemma set_lfp_simps [simp] :
 "mono f \<Longrightarrow> f s \<subseteq> s \<Longrightarrow> set_lfp s f = s"
 "mono f \<Longrightarrow> \<not>(f s \<subseteq> s) \<Longrightarrow> set_lfp s f = (set_lfp (s \<union> f s) f)"
 by (metis set_lfp_tail_rec_def)+
 
 
 fun insert_in_list_at_arbitrary_pos where
    "insert_in_list_at_arbitrary_pos x [] = {[x]}"
  | "insert_in_list_at_arbitrary_pos x (y # ys) =
     insert (x # y # ys) ((\<lambda>l. y # l) ` (insert_in_list_at_arbitrary_pos x ys))"
 
 lemma insert_in_list_at_arbitrary_pos_thm :
   "xl \<in> insert_in_list_at_arbitrary_pos x l \<longleftrightarrow>
    (\<exists>l1 l2. l = l1 @ l2 \<and> xl = l1 @ [x] @ l2)"
 proof (induct l arbitrary: xl)
   case Nil thus ?case by simp
 next
   case (Cons y l xyl)
   note ind_hyp = this
 
   show ?case
   proof (rule iffI)
     assume xyl_in: "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)"
     show "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2"
     proof (cases "xyl = x # y # l")
       case True
       hence "y # l = [] @ (y # l) \<and> xyl = [] @ [x] @ (y # l)" by simp
       thus ?thesis by blast
     next
       case False
       with xyl_in have "xyl \<in> (#) y ` insert_in_list_at_arbitrary_pos x l" by simp
       with ind_hyp obtain l1 l2 where "l = l1 @ l2 \<and> xyl = y # l1 @ x # l2"
          by (auto simp add: image_def Bex_def)
       hence "y # l = (y # l1) @ l2 \<and> xyl = (y # l1) @ [x] @ l2" by simp
       thus ?thesis by blast
     qed
   next
     assume "\<exists>l1 l2. y # l = l1 @ l2 \<and> xyl = l1 @ [x] @ l2"
     then obtain l1 l2 where yl_eq: "y # l = l1 @ l2" and xyl_eq: "xyl = l1 @ [x] @ l2" by blast
     show "xyl \<in> insert_in_list_at_arbitrary_pos x (y # l)"
     proof (cases l1)
       case Nil
       with yl_eq xyl_eq
       have "xyl = x # y # l" by simp
       thus ?thesis by simp
     next
       case (Cons y' l1')
       with yl_eq have l1_eq: "l1 = y # l1'" and l_eq: "l = l1' @ l2" by simp_all
 
       have "\<exists>l1'' l2''. l = l1'' @ l2'' \<and> l1' @ [x] @ l2 = l1'' @ [x] @ l2''"
         apply (rule_tac exI[where x = l1'])
         apply (rule_tac exI [where x = l2])
         apply (simp add: l_eq)
       done
       hence "(l1' @ [x] @ l2) \<in> insert_in_list_at_arbitrary_pos x l"
         unfolding ind_hyp by blast
       hence "\<exists>l'. l' \<in> insert_in_list_at_arbitrary_pos x l \<and> l1 @ x # l2 = y # l'"
         by (rule_tac exI [where x = "l1' @ [x] @ l2"]) (simp add: l1_eq)
       thus ?thesis
         by (simp add: image_def Bex_def xyl_eq)
     qed
   qed
 qed
 
 definition list_of_set_set :: "'a set \<Rightarrow> ('a list) set" where
 "list_of_set_set s = { l . (set l = s) \<and> distinct l }"
 
 lemma list_of_set_set_empty [simp]:
   "list_of_set_set {} = {[]}"
 unfolding list_of_set_set_def by auto
 
 lemma list_of_set_set_insert [simp] :
   "list_of_set_set (insert x s) =
      \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x})))"
    (is "?lhs = ?rhs")
 proof (intro set_eqI)
   fix l
 
   have "(set l = insert x s \<and> distinct l) \<longleftrightarrow> (\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2)"
   proof (intro iffI)
     assume "set l = insert x s \<and> distinct l"
     hence set_l_eq: "set l = insert x s" and "distinct l" by simp_all
 
     from \<open>set l = insert x s\<close>
     have "x \<in> set l" by simp
     then obtain l1 l2 where l_eq: "l = l1 @ x # l2"
       unfolding in_set_conv_decomp by blast
 
     from \<open>distinct l\<close>  l_eq
     have "distinct (l1 @ l2)" and x_nin: "x \<notin> set (l1 @ l2)"
       by auto
 
     from x_nin set_l_eq[unfolded l_eq]
     have set_l12_eq: "set (l1 @ l2) = s - {x}"
       by auto
 
     from \<open>distinct (l1 @ l2)\<close> l_eq set_l12_eq
     show "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2"
       by blast
   next
     assume "\<exists>l1 l2. set (l1 @ l2) = s - {x} \<and> distinct (l1 @ l2) \<and> l = l1 @ x # l2"
     then obtain l1 l2 where "set (l1 @ l2) = s - {x}"  "distinct (l1 @ l2)" "l = l1 @ x # l2"
       by blast
     thus "set l = insert x s \<and> distinct l"
        by auto
   qed
 
   thus "l \<in> list_of_set_set (insert x s) \<longleftrightarrow> l \<in> (\<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set (s - {x}))))"
      unfolding list_of_set_set_def
      by (simp add: insert_in_list_at_arbitrary_pos_thm ex_simps[symmetric] del: ex_simps)
 qed
 
 lemma list_of_set_set_code [code]:
   "list_of_set_set (set []) = {[]}"
   "list_of_set_set (set (x # xs)) =
      \<Union> ((insert_in_list_at_arbitrary_pos x) ` (list_of_set_set ((set xs) - {x})))"
 by simp_all
 
 lemma list_of_set_set_is_empty :
   "list_of_set_set s = {} \<longleftrightarrow> \<not> (finite s)"
 proof -
   have "finite s \<longleftrightarrow> (\<exists>l. set l = s \<and> distinct l)"
   proof (rule iffI)
     assume "\<exists>l. set l = s \<and> distinct l" then
     obtain l where "s = set l" by blast
     thus "finite s" by simp
   next
     assume "finite s"
     thus "\<exists>l. set l = s \<and> distinct l"
     proof (induct s)
       case empty
       show ?case by auto
     next
       case (insert e s)
       note e_nin_s = insert(2)
       from insert(3) obtain l where set_l: "set l = s" and dist_l: "distinct l" by blast
 
       from set_l have set_el: "set (e # l) = insert e s" by auto
       from dist_l set_l e_nin_s have dist_el: "distinct (e # l)" by simp
 
       from set_el dist_el show ?case by blast
     qed
   qed
   thus ?thesis
     unfolding list_of_set_set_def by simp
 qed
 
 definition list_of_set :: "'a set \<Rightarrow> 'a list" where
    "list_of_set s = set_choose (list_of_set_set s)"
 
 lemma list_of_set [simp] :
   assumes fin_s: "finite s"
   shows "set (list_of_set s) = s"
         "distinct (list_of_set s)"
 proof -
   from fin_s list_of_set_set_is_empty[of s]
   have "\<not> (list_of_set_set s = {})" by simp
   hence "list_of_set s \<in> list_of_set_set s"
     unfolding list_of_set_def
     by (rule set_choose_thm)
   thus "set (list_of_set s) = s"
        "distinct (list_of_set s)" unfolding list_of_set_set_def
   by simp_all
 qed
 
 lemma list_of_set_in:
   "finite s \<Longrightarrow> list_of_set s \<in> list_of_set_set s"
 unfolding list_of_set_def
 by (metis list_of_set_set_is_empty set_choose_thm)
 
 definition ordered_list_of_set where
   "ordered_list_of_set cmp s = set_choose (sort_by cmp ` list_of_set_set s)"
 
 subsection \<open>sum\<close>
 
 find_consts "'a list => ('a list * _)"
 
 fun sum_partition :: "('a + 'b) list \<Rightarrow> 'a list * 'b list"  where
   "sum_partition [] = ([], [])"
 | "sum_partition ((Inl l) # lrs) =
      (let (ll, rl) = sum_partition lrs in
      (l # ll, rl))"
 | "sum_partition ((Inr r) # lrs) =
      (let (ll, rl) = sum_partition lrs in
      (ll, r # rl))"
 
 lemma sum_partition_length :
   "List.length lrs = List.length (fst (sum_partition lrs)) + List.length (snd (sum_partition lrs))"
 proof (induct lrs)
   case Nil thus ?case by simp
 next
   case (Cons lr lrs) thus ?case
     by (cases lr) (auto split: prod.split)
 qed
 
 subsection \<open>sorting\<close>
 
 subsection \<open>Strings\<close>
 
 declare String.literal.explode_inverse [simp]
 
 subsection \<open>num to string conversions\<close>
 
 definition nat_list_to_string :: "nat list \<Rightarrow> string" where
   "nat_list_to_string nl = map char_of nl"
 
 definition is_digit where
   "is_digit (n::nat) = (n < 10)"
 
 lemma is_digit_simps[simp] :
   "n < 10 \<Longrightarrow> is_digit n"
   "\<not>(n < 10) \<Longrightarrow> \<not>(is_digit n)"
 unfolding is_digit_def by simp_all
 
 lemma is_digit_expand :
   "is_digit n \<longleftrightarrow>
      (n = 0) \<or> (n = 1) \<or> (n = 2) \<or> (n = 3) \<or>  (n = 4) \<or>
      (n = 5) \<or> (n = 6) \<or> (n = 7) \<or> (n = 8) \<or>  (n = 9)"
 unfolding is_digit_def by auto
 
 lemmas is_digitE = is_digit_expand[THEN iffD1,elim_format]
 lemmas is_digitI = is_digit_expand[THEN iffD2,rule_format]
 
 definition is_digit_char where
   "is_digit_char c \<longleftrightarrow>
      (c = CHR ''0'') \<or> (c = CHR ''5'') \<or>
      (c = CHR ''1'') \<or> (c = CHR ''6'') \<or>
      (c = CHR ''2'') \<or> (c = CHR ''7'') \<or>
      (c = CHR ''3'') \<or> (c = CHR ''8'') \<or>
      (c = CHR ''4'') \<or> (c = CHR ''9'')"
 
 lemma is_digit_char_simps[simp] :
   "is_digit_char (CHR ''0'')"
   "is_digit_char (CHR ''1'')"
   "is_digit_char (CHR ''2'')"
   "is_digit_char (CHR ''3'')"
   "is_digit_char (CHR ''4'')"
   "is_digit_char (CHR ''5'')"
   "is_digit_char (CHR ''6'')"
   "is_digit_char (CHR ''7'')"
   "is_digit_char (CHR ''8'')"
   "is_digit_char (CHR ''9'')"
 unfolding is_digit_char_def by simp_all
 
 lemmas is_digit_charE = is_digit_char_def[THEN iffD1,elim_format]
 lemmas is_digit_charI = is_digit_char_def[THEN iffD2,rule_format]
 
 definition digit_to_char :: "nat \<Rightarrow> char" where
   "digit_to_char n = (
      if n = 0 then CHR ''0''
      else if n = 1 then CHR ''1''
      else if n = 2 then CHR ''2''
      else if n = 3 then CHR ''3''
      else if n = 4 then CHR ''4''
      else if n = 5 then CHR ''5''
      else if n = 6 then CHR ''6''
      else if n = 7 then CHR ''7''
      else if n = 8 then CHR ''8''
      else if n = 9 then CHR ''9''
      else CHR ''X'')"
 
 lemma digit_to_char_simps [simp]:
   "digit_to_char 0 = CHR ''0''"
   "digit_to_char (Suc 0) = CHR ''1''"
   "digit_to_char 2 = CHR ''2''"
   "digit_to_char 3 = CHR ''3''"
   "digit_to_char 4 = CHR ''4''"
   "digit_to_char 5 = CHR ''5''"
   "digit_to_char 6 = CHR ''6''"
   "digit_to_char 7 = CHR ''7''"
   "digit_to_char 8 = CHR ''8''"
   "digit_to_char 9 = CHR ''9''"
   "n > 9 \<Longrightarrow> digit_to_char n = CHR ''X''"
 unfolding digit_to_char_def
 by simp_all
 
 definition char_to_digit :: "char \<Rightarrow> nat" where
   "char_to_digit c = (
      if c = CHR ''0'' then 0
      else if c = CHR ''1'' then 1
      else if c = CHR ''2'' then 2
      else if c = CHR ''3'' then 3
      else if c = CHR ''4'' then 4
      else if c = CHR ''5'' then 5
      else if c = CHR ''6'' then 6
      else if c = CHR ''7'' then 7
      else if c = CHR ''8'' then 8
      else if c = CHR ''9'' then 9
      else 10)"
 
 lemma char_to_digit_simps [simp]:
   "char_to_digit (CHR ''0'') = 0"
   "char_to_digit (CHR ''1'') = 1"
   "char_to_digit (CHR ''2'') = 2"
   "char_to_digit (CHR ''3'') = 3"
   "char_to_digit (CHR ''4'') = 4"
   "char_to_digit (CHR ''5'') = 5"
   "char_to_digit (CHR ''6'') = 6"
   "char_to_digit (CHR ''7'') = 7"
   "char_to_digit (CHR ''8'') = 8"
   "char_to_digit (CHR ''9'') = 9"
 unfolding char_to_digit_def by simp_all
 
 
 lemma diget_to_char_inv[simp]:
 assumes is_digit: "is_digit n"
 shows "char_to_digit (digit_to_char n) = n"
 using is_digit unfolding is_digit_expand by auto
 
 lemma char_to_diget_inv[simp]:
 assumes is_digit: "is_digit_char c"
 shows "digit_to_char (char_to_digit c) = c"
 using is_digit
 unfolding char_to_digit_def is_digit_char_def
 by auto
 
 lemma char_to_digit_div_mod [simp]:
 assumes is_digit: "is_digit_char c"
 shows "char_to_digit c < 10"
 using is_digit
 unfolding char_to_digit_def is_digit_char_def
 by auto
 
 
 lemma is_digit_char_intro[simp]:
   "is_digit (char_to_digit c) = is_digit_char c"
 unfolding char_to_digit_def is_digit_char_def is_digit_expand
 by auto
 
 lemma is_digit_intro[simp]:
   "is_digit_char (digit_to_char n) = is_digit n"
 unfolding digit_to_char_def is_digit_char_def is_digit_expand
 by auto
 
 lemma digit_to_char_11:
 "digit_to_char n1 = digit_to_char n2 \<Longrightarrow>
  (is_digit n1 = is_digit n2) \<and> (is_digit n1 \<longrightarrow> (n1 = n2))"
 by (metis diget_to_char_inv is_digit_intro)
 
 lemma char_to_digit_11:
 "char_to_digit c1 = char_to_digit c2 \<Longrightarrow>
  (is_digit_char c1 = is_digit_char c2) \<and> (is_digit_char c1 \<longrightarrow> (c1 = c2))"
 by (metis char_to_diget_inv is_digit_char_intro)
 
 function nat_to_string :: "nat \<Rightarrow> string" where
   "nat_to_string n =
      (if (is_digit n) then [digit_to_char n] else
       nat_to_string (n div 10) @ [digit_to_char (n mod 10)])"
 by auto
 termination
   by (relation "measure id") (auto simp add: is_digit_def)
 
 definition int_to_string :: "int \<Rightarrow> string" where
   "int_to_string i \<equiv>
      if i < 0 then
        ''-'' @ nat_to_string (nat (abs i))
      else
        nat_to_string (nat i)"
 
 lemma nat_to_string_simps[simp]:
    "is_digit n \<Longrightarrow> nat_to_string n = [digit_to_char n]"
   "\<not>(is_digit n) \<Longrightarrow> nat_to_string n = nat_to_string (n div 10) @ [digit_to_char (n mod 10)]"
 by simp_all
 declare nat_to_string.simps[simp del]
 
 lemma nat_to_string_neq_nil[simp]:
   "nat_to_string n \<noteq> []"
   by (cases "is_digit n") simp_all
 
 lemmas nat_to_string_neq_nil2[simp] = nat_to_string_neq_nil[symmetric]
 
 lemma nat_to_string_char_to_digit [simp]:
   "is_digit_char c \<Longrightarrow> nat_to_string (char_to_digit c) = [c]"
 by auto
 
 lemma nat_to_string_11[simp] :
   "(nat_to_string n1 = nat_to_string n2) \<longleftrightarrow> n1 = n2"
 proof (rule iffI)
   assume "n1 = n2"
   thus "nat_to_string n1 = nat_to_string n2" by simp
 next
   assume "nat_to_string n1 = nat_to_string n2"
   thus "n1 = n2"
   proof (induct n2 arbitrary: n1 rule: less_induct)
     case (less n2')
     note ind_hyp = this(1)
     note n2s_eq = less(2)
 
     have is_dig_eq: "is_digit n2' = is_digit n1" using n2s_eq
       apply (cases "is_digit n2'")
       apply (case_tac [!] "is_digit n1")
       apply (simp_all)
     done
 
     show ?case
     proof (cases "is_digit n2'")
       case True with n2s_eq is_dig_eq show ?thesis by simp (metis digit_to_char_11)
     next
       case False
       with is_dig_eq have not_digs : "\<not> (is_digit n1)"  "\<not> (is_digit n2')" by simp_all
 
       from not_digs(2) have "n2' div 10 < n2'" unfolding is_digit_def by auto
       note ind_hyp' = ind_hyp [OF this, of "n1 div 10"]
 
       from not_digs n2s_eq ind_hyp' digit_to_char_11[of "n1 mod 10" "n2' mod 10"]
       have "(n1 mod 10) = (n2' mod 10)" "n1 div 10 = n2' div 10" by simp_all
       thus "n1 = n2'" by (metis div_mult_mod_eq)
     qed
   qed
 qed
 
 definition "is_nat_string s \<equiv> (\<forall>c\<in>set s. is_digit_char c)"
 definition "is_strong_nat_string s \<equiv> is_nat_string s \<and> (s \<noteq> []) \<and> (hd s = CHR ''0'' \<longrightarrow> length s = 1)"
 
 lemma is_nat_string_simps[simp]:
   "is_nat_string []"
   "is_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s"
 unfolding is_nat_string_def by simp_all
 
 lemma is_strong_nat_string_simps[simp]:
   "\<not>(is_strong_nat_string [])"
   "is_strong_nat_string (c # s) \<longleftrightarrow> is_digit_char c \<and> is_nat_string s \<and>
                                     (c = CHR ''0'' \<longrightarrow> s = [])"
 unfolding is_strong_nat_string_def by simp_all
 
 fun string_to_nat_aux :: "nat \<Rightarrow> string \<Rightarrow> nat" where
    "string_to_nat_aux n [] = n"
  | "string_to_nat_aux n (d#ds) =
     string_to_nat_aux (n*10 + char_to_digit d) ds"
 
 definition string_to_nat :: "string \<Rightarrow> nat option" where
    "string_to_nat s \<equiv>
     (if is_nat_string s then Some (string_to_nat_aux 0 s) else None)"
 
 definition string_to_nat' :: "string \<Rightarrow> nat" where
   "string_to_nat' s \<equiv> the (string_to_nat s)"
 
 lemma string_to_nat_aux_inv :
 assumes "is_nat_string s"
 assumes "n > 0 \<or> is_strong_nat_string s"
 shows "nat_to_string (string_to_nat_aux n s) =
 (if n = 0 then '''' else nat_to_string n) @ s"
 using assms
 proof (induct s arbitrary: n)
   case Nil
   thus ?case
     by (simp add: is_strong_nat_string_def)
 next
   case (Cons c s n)
   from Cons(2) have "is_digit_char c" "is_nat_string s" by simp_all
   note cs_ok = Cons(3)
   let ?m = "n*10 + char_to_digit c"
   note ind_hyp = Cons(1)[OF \<open>is_nat_string s\<close>, of ?m]
 
   from \<open>is_digit_char c\<close> have m_div: "?m div 10 = n" and
                               m_mod: "?m mod 10 = char_to_digit c"
     unfolding is_digit_char_def
     by auto
 
   show ?case
   proof (cases "?m = 0")
     case True
     with \<open>is_digit_char c\<close>
     have "n = 0" "c = CHR ''0''" unfolding is_digit_char_def by auto
     moreover with cs_ok have "s = []" by simp
     ultimately show ?thesis by simp
   next
     case False note m_neq_0 = this
     with ind_hyp have ind_hyp':
       "nat_to_string (string_to_nat_aux ?m s) = (nat_to_string ?m) @ s" by auto
 
     hence "nat_to_string (string_to_nat_aux n (c # s)) = (nat_to_string ?m) @ s"
       by simp
 
     with \<open>is_digit_char c\<close> m_div show ?thesis by simp
   qed
 qed
 
 lemma string_to_nat_inv :
 assumes strong_nat_s: "is_strong_nat_string s"
 assumes s2n_s: "string_to_nat s = Some n"
 shows "nat_to_string n = s"
 proof -
   from strong_nat_s have nat_s: "is_nat_string s" unfolding is_strong_nat_string_def by simp
   with s2n_s have n_eq: "n = string_to_nat_aux 0 s" unfolding string_to_nat_def by simp
 
   from string_to_nat_aux_inv[of s 0, folded n_eq] nat_s strong_nat_s
   show ?thesis by simp
 qed
 
 lemma nat_to_string_induct [case_names "digit" "non_digit"]:
 assumes digit: "\<And>d. is_digit d \<Longrightarrow> P d"
 assumes not_digit: "\<And>n. \<not>(is_digit n) \<Longrightarrow> P (n div 10) \<Longrightarrow> P (n mod 10) \<Longrightarrow> P n"
 shows "P n"
 proof (induct n rule: less_induct)
   case (less n)
   note ind_hyp = this
 
   show ?case
   proof (cases "is_digit n")
     case True with digit show ?thesis by simp
   next
     case False note not_dig = this
     hence "n div 10 < n" "n mod 10 < n" unfolding is_digit_def by auto
     with not_dig ind_hyp not_digit show ?thesis by simp
   qed
 qed
 
 lemma nat_to_string___is_nat_string [simp]:
   "is_nat_string (nat_to_string n)"
 unfolding is_nat_string_def
 proof (induct n rule: nat_to_string_induct)
   case (digit d)
   thus ?case by simp
 next
   case (non_digit n)
   thus ?case by simp
 qed
 
 lemma nat_to_string___eq_0 [simp]:
   "(nat_to_string n = (CHR ''0'')#s) \<longleftrightarrow> (n = 0 \<and> s = [])"
 unfolding is_nat_string_def
 proof (induct n arbitrary: s rule: nat_to_string_induct)
   case (digit d) thus ?case unfolding is_digit_expand by auto
 next
   case (non_digit n)
 
   obtain c s' where ns_eq: "nat_to_string (n div 10) = c # s'"
      by (cases "nat_to_string (n div 10)") auto
 
   from non_digit(1) have "n div 10 \<noteq> 0" unfolding is_digit_def by auto
   with non_digit(2) ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto
 
   from \<open>\<not> (is_digit n)\<close> c_neq ns_eq
   show ?case by auto
 qed
 
 lemma nat_to_string___is_strong_nat_string:
   "is_strong_nat_string (nat_to_string n)"
 proof (cases "is_digit n")
   case True thus ?thesis by simp
 next
   case False note not_digit = this
 
   obtain c s' where ns_eq: "nat_to_string n = c # s'"
      by (cases "nat_to_string n") auto
 
   from not_digit have "0 < n" unfolding is_digit_def by simp
   with ns_eq have c_neq: "c \<noteq> CHR ''0''" by auto
   hence "hd (nat_to_string n) \<noteq> CHR ''0''" unfolding ns_eq by simp
 
   thus ?thesis unfolding is_strong_nat_string_def
     by simp
 qed
 
 lemma nat_to_string_inv :
   "string_to_nat (nat_to_string n) = Some n"
 by (metis nat_to_string_11
           nat_to_string___is_nat_string
           nat_to_string___is_strong_nat_string
           string_to_nat_def
           string_to_nat_inv)
 
 definition The_opt where
   "The_opt p = (if (\<exists>!x. p x) then Some (The p) else None)"
 
 lemma The_opt_eq_some [simp] :
 "((The_opt p) = (Some x)) \<longleftrightarrow> ((p x) \<and> ((\<forall> y.  p y \<longrightarrow> (x = y))))"
     (is "?lhs = ?rhs")
 proof (cases "\<exists>!x. p x")
   case True
   note exists_unique = this
   then obtain x where p_x: "p x" by auto
 
   from the1_equality[of p x] exists_unique p_x
   have the_opt_eq: "The_opt p = Some x"
     unfolding The_opt_def by simp
 
   from exists_unique the_opt_eq p_x show ?thesis
     by auto
 next
   case False
   note not_unique = this
 
   hence "The_opt p = None"
     unfolding The_opt_def by simp
   with not_unique show ?thesis by auto
 qed
 
 lemma The_opt_eq_none [simp] :
 "((The_opt p) = None) \<longleftrightarrow> \<not>(\<exists>!x. p x)"
 unfolding The_opt_def by auto
 
 
 end
diff --git a/thys/Collections/ICF/gen_algo/PrioUniqueByAnnotatedList.thy b/thys/Collections/ICF/gen_algo/PrioUniqueByAnnotatedList.thy
--- a/thys/Collections/ICF/gen_algo/PrioUniqueByAnnotatedList.thy
+++ b/thys/Collections/ICF/gen_algo/PrioUniqueByAnnotatedList.thy
@@ -1,1114 +1,1114 @@
 section \<open>\isaheader{Implementing Unique Priority Queues by Annotated Lists}\<close>
 theory PrioUniqueByAnnotatedList
 imports 
   "../spec/AnnotatedListSpec"
   "../spec/PrioUniqueSpec"
 begin
 
 text \<open>
   In this theory we use annotated lists to implement unique priority queues 
   with totally ordered elements.
 
   This theory is written as a generic adapter from the AnnotatedList interface
   to the unique priority queue interface.
 
   The annotated list stores a sequence of elements annotated with 
   priorities\footnote{Technically, the annotated list elements are of unit-type,
   and the annotations hold both, the priority queue elements and the priorities.
   This is required as we defined annotated lists to only sum up the elements 
   annotations.}
 
   The monoids operations forms the maximum over the elements and
   the minimum over the priorities. 
   The sequence of pairs is ordered by ascending elements' order. 
   The insertion point for a new element, or the priority of an existing element
   can be found by splitting the
   sequence at the point where the maximum of the elements read so far gets
   bigger than the element to be inserted.
 
   The minimum priority can be read out as the sum over the whole sequence.
   Finding the element with minimum priority is done by splitting the sequence
   at the point where the minimum priority of the elements read so far becomes
   equal to the minimum priority of the whole sequence.
 \<close>
 
 subsection "Definitions"
 
 subsubsection "Monoid"
 datatype ('e, 'a) LP = Infty | LP 'e 'a
 
 fun p_unwrap :: "('e,'a) LP \<Rightarrow> ('e \<times> 'a)" where
   "p_unwrap (LP e a) = (e , a)"
 
 fun p_min :: "('e::linorder, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> ('e, 'a) LP"  where
   "p_min Infty Infty = Infty"|
   "p_min Infty (LP e a) = LP e a"|
   "p_min (LP e a) Infty = LP e a"|
   "p_min (LP e1 a) (LP e2 b) = (LP (max e1 e2) (min a b))"
 
 fun e_less_eq :: "'e \<Rightarrow> ('e::linorder, 'a::linorder) LP \<Rightarrow> bool"  where
   "e_less_eq e Infty = False"|
   "e_less_eq e (LP e' _) = (e \<le> e')"
 
 
 text_raw\<open>\paragraph{Instantiation of classes}\ \\\<close>
 lemma p_min_re_neut[simp]: "p_min a Infty = a" by (induct a) auto
 lemma p_min_le_neut[simp]: "p_min Infty a = a" by (induct a) auto
 lemma p_min_asso: "p_min (p_min a b) c = p_min a (p_min b c)"
   apply(induct a b  rule: p_min.induct )
   apply (auto)
   apply (induct c)
   apply (auto)
 apply (metis max.assoc)
 apply (metis min.assoc)
   done
 
 lemma lp_mono: "class.monoid_add p_min Infty" by  unfold_locales  (auto simp add: p_min_asso)
 
 instantiation LP :: (linorder,linorder) monoid_add
 begin
 definition zero_def: "0 == Infty" 
 definition plus_def: "a+b == p_min a b"
   
 instance by 
   intro_classes 
 (auto simp add: p_min_asso zero_def plus_def)
 end
 
 fun p_less_eq :: "('e, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> bool" where
   "p_less_eq (LP e a) (LP f b) = (a \<le> b)"|
   "p_less_eq  _ Infty = True"|
   "p_less_eq Infty (LP e a) = False"
 
 fun p_less :: "('e, 'a::linorder) LP \<Rightarrow> ('e, 'a) LP \<Rightarrow> bool" where
   "p_less (LP e a) (LP f b) = (a < b)"|
   "p_less (LP e a) Infty = True"|
   "p_less Infty _ = False"
 
 lemma p_less_le_not_le : "p_less x y \<longleftrightarrow> p_less_eq x y \<and> \<not> (p_less_eq y x)"
   by (induct x y rule: p_less.induct) auto
 
 lemma p_order_refl : "p_less_eq x x"
   by (induct x) auto
 
 lemma p_le_inf : "p_less_eq Infty x \<Longrightarrow> x = Infty"
   by (induct x) auto
 
 lemma p_order_trans : "\<lbrakk>p_less_eq x y; p_less_eq y z\<rbrakk> \<Longrightarrow> p_less_eq x z"
   apply (induct y z rule: p_less.induct)
   apply auto
   apply (induct x)
   apply auto
   apply (cases x)
   apply auto
   apply(induct x)
   apply (auto simp add: p_le_inf)
   apply (metis p_le_inf p_less_eq.simps(2))
   done
 
 lemma p_linear2 : "p_less_eq x y \<or> p_less_eq y x"
   apply (induct x y rule: p_less_eq.induct)
   apply auto
   done
 
 instantiation LP :: (type, linorder) preorder
 begin
 definition plesseq_def: "less_eq = p_less_eq"
 definition pless_def: "less = p_less"
 
 instance 
   apply (intro_classes)
   apply (simp only: p_less_le_not_le pless_def plesseq_def)
   apply (simp only: p_order_refl plesseq_def pless_def)
   apply (simp only: plesseq_def)
   apply (metis p_order_trans)
   done
 
 end
 
 subsubsection "Operations"
 
 definition aluprio_\<alpha> :: "('s \<Rightarrow> (unit \<times> ('e::linorder,'a::linorder) LP) list) 
   \<Rightarrow> 's \<Rightarrow> ('e::linorder \<rightharpoonup>  'a::linorder)"
   where 
   "aluprio_\<alpha> \<alpha> ft == (map_of (map p_unwrap (map snd (\<alpha> ft))))"
 
 definition aluprio_invar :: "('s \<Rightarrow> (unit \<times> ('c::linorder, 'd::linorder) LP) list)
   \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" 
   where
   "aluprio_invar \<alpha> invar ft == 
      invar ft 
      \<and> (\<forall> x\<in>set (\<alpha> ft). snd x\<noteq>Infty) 
      \<and> sorted (map fst (map p_unwrap (map snd (\<alpha> ft)))) 
      \<and> distinct (map fst (map p_unwrap (map snd (\<alpha> ft)))) "
 
 definition aluprio_empty  where 
   "aluprio_empty empt = empt"
 
 definition aluprio_isEmpty  where 
   "aluprio_isEmpty isEmpty = isEmpty"
 
 definition aluprio_insert :: 
   "((('e::linorder,'a::linorder) LP \<Rightarrow> bool) 
   \<Rightarrow> ('e,'a) LP \<Rightarrow> 's \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's)) 
     \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP) 
       \<Rightarrow> ('s \<Rightarrow> bool)
         \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's) 
           \<Rightarrow> ('s \<Rightarrow> unit \<Rightarrow> ('e,'a) LP \<Rightarrow> 's)
             \<Rightarrow> 's \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's" 
   where
   "
   aluprio_insert splits annot isEmpty app consr s e a = 
     (if e_less_eq e (annot s) \<and> \<not> isEmpty s 
     then
       (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in 
         (if e < fst (p_unwrap lp)
         then 
           app (consr (consr l () (LP e a))  () lp) r
         else 
           app (consr l () (LP e a)) r  ))
     else 
       consr s () (LP e a))
   "
 
 definition aluprio_pop :: "((('e::linorder,'a::linorder) LP \<Rightarrow> bool) \<Rightarrow> ('e,'a) LP
   \<Rightarrow> 's \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's)) 
     \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP) 
       \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> 's) 
         \<Rightarrow> 's 
           \<Rightarrow> 'e \<times>'a \<times>'s" 
   where
   "aluprio_pop splits annot app s = 
     (let (l, (_,lp) , r) = splits (\<lambda> x. x \<le> (annot s)) Infty s 
     in 
       (case lp of 
         (LP e a) \<Rightarrow> 
           (e, a, app l r) ))"
 
 definition aluprio_prio :: 
   "((('e::linorder,'a::linorder) LP \<Rightarrow> bool) \<Rightarrow> ('e,'a) LP \<Rightarrow> 's 
   \<Rightarrow> ('s \<times> (unit \<times> ('e,'a) LP) \<times> 's)) 
     \<Rightarrow> ('s \<Rightarrow> ('e,'a) LP) 
       \<Rightarrow> ('s \<Rightarrow> bool)
         \<Rightarrow> 's \<Rightarrow> 'e \<Rightarrow> 'a option" 
   where
   "
   aluprio_prio splits annot isEmpty s e = 
     (if e_less_eq e (annot s) \<and> \<not> isEmpty s 
     then
       (let (l, (_,lp) , r) = splits (e_less_eq e) Infty s in 
         (if e = fst (p_unwrap lp)
         then 
           Some (snd (p_unwrap lp))
         else
           None))
     else 
       None)
   "
 
 lemmas aluprio_defs =
 aluprio_invar_def
 aluprio_\<alpha>_def
 aluprio_empty_def
 aluprio_isEmpty_def
 aluprio_insert_def
 aluprio_pop_def
 aluprio_prio_def
 
 subsection "Correctness"
 
 subsubsection "Auxiliary Lemmas"
 
 lemma p_linear: "(x::('e, 'a::linorder) LP) \<le> y \<or> y \<le> x"
   by (unfold plesseq_def) (simp only: p_linear2)
 
 
 lemma e_less_eq_mon1: "e_less_eq e x \<Longrightarrow> e_less_eq e (x + y)"
   apply (cases x) 
   apply (auto simp add: plus_def) 
   apply (cases y) 
   apply (auto simp add: max.coboundedI1)
   done
 lemma e_less_eq_mon2: "e_less_eq e y \<Longrightarrow> e_less_eq e (x + y)"
   apply (cases x) 
   apply (auto simp add: plus_def) 
   apply (cases y) 
   apply (auto simp add: max.coboundedI2)
   done
 lemmas e_less_eq_mon = 
   e_less_eq_mon1
   e_less_eq_mon2
 
 lemma p_less_eq_mon:
   "(x::('e::linorder,'a::linorder) LP) \<le> z \<Longrightarrow> (x + y) \<le> z"
   apply(cases y)
   apply(auto simp add: plus_def)
   apply (cases x)
   apply (cases z)
   apply (auto simp add: plesseq_def)
   apply (cases z)
   apply (auto simp add: min.coboundedI1)
   done
 
 lemma p_less_eq_lem1:
   "\<lbrakk>\<not> (x::('e::linorder,'a::linorder) LP) \<le> z;
   (x + y) \<le> z\<rbrakk>
   \<Longrightarrow> y \<le> z "
   apply (cases x,auto simp add: plus_def)
   apply (cases y, auto)
   apply (cases z, auto simp add: plesseq_def)
   apply (metis min_le_iff_disj)
   done
   
 lemma infadd: "x \<noteq> Infty \<Longrightarrow>x + y \<noteq> Infty"
   apply (unfold plus_def)
   apply (induct x y rule: p_min.induct)
   apply auto
   done
 
 
 lemma e_less_eq_sum_list: 
   "\<lbrakk>\<not> e_less_eq e (sum_list xs)\<rbrakk> \<Longrightarrow> \<forall>x \<in> set xs. \<not> e_less_eq e x"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons a xs)
   hence "\<not> e_less_eq e (sum_list xs)" by (auto simp add: e_less_eq_mon)
   hence v1: "\<forall>x\<in>set xs. \<not> e_less_eq e x" using Cons.hyps by simp
   from Cons.prems have "\<not> e_less_eq e a" by (auto simp add: e_less_eq_mon)
   with v1 show "\<forall>x\<in>set (a#xs). \<not> e_less_eq e x" by simp
 qed
 
 lemma e_less_eq_p_unwrap: 
   "\<lbrakk>x \<noteq> Infty;\<not> e_less_eq e x\<rbrakk> \<Longrightarrow> fst (p_unwrap x) < e"
   by (cases x) auto
 
 lemma e_less_eq_refl :
   "b \<noteq> Infty \<Longrightarrow> e_less_eq (fst (p_unwrap b)) b"
   by (cases b) auto
 
 lemma e_less_eq_sum_list2:
   assumes 
   "\<forall>x\<in>set (\<alpha>s). snd x \<noteq> Infty"
   "((), b) \<in> set (\<alpha>s)"
   shows "e_less_eq (fst (p_unwrap b)) (sum_list (map snd (\<alpha>s)))"
   apply(insert assms)
   apply (induct "\<alpha>s")
   apply (auto simp add: zero_def e_less_eq_mon e_less_eq_refl) 
   done
 
 lemma e_less_eq_lem1:
   "\<lbrakk>\<not> e_less_eq e a;e_less_eq e (a + b)\<rbrakk> \<Longrightarrow> e_less_eq e b"
   apply (auto simp add: plus_def)
   apply (cases a)
   apply auto
   apply (cases b)
   apply auto
   apply (metis le_max_iff_disj)
   done
 
 lemma p_unwrap_less_sum: "snd (p_unwrap ((LP e aa) + b)) \<le> aa"
   apply (cases b)
   apply (auto simp add: plus_def)
 done
 
 lemma  sum_list_less_elems: "\<forall>x\<in>set xs. snd x \<noteq> Infty \<Longrightarrow>
   \<forall>y\<in>set (map snd (map p_unwrap (map snd xs))).
               snd (p_unwrap (sum_list (map snd xs))) \<le> y"          
     proof (induct xs)
     case Nil thus ?case by simp
     next
     case (Cons a as) thus ?case
       apply auto
       apply (cases "(snd a)" rule: p_unwrap.cases)
       apply auto
       apply (cases "sum_list (map snd as)")
       apply auto
       apply (metis linorder_linear p_min_re_neut p_unwrap.simps 
         plus_def[abs_def] snd_eqD)
       apply (auto simp add: p_unwrap_less_sum)
       apply (unfold plus_def)
       apply (cases "(snd a, sum_list (map snd as))" rule: p_min.cases)
       apply auto
       apply (cases "map snd as")
       apply (auto simp add: infadd)
       apply (metis min.coboundedI2 snd_conv)
       done
 qed
 
 lemma distinct_sortet_list_app:
   "\<lbrakk>sorted xs; distinct xs; xs = as @ b # cs\<rbrakk>
   \<Longrightarrow> \<forall> x\<in> set cs. b < x"
   by (metis distinct.simps(2) distinct_append 
-    antisym_conv2 sorted.simps(2) sorted_append)
+    antisym_conv2 sorted_wrt.simps(2) sorted_append)
 
 lemma distinct_sorted_list_lem1:
   assumes 
   "sorted xs"
   "sorted ys"
   "distinct xs"
   "distinct ys"
   " \<forall> x \<in> set xs. x < e"
   " \<forall> y \<in> set ys. e < y"
   shows 
   "sorted (xs @ e # ys)"
   "distinct (xs @ e # ys)"
 proof -
   from assms (5,6)
   have "\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<le> y" by force
   thus "sorted (xs @ e # ys)"
     using assms
     by (auto simp add: sorted_append)
   have "set xs \<inter> set ys = {}" using assms (5,6) by force
   thus "distinct (xs @ e # ys)"
     using assms
     by (auto)
 qed
 
 lemma distinct_sorted_list_lem2:
   assumes 
   "sorted xs"
   "sorted ys"
   "distinct xs"
   "distinct ys"
   "e < e'"  
   " \<forall> x \<in> set xs. x < e"
   " \<forall> y \<in> set ys. e' < y"
   shows 
   "sorted (xs @ e # e' # ys)"
   "distinct (xs @ e # e' # ys)"
 proof -
   have "sorted (e' # ys)"
     "distinct (e' # ys)"
     "\<forall> y \<in> set (e' # ys). e < y"
     using assms(2,4,5,7)
     by (auto)
   thus "sorted (xs @ e # e' # ys)"
   "distinct (xs @ e # e' # ys)"
     using assms(1,3,6) distinct_sorted_list_lem1[of xs "e' # ys" e]  
     by auto
 qed
 
 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)"
   apply(insert assms)
   apply(induct xs)
 
   apply clarsimp
   apply (metis dom_map_of_conv_image_fst fun_upd_None_restrict 
     restrict_complement_singleton_eq restrict_map_self)
 
   apply (auto simp add: map_of_eq_None_iff) []
   done
 
 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
 
 
 
 
 subsubsection "Finite"
 
 lemma aluprio_finite_correct: "uprio_finite (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar)" 
   by(unfold_locales) (simp add: aluprio_defs finite_dom_map_of)
 
 subsubsection "Empty"
 lemma aluprio_empty_correct:
   assumes "al_empty \<alpha> invar empt"
   shows "uprio_empty (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_empty empt)"
 proof -
   interpret al_empty \<alpha> invar empt by fact
   show ?thesis
     apply (unfold_locales)
     apply (auto simp add: empty_correct aluprio_defs)
     done
 qed
 
 subsubsection "Is Empty"
 
 lemma aluprio_isEmpty_correct: 
   assumes "al_isEmpty \<alpha> invar isEmpty"
   shows "uprio_isEmpty (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_isEmpty isEmpty)"
 proof -
   interpret al_isEmpty \<alpha> invar isEmpty by fact
   show ?thesis 
     apply (unfold_locales) 
     apply (auto simp add: aluprio_defs isEmpty_correct)
     done
 qed
 
 
 subsubsection "Insert"
 
 lemma annot_inf: 
   assumes A: "invar s" "\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty" "al_annot \<alpha> invar annot"
   shows "annot s = Infty \<longleftrightarrow> \<alpha> s = [] " 
 proof -
   from A have invs: "invar s" by (simp add: aluprio_defs)  
   interpret al_annot \<alpha> invar annot by fact
   show "annot s = Infty \<longleftrightarrow> \<alpha> s = []"  
   proof (cases "\<alpha> s = []")
     case True
     hence "map snd (\<alpha> s) = []" by simp
     hence "sum_list (map snd (\<alpha> s)) = Infty"  
       by (auto simp add: zero_def)
     with invs have  "annot s = Infty" by (auto simp add: annot_correct)
     with True show ?thesis by simp
   next
     case False
     hence " \<exists>x xs. (\<alpha> s) = x # xs" by (cases "\<alpha> s") auto
     from this obtain x xs where [simp]: "(\<alpha> s) = x # xs" by blast
     from this assms(2) have "snd x \<noteq> Infty" by (auto simp add: aluprio_defs)
     hence "sum_list (map snd (\<alpha> s)) \<noteq> Infty" by (auto simp add: infadd)
     thus ?thesis using annot_correct invs False by simp
   qed
 qed
 
 lemma e_less_eq_annot: 
   
   assumes "al_annot \<alpha> invar annot" 
    "invar s" "\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty" "\<not> e_less_eq e (annot s)"
   shows "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
 proof -
   interpret al_annot \<alpha> invar annot by fact
   from assms(2) have "annot s = sum_list (map snd (\<alpha> s))"
     by (auto simp add: annot_correct)
   with assms(4) have 
     "\<forall>x \<in> set (map snd (\<alpha> s)). \<not> e_less_eq e x"
     by (metis e_less_eq_sum_list)
   with assms(3) 
   show ?thesis
     by (auto simp add: e_less_eq_p_unwrap)
 qed
 
 lemma aluprio_insert_correct: 
   assumes 
   "al_splits \<alpha> invar splits"
   "al_annot \<alpha> invar annot"
   "al_isEmpty \<alpha> invar isEmpty"
   "al_app \<alpha> invar app"
   "al_consr \<alpha> invar consr"
   shows 
   "uprio_insert (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) 
     (aluprio_insert splits annot isEmpty app consr)"
 proof -
   interpret al_splits \<alpha> invar splits by fact
   interpret al_annot \<alpha> invar annot by fact
   interpret al_isEmpty \<alpha> invar isEmpty by fact
   interpret al_app \<alpha> invar app by fact
   interpret al_consr \<alpha> invar consr by fact
   show ?thesis 
   proof (unfold_locales, unfold aluprio_defs, goal_cases)
     case g1asms: (1 s e a)
     thus ?case proof (cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
       case False with g1asms show  ?thesis
         apply (auto simp add: consr_correct )
       proof goal_cases
         case prems: 1
         with assms(2) have  
           "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
           by (simp add: e_less_eq_annot)
         with prems(3) show ?case
           by(auto simp add: sorted_append)
       next
         case prems: 2
         hence "annot s = sum_list (map snd (\<alpha> s))" 
           by (simp add: annot_correct)
         with prems
         show ?case 
           by (auto simp add: e_less_eq_sum_list2)
       next
         case prems: 3
         hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
         thus ?case by simp
       next
         case prems: 4
         hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
         with prems show ?case by simp
       qed
     next
       case True note T1 = this
       obtain l uu lp r where 
         l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
         by (cases "splits (e_less_eq e) Infty s", auto)
       note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
       have 
         v3: "invar s" 
         "\<not> e_less_eq e Infty"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> s)))"
         using T1 g1asms annot_correct
         by (auto simp add: plus_def)
       have 
         v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"  
         "\<not> e_less_eq e (Infty + sum_list (map snd (\<alpha> l)))"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> l)) + lp)"
         "invar l"
         "invar r"
         using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
       hence v5: "e_less_eq e lp"
         by (metis e_less_eq_lem1)
       hence v6: "e \<le> (fst (p_unwrap lp))"
         by (cases lp) auto
       have "(Infty + sum_list (map snd (\<alpha> l))) = (annot l)"
         by (metis add_0_left annot_correct v4(4) zero_def)
       hence v7:"\<not> e_less_eq e (annot l)"
         using v4(2) by simp
       have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
         using g1asms v4(1) by simp
       hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
         using v4(4) v7 assms(2)
         by(simp add: e_less_eq_annot)
       have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) = 
         map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
         map fst (map p_unwrap (map snd (\<alpha> r)))"
         using v4(1)
         by simp
       note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
         "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)" 
         "map fst (map p_unwrap (map snd (\<alpha> r)))"]
       hence v9: 
         "\<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
         using v4(1) g1asms v8
         by auto
       have v10: 
         "sorted (map fst (map p_unwrap (map snd (\<alpha> l))))"
         "distinct (map fst (map p_unwrap (map snd (\<alpha> l))))"
         "sorted (map fst (map p_unwrap (map snd (\<alpha> r))))"
         "distinct (map fst (map p_unwrap (map snd (\<alpha> l))))"
         using g1asms v8
         by (auto simp add: sorted_append)
       
       from l_lp_r T1 g1asms show ?thesis        
       proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
         case True
         hence v11: 
           "aluprio_insert splits annot isEmpty app consr s e a 
             = app (consr (consr l () (LP e a)) () lp) r"
           using l_lp_r T1
           by (auto simp add: aluprio_defs)
         have  v12: "invar (app (consr (consr l () (LP e a)) () lp) r)" 
           using v4(4,5)
           by (auto simp add: app_correct consr_correct)
         have v13: 
           "\<alpha> (app (consr (consr l () (LP e a)) () lp) r) 
             = \<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r"
           using v4(4,5) by (auto simp add: app_correct consr_correct)
         hence v14: 
           "(\<forall>x\<in>set (\<alpha> (app (consr (consr l () (LP e a)) () lp) r)). 
              snd x \<noteq> Infty)"
           using g1asms v4(1)
           by auto
         have v15: "e = fst(p_unwrap (LP e a))" by simp
         hence v16: 
           "sorted (map fst (map p_unwrap 
              (map snd (\<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r))))"              
           "distinct (map fst (map p_unwrap 
              (map snd (\<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r))))"              
           using v10(1,3) v7 True v9 v4(1) g1asms distinct_sorted_list_lem2
           by (auto simp add: sorted_append)              
         thus "invar (aluprio_insert splits annot isEmpty app consr s e a) \<and>
           (\<forall>x\<in>set (\<alpha> (aluprio_insert splits annot isEmpty app consr s e a)). 
              snd x \<noteq> Infty) \<and>
           sorted (map fst (map p_unwrap (map snd (\<alpha> 
              (aluprio_insert splits annot isEmpty app consr s e a))))) \<and> 
           distinct (map fst (map p_unwrap (map snd (\<alpha> 
              (aluprio_insert splits annot isEmpty app consr s e a)))))"
           using v11 v12 v13 v14
           by simp
       next
         case False            
         hence v11: 
           "aluprio_insert splits annot isEmpty app consr s e a 
              = app (consr l () (LP e a)) r"
           using l_lp_r T1
           by (auto simp add: aluprio_defs)
         have  v12: "invar (app (consr l () (LP e a)) r)" using v4(4,5)
           by (auto simp add: app_correct consr_correct)
         have v13: "\<alpha> (app (consr l () (LP e a)) r) = \<alpha> l @ ((),(LP e a)) # \<alpha> r"
           using v4(4,5) by (auto simp add: app_correct consr_correct)
         hence v14: "(\<forall>x\<in>set (\<alpha> (app (consr l () (LP e a)) r)). snd x \<noteq> Infty)"
           using g1asms v4(1)
           by auto
         have v15: "e = fst(p_unwrap (LP e a))" by simp
         have v16: "e = fst(p_unwrap lp)"
           using False v5 by (cases lp) auto
         hence v17: 
           "sorted (map fst (map p_unwrap 
             (map snd (\<alpha> l @ ((),(LP e a)) # \<alpha> r))))"              
           "distinct (map fst (map p_unwrap 
             (map snd (\<alpha> l @ ((),(LP e a)) # \<alpha> r))))"              
           using v16 v15 v10(1,3) v7 True v9 v4(1) 
             g1asms distinct_sorted_list_lem1
           by (auto simp add: sorted_append)              
         thus "invar (aluprio_insert splits annot isEmpty app consr s e a) \<and>
           (\<forall>x\<in>set (\<alpha> (aluprio_insert splits annot isEmpty app consr s e a)). 
             snd x \<noteq> Infty) \<and>
           sorted (map fst (map p_unwrap (map snd (\<alpha> 
             (aluprio_insert splits annot isEmpty app consr s e a))))) \<and> 
           distinct (map fst (map p_unwrap (map snd (\<alpha> 
             (aluprio_insert splits annot isEmpty app consr s e a)))))"
           using v11 v12 v13 v14
           by simp
       qed
     qed
   next
     case g1asms: (2 s e a)
     thus ?case proof (cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
       case False with g1asms show  ?thesis
         apply (auto simp add: consr_correct)
       proof goal_cases
         case prems: 1
         with assms(2) have  
           "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s)). x < e"
           by (simp add: e_less_eq_annot)
         hence "e \<notin> set (map fst ((map (p_unwrap \<circ> snd)) (\<alpha> s)))"
           by auto
         thus ?case
           by (auto simp add: map_of_distinct_upd)
       next
         case prems: 2
         hence "\<alpha> s = []" by (auto simp add: isEmpty_correct)
         thus ?case
           by simp
       qed
     next
       case True note T1 = this
       obtain l lp r where 
         l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
         by (cases "splits (e_less_eq e) Infty s", auto)
       note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
       have 
         v3: "invar s" 
         "\<not> e_less_eq e Infty"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> s)))"
         using T1 g1asms annot_correct
         by (auto simp add: plus_def)
       have 
         v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"  
         "\<not> e_less_eq e (Infty + sum_list (map snd (\<alpha> l)))"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> l)) + lp)"
         "invar l"
         "invar r"
         using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
       hence v5: "e_less_eq e lp"
         by (metis e_less_eq_lem1)
       hence v6: "e \<le> (fst (p_unwrap lp))"
         by (cases lp) auto
       have "(Infty + sum_list (map snd (\<alpha> l))) = (annot l)"
         by (metis add_0_left annot_correct v4(4) zero_def)
       hence v7:"\<not> e_less_eq e (annot l)"
         using v4(2) by simp
       have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
         using g1asms v4(1) by simp
       hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
         using v4(4) v7 assms(2)
         by(simp add: e_less_eq_annot)
       have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) = 
         map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
         map fst (map p_unwrap (map snd (\<alpha> r)))"
         using v4(1)
         by simp
       note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
         "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)" 
         "map fst (map p_unwrap (map snd (\<alpha> r)))"]
       hence v9: "
         \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
         using v4(1) g1asms v8
         by auto
       hence v10: " \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). e < x"
         using v6 by auto
       have v11: 
         "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
         "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
         using v7 v10 v8 g1asms
         by auto
       from l_lp_r T1 g1asms show ?thesis        
       proof (fold aluprio_insert_def, cases "e < fst (p_unwrap lp)")
         case True
         hence v12: 
           "aluprio_insert splits annot isEmpty app consr s e a 
             = app (consr (consr l () (LP e a)) () lp) r"
           using l_lp_r T1
           by (auto simp add: aluprio_defs)
         have v13: 
           "\<alpha> (app (consr (consr l () (LP e a)) () lp) r) 
             = \<alpha> l @ ((),(LP e a)) # ((), lp) # \<alpha> r"
           using v4(4,5) by (auto simp add: app_correct consr_correct)
         have v14: "e = fst(p_unwrap (LP e a))" by simp
         have v15: "e \<notin> set (map fst (map p_unwrap (map snd(((),lp)#\<alpha> r))))"
           using v11(2) True by auto
         note map_of_distinct_upd2[OF v11(1) v15]
         thus 
           "map_of (map p_unwrap (map snd (\<alpha> 
               (aluprio_insert splits annot isEmpty app consr s e a)))) 
             = map_of (map p_unwrap (map snd (\<alpha> s)))(e \<mapsto> a)"
           using v12 v13 v4(1)
           by simp
       next
         case False            
         hence v12: 
           "aluprio_insert splits annot isEmpty app consr s e a 
             = app (consr l () (LP e a)) r"
           using l_lp_r T1
           by (auto simp add: aluprio_defs)
         have v13: 
           "\<alpha> (app (consr l () (LP e a)) r) = \<alpha> l @ ((),(LP e a)) # \<alpha> r"
           using v4(4,5) by (auto simp add: app_correct consr_correct)
         have v14: "e = fst(p_unwrap lp)"
           using False v5 by (cases lp) auto
         note v15 = map_of_distinct_upd3[OF v11(1) v11(2)]
         have v16:"(map p_unwrap (map snd (\<alpha> s))) = 
           (map p_unwrap (map snd (\<alpha> l))) @ (e,snd(p_unwrap lp)) #
           (map p_unwrap (map snd (\<alpha> r)))"
           using v4(1) v14              
           by simp
         note v15[of a "snd(p_unwrap lp)"]         
         thus 
           "map_of (map p_unwrap (map snd (\<alpha> 
               (aluprio_insert splits annot isEmpty app consr s e a)))) 
             = map_of (map p_unwrap (map snd (\<alpha> s)))(e \<mapsto> a)"
           using v12 v13 v16
           by simp
       qed
     qed
   qed
 qed
 
 subsubsection "Prio"
 lemma aluprio_prio_correct: 
   assumes 
   "al_splits \<alpha> invar splits"
   "al_annot \<alpha> invar annot"
   "al_isEmpty \<alpha> invar isEmpty"
   shows 
   "uprio_prio (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_prio splits annot isEmpty)"
 proof -
   interpret al_splits \<alpha> invar splits by fact
   interpret al_annot \<alpha> invar annot by fact
   interpret al_isEmpty \<alpha> invar isEmpty by fact
   show ?thesis 
   proof (unfold_locales)
     fix s e
     assume inv1: "aluprio_invar \<alpha> invar s"
     hence sinv: "invar s" 
       "(\<forall> x\<in>set (\<alpha> s). snd x\<noteq>Infty)"
       "sorted (map fst (map p_unwrap (map snd (\<alpha> s))))" 
       "distinct (map fst (map p_unwrap (map snd (\<alpha> s))))"
       by (auto simp add: aluprio_defs)
     show "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
     proof(cases "e_less_eq e (annot s) \<and> \<not> isEmpty s")
       case False note F1 = this      
       thus ?thesis
       proof(cases "isEmpty s")
         case True
         hence "\<alpha> s = []"
           using sinv isEmpty_correct by simp
         hence "aluprio_\<alpha> \<alpha> s = Map.empty" by (simp add:aluprio_defs)
         hence "aluprio_\<alpha> \<alpha> s e = None" by simp
         thus "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
           using F1 
           by (auto simp add: aluprio_defs)
       next
         case False
         hence v3:"\<not> e_less_eq e (annot s)"  using F1 by simp
         note v4=e_less_eq_annot[OF assms(2)]
         note v4[OF sinv(1) sinv(2) v3]
         hence v5:"e\<notin>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> s))"
           by auto
         hence "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = None"
           using map_of_eq_None_iff
           by (metis map_map map_of_eq_None_iff set_map v5) 
         thus "aluprio_prio splits annot isEmpty s e = aluprio_\<alpha> \<alpha> s e"
           using F1 
           by (auto simp add: aluprio_defs)
       qed
     next
       case True note T1 = this
       obtain l uu lp r where 
         l_lp_r: "(splits (e_less_eq e) Infty s) = (l, ((), lp), r) "
         by (cases "splits (e_less_eq e) Infty s", auto)
       note v2 = splits_correct[of s "e_less_eq e" Infty l "()" lp r]
       have 
         v3: "invar s" 
         "\<not> e_less_eq e Infty"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> s)))"
         using T1 sinv annot_correct
         by (auto simp add: plus_def)
       have 
         v4: "\<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"  
         "\<not> e_less_eq e (Infty + sum_list (map snd (\<alpha> l)))"
         "e_less_eq e (Infty + sum_list (map snd (\<alpha> l)) + lp)"
         "invar l"
         "invar r"
         using v2[OF v3(1) _ v3(2) v3(3) l_lp_r] e_less_eq_mon(1) by auto
       hence v5: "e_less_eq e lp"
         by (metis e_less_eq_lem1)
       hence v6: "e \<le> (fst (p_unwrap lp))"
         by (cases lp) auto
       have "(Infty + sum_list (map snd (\<alpha> l))) = (annot l)"
         by (metis add_0_left annot_correct v4(4) zero_def)
       hence v7:"\<not> e_less_eq e (annot l)"
         using v4(2) by simp
       have "\<forall>x\<in>set (\<alpha> l). snd x \<noteq> Infty"
         using sinv v4(1) by simp
       hence v7: "\<forall>x \<in> set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> l)). x < e"
         using v4(4) v7 assms(2)
         by(simp add: e_less_eq_annot)
       have v8:"map fst (map p_unwrap (map snd (\<alpha> s))) = 
         map fst (map p_unwrap (map snd (\<alpha> l))) @ fst(p_unwrap lp) #
         map fst (map p_unwrap (map snd (\<alpha> r)))"
         using v4(1)
         by simp
       note distinct_sortet_list_app[of "map fst (map p_unwrap (map snd (\<alpha> s)))"
         "map fst (map p_unwrap (map snd (\<alpha> l)))" "fst(p_unwrap lp)" 
         "map fst (map p_unwrap (map snd (\<alpha> r)))"]
       hence v9: 
         "\<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). fst(p_unwrap lp) < x"
         using v4(1) sinv v8
         by auto
       hence v10: " \<forall> x\<in>set (map (fst \<circ> (p_unwrap \<circ> snd)) (\<alpha> r)). e < x"
         using v6 by auto
       have v11: 
         "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
         "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
         using v7 v10 v8 sinv
         by auto
       from l_lp_r T1 sinv show ?thesis
       proof (cases "e = fst (p_unwrap lp)")
         case False
         have v12: "e \<notin> set (map fst (map p_unwrap (map snd(\<alpha> s))))"
           using v11 False v4(1) by auto
         hence "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = None"
           using map_of_eq_None_iff
           by (metis map_map map_of_eq_None_iff set_map v12)
         thus ?thesis
           using T1 False l_lp_r
           by (auto simp add: aluprio_defs)
       next
         case True
         have v12: "map (p_unwrap \<circ> snd) (\<alpha> s) = 
           map p_unwrap (map snd (\<alpha> l)) @ (e,snd (p_unwrap lp)) #
           map p_unwrap (map snd (\<alpha> r))"
           using v4(1) True by simp
         note map_of_distinct_lookup[OF v11]
         hence
           "map_of (map (p_unwrap \<circ> snd) (\<alpha> s)) e = Some (snd (p_unwrap lp))"
           using v12 by simp
         thus ?thesis
           using T1 True l_lp_r
           by (auto simp add: aluprio_defs)
       qed
     qed
   qed
 qed
         
 
 subsubsection "Pop"
 
 lemma aluprio_pop_correct: 
   assumes "al_splits \<alpha> invar splits"
   "al_annot \<alpha> invar annot"
   "al_app \<alpha> invar app"
   shows 
   "uprio_pop (aluprio_\<alpha> \<alpha>) (aluprio_invar \<alpha> invar) (aluprio_pop splits annot app)"
 proof -
   interpret al_splits \<alpha> invar splits by fact
   interpret al_annot \<alpha> invar annot by fact
   interpret al_app \<alpha> invar app by fact
   show ?thesis 
   proof (unfold_locales)
     fix s e a s'
     assume A: "aluprio_invar \<alpha> invar s" 
       "aluprio_\<alpha> \<alpha> s \<noteq> Map.empty" 
       "aluprio_pop splits annot app s = (e, a, s')"
     hence v1: "\<alpha> s \<noteq> []"
       by (auto simp add: aluprio_defs)
     obtain l lp r where
       l_lp_r: "splits (\<lambda> x. x\<le>annot s) Infty s = (l,((),lp),r)"
       by (cases "splits (\<lambda> x. x\<le>annot s) Infty s", auto)
     have invs:
       "invar s" 
       "(\<forall>x\<in>set (\<alpha> s). snd x \<noteq> Infty)"
       "sorted (map fst (map p_unwrap (map snd (\<alpha> s))))"
       "distinct (map fst (map p_unwrap (map snd (\<alpha> s))))"
       using A by (auto simp add:aluprio_defs)
     note a1 = annot_inf[of invar s \<alpha> annot]
     note a1[OF invs(1) invs(2) assms(2)]
     hence v2: "annot s \<noteq> Infty"
       using v1 by simp
     hence v3:
       "\<not> Infty \<le> annot s"
       by(cases "annot s") (auto simp add: plesseq_def)
     have v4: "annot s = sum_list (map snd (\<alpha> s))"
       by (auto simp add: annot_correct invs(1))
     hence 
       v5:
       "(Infty + sum_list (map snd (\<alpha> s))) \<le> annot s"
       by (auto simp add: plus_def)
     note p_mon = p_less_eq_mon[of _ "annot s"]
     note v6 = splits_correct[OF invs(1)]
     note v7 = v6[of "\<lambda> x. x \<le> annot s"]
     note v7[OF _ v3 v5 l_lp_r] p_mon
     hence v8: 
       " \<alpha> s = \<alpha> l @ ((), lp) # \<alpha> r"
       "\<not> Infty + sum_list (map snd (\<alpha> l)) \<le> annot s"
       "Infty + sum_list (map snd (\<alpha> l)) + lp \<le> annot s"
       "invar l"
       "invar r"
       by auto
     hence v9: "lp \<noteq> Infty"
       using invs(2) by auto
     hence v10: 
       "s' = app l r" 
       "(e,a) = p_unwrap lp"
       using l_lp_r A(3)
       apply (auto simp add: aluprio_defs)
       apply (cases lp)
       apply auto
       apply (cases lp)
       apply auto
       done
     have "lp \<le> annot s"
       using v8(2,3) p_less_eq_lem1
       by auto
     hence v11: "a \<le> snd (p_unwrap (annot s))"
       using v10(2) v2 v9
       apply (cases "annot s")
       apply auto
       apply (cases lp)
       apply (auto simp add: plesseq_def)
       done 
     note sum_list_less_elems[OF invs(2)]
     hence v12: "\<forall>y\<in>set (map snd (map p_unwrap (map snd (\<alpha> s)))). a \<le> y"
       using v4 v11 by auto
     have "ran (aluprio_\<alpha> \<alpha> s) = set (map snd (map p_unwrap (map snd (\<alpha> s))))"
       using ran_distinct[OF invs(4)]
       apply (unfold aluprio_defs)
       apply (simp only: set_map)
       done
     hence ziel1: "\<forall>y\<in>ran (aluprio_\<alpha> \<alpha> s). a \<le> y"
       using v12 by simp
     have v13:
       "map p_unwrap (map snd (\<alpha> s)) 
         = map p_unwrap (map  snd (\<alpha> l)) @ (e,a) # map p_unwrap (map snd (\<alpha> r))"
       using v8(1) v10 by auto
      hence v14:
       "map fst (map p_unwrap (map snd (\<alpha> s))) 
          = map fst (map p_unwrap (map snd (\<alpha> l))) @ e 
              # map fst (map p_unwrap (map snd (\<alpha> r)))"
        by auto
     hence v15: 
       "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> l))))"
       "e \<notin> set (map fst (map p_unwrap (map snd (\<alpha> r))))"
       using invs(4) by auto
     note map_of_distinct_lookup[OF v15]
     note this[of a]
     hence ziel2: "aluprio_\<alpha> \<alpha> s e = Some a"
       using  v13
       by (unfold aluprio_defs, auto)
     have v16: 
       "\<alpha> s' = \<alpha> l @ \<alpha> r" 
       "invar s'"
       using v8(4,5) app_correct v10 by auto
     note map_of_distinct_upd4[OF v15]
     note this[of a]
     hence 
       ziel3: "aluprio_\<alpha> \<alpha> s' = (aluprio_\<alpha> \<alpha> s)(e := None)"
       unfolding aluprio_defs
       using v16(1) v13 by auto
     have ziel4: "aluprio_invar \<alpha> invar s'"
       using v16 v8(1) invs(2,3,4)
       unfolding aluprio_defs
       by (auto simp add: sorted_append)
     
     show "aluprio_invar \<alpha> invar s' \<and>
           aluprio_\<alpha> \<alpha> s' = (aluprio_\<alpha> \<alpha> s)(e := None) \<and>
           aluprio_\<alpha> \<alpha> s e = Some a \<and> (\<forall>y\<in>ran (aluprio_\<alpha> \<alpha> s). a \<le> y)"
       using ziel1 ziel2 ziel3 ziel4 by simp
   qed
 qed
     
 lemmas aluprio_correct =
   aluprio_finite_correct
   aluprio_empty_correct
   aluprio_isEmpty_correct
   aluprio_insert_correct
   aluprio_pop_correct
   aluprio_prio_correct
 
 locale aluprio_defs = StdALDefs ops 
   for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
 begin
   definition [icf_rec_def]: "aluprio_ops \<equiv> \<lparr>
     upr_\<alpha> = aluprio_\<alpha> \<alpha>,
     upr_invar = aluprio_invar \<alpha> invar,
     upr_empty = aluprio_empty empty,
     upr_isEmpty = aluprio_isEmpty isEmpty,
     upr_insert = aluprio_insert splits annot isEmpty app consr,
     upr_pop = aluprio_pop splits annot app,
     upr_prio = aluprio_prio splits annot isEmpty
     \<rparr>"
   
 end
 
 locale aluprio = aluprio_defs ops + StdAL ops 
   for ops :: "(unit,('e::linorder,'a::linorder) LP,'s) alist_ops"
 begin
   lemma aluprio_ops_impl: "StdUprio aluprio_ops"
     apply (rule StdUprio.intro)
     apply (simp_all add: icf_rec_unf)
     apply (rule aluprio_correct)
     apply (rule aluprio_correct, unfold_locales) []
     apply (rule aluprio_correct, unfold_locales) []
     apply (rule aluprio_correct, unfold_locales) []
     apply (rule aluprio_correct, unfold_locales) []
     apply (rule aluprio_correct, unfold_locales) []
     done
 end
 
 end
diff --git a/thys/Collections/Iterator/Proper_Iterator.thy b/thys/Collections/Iterator/Proper_Iterator.thy
--- a/thys/Collections/Iterator/Proper_Iterator.thy
+++ b/thys/Collections/Iterator/Proper_Iterator.thy
@@ -1,269 +1,268 @@
 section \<open>Proper Iterators\<close>
 theory Proper_Iterator
 imports 
   SetIteratorOperations 
   Automatic_Refinement.Refine_Lib
 begin
   text \<open>
     Proper iterators provide a way to obtain polymorphic iterators even
     inside locale contexts.
 
     For this purpose, an iterator that converts the set to a list is fixed
     inside the locale, and polymorphic iterators are described by folding
     over the generated list.
 
     In order to ensure efficiency, it is shown that folding over the generated
     list is equivalent to directly iterating over the set, and this equivalence
     is set up as a code preprocessing rule.
 \<close>
 
   subsection \<open>Proper Iterators\<close>
 
   text \<open>A proper iterator can be expressed as a fold over a list, where
     the list does only depend on the set. In particular, it does not depend
     on the type of the state. We express this by the following definition, 
     using two iterators with different types:\<close>
 
   definition proper_it 
     :: "('x,'\<sigma>1) set_iterator \<Rightarrow> ('x,'\<sigma>2) set_iterator \<Rightarrow> bool"
     where "proper_it it it' \<equiv> (\<exists>l. it=foldli l \<and> it'=foldli l)"
 
   lemma proper_itI[intro?]:
     fixes it :: "('x,'\<sigma>1) set_iterator" 
     and it' :: "('x,'\<sigma>2) set_iterator"
     assumes "it=foldli l \<and> it'=foldli l"
     shows "proper_it it it'"
     using assms unfolding proper_it_def by auto
 
   lemma proper_itE:
     fixes it :: "('x,'\<sigma>1) set_iterator" 
     and it' :: "('x,'\<sigma>2) set_iterator"
     assumes "proper_it it it'"
     obtains l where "it=foldli l" and "it'=foldli l"
     using assms unfolding proper_it_def by auto
 
   lemma proper_it_parE:
     fixes it :: "'a \<Rightarrow> ('x,'\<sigma>1) set_iterator" 
     and it' :: "'a \<Rightarrow> ('x,'\<sigma>2) set_iterator"
     assumes "\<forall>x. proper_it (it x) (it' x)"
     obtains f where "it = (\<lambda>x. foldli (f x))" and "it' = (\<lambda>x. foldli (f x))"
     using assms unfolding proper_it_def
     by metis
 
   definition 
     proper_it'
     where "proper_it' it it' \<equiv> \<forall>s. proper_it (it s) (it' s)"
 
   lemma proper_it'I:
     "\<lbrakk>\<And>s. proper_it (it s) (it' s)\<rbrakk> \<Longrightarrow> proper_it' it it'"
     unfolding proper_it'_def by blast
 
   lemma proper_it'D:
     "proper_it' it it' \<Longrightarrow> proper_it (it s) (it' s)"
     unfolding proper_it'_def by blast
 
 
 
 
 
   subsubsection \<open>Properness Preservation\<close>
   ML \<open>
     structure Icf_Proper_Iterator = struct
 
       structure icf_proper_iteratorI = Named_Thms
         ( val name = @{binding icf_proper_iteratorI_raw}
           val description = "ICF (internal): Rules to show properness of iterators" )
 
       val get = icf_proper_iteratorI.get
   
       fun add_thm thm = icf_proper_iteratorI.add_thm thm
   
       val add = Thm.declaration_attribute add_thm
 
       fun del_thm thm = icf_proper_iteratorI.del_thm thm
 
       val del = Thm.declaration_attribute del_thm
 
       val setup = I
         #> icf_proper_iteratorI.setup
         #> Attrib.setup @{binding icf_proper_iteratorI} 
           (Attrib.add_del add del) 
           ("ICF: Rules to show properness of iterators")
         #> Global_Theory.add_thms_dynamic (@{binding icf_proper_iteratorI}, 
              get o Context.proof_of
             )
         
   
     end
 \<close>
   setup \<open>Icf_Proper_Iterator.setup\<close>
 
   lemma proper_iterator_trigger: 
     "proper_it it it' \<Longrightarrow> proper_it it it'"
     "proper_it' itf itf' \<Longrightarrow> proper_it' itf itf'" .
 
   declaration \<open>
     Tagged_Solver.declare_solver @{thms proper_iterator_trigger} 
       @{binding proper_iterator} "Proper iterator solver"
       (fn ctxt => REPEAT_ALL_NEW (resolve_tac ctxt (Icf_Proper_Iterator.get ctxt)))
 \<close>
 
   lemma pi_foldli[icf_proper_iteratorI]: 
     "proper_it (foldli l :: ('a,'\<sigma>) set_iterator) (foldli l)"
     unfolding proper_it_def 
     by auto
 
   lemma pi_foldri[icf_proper_iteratorI]: 
     "proper_it (foldri l :: ('a,'\<sigma>) set_iterator) (foldri l)"
     unfolding proper_it_def foldri_def by auto
 
   lemma pi'_foldli[icf_proper_iteratorI]: 
     "proper_it' (foldli o tsl) (foldli o tsl)"
     apply (clarsimp simp add: proper_it'_def)
     apply (tagged_solver)
     done
 
   lemma pi'_foldri[icf_proper_iteratorI]: 
     "proper_it' (foldri o tsl) (foldri o tsl)"
     apply (clarsimp simp add: proper_it'_def)
     apply (tagged_solver)
     done
 
   text \<open>Iterator combinators preserve properness\<close>
   lemma pi_emp[icf_proper_iteratorI]: 
     "proper_it set_iterator_emp set_iterator_emp"
     unfolding proper_it_def set_iterator_emp_def[abs_def]
     by (auto intro!: ext exI[where x="[]"])
 
   lemma pi_sng[icf_proper_iteratorI]:
     "proper_it (set_iterator_sng x) (set_iterator_sng x)"
     unfolding proper_it_def set_iterator_sng_def[abs_def]
     by (auto intro!: ext exI[where x="[x]"])
 
   lemma pi_union[icf_proper_iteratorI]:
     assumes PA: "proper_it it_a it_a'"
     assumes PB: "proper_it it_b it_b'"
     shows "proper_it (set_iterator_union it_a it_b)
       (set_iterator_union it_a' it_b')"
     unfolding set_iterator_union_def
     apply (rule proper_itE[OF PA])
     apply (rule proper_itE[OF PB])
     apply (rule_tac l="l@la" in proper_itI)
     apply simp
     apply (intro conjI ext)
     apply (simp_all add: foldli_append)
     done
 
   lemma pi_product[icf_proper_iteratorI]:
     fixes it_a :: "('a,'\<sigma>a) set_iterator"
     fixes it_b :: "'a \<Rightarrow> ('b,'\<sigma>a) set_iterator"
     assumes PA: "proper_it it_a it_a'"
     and PB: "\<And>x. proper_it (it_b x) (it_b' x)"
     shows "proper_it (set_iterator_product it_a it_b)
       (set_iterator_product it_a' it_b')"
   proof -
     from PB have PB': "\<forall>x. proper_it (it_b x) (it_b' x)" ..
     show ?thesis
       unfolding proper_it_def
       apply (rule proper_itE[OF PA])
       apply (rule proper_it_parE[OF PB'])
       apply (auto simp add: set_iterator_product_foldli_conv)
       done
   qed
 
   lemma pi_image_filter[icf_proper_iteratorI]:
     fixes it :: "('x,'\<sigma>1) set_iterator" 
     and it' :: "('x,'\<sigma>2) set_iterator"
     and g :: "'x \<Rightarrow> 'y option"
     assumes P: "proper_it it it'"
     shows "proper_it (set_iterator_image_filter g it) 
       (set_iterator_image_filter g it')"
     unfolding proper_it_def
     apply (rule proper_itE[OF P])
     apply (auto simp: set_iterator_image_filter_foldli_conv)
     done
 
   lemma pi_filter[icf_proper_iteratorI]:
     assumes P: "proper_it it it'"
     shows "proper_it (set_iterator_filter P it) 
       (set_iterator_filter P it')"
     unfolding proper_it_def
     apply (rule proper_itE[OF P])
     by (auto simp: set_iterator_filter_foldli_conv)
 
   lemma pi_image[icf_proper_iteratorI]:
     assumes P: "proper_it it it'"
     shows "proper_it (set_iterator_image g it) 
       (set_iterator_image g it')"
     unfolding proper_it_def
     apply (rule proper_itE[OF P])
     by (auto simp: set_iterator_image_foldli_conv)
 
   lemma pi_dom[icf_proper_iteratorI]:
     assumes P: "proper_it it it'"
     shows "proper_it (map_iterator_dom it) 
       (map_iterator_dom it')"
     unfolding proper_it_def
     apply (rule proper_itE[OF P])
     by (auto simp: map_iterator_dom_foldli_conv)
 
   lemma set_iterator_product_eq2:
     assumes "\<forall>a\<in>set la. itb a = itb' a"
     shows "set_iterator_product (foldli la) itb
     = set_iterator_product (foldli la) itb'"
   proof (intro ext)
     fix c f \<sigma>
     show "set_iterator_product (foldli la) itb c f \<sigma>
       = set_iterator_product (foldli la) itb' c f \<sigma>"
       using assms
       unfolding set_iterator_product_def
       apply (induct la arbitrary: \<sigma>)
       apply (auto)
       done
   qed
 
 
 subsubsection \<open>Optimizing Folds\<close>
   text \<open>
     Using an iterator to create a list. The optimizations will
     match the pattern \<open>foldli (it_to_list it s)\<close>
 \<close>
   definition "it_to_list it s \<equiv> (it s) (\<lambda>_. True) (\<lambda>x l. l@[x]) []"
 
   lemma map_it_to_list_genord_correct:
     assumes A: "map_iterator_genord (it s) m (\<lambda>(k,_) (k',_). R k k')"
     shows "map_of (it_to_list it s) = m
       \<and> distinct (map fst (it_to_list it s))
       \<and> sorted_wrt R ((map fst (it_to_list it s)))"
     unfolding it_to_list_def
     apply (rule map_iterator_genord_rule_insert_P[OF A, where I="
       \<lambda>it l. map_of l = m |` it 
         \<and> distinct (map fst l) 
         \<and> sorted_wrt R ((map fst l))
       "])
     apply auto
     apply (auto simp: restrict_map_def) []
     apply (metis Some_eq_map_of_iff restrict_map_eq(2))
     apply (auto simp add: sorted_wrt_append)
     by (metis (lifting) restrict_map_eq(2) weak_map_of_SomeI)
 
   lemma (in linorder) map_it_to_list_linord_correct:
     assumes A: "map_iterator_linord (it s) m"
     shows "map_of (it_to_list it s) = m
       \<and> distinct (map fst (it_to_list it s))
       \<and> sorted ((map fst (it_to_list it s)))"
     using map_it_to_list_genord_correct[where it=it,
-      OF A[unfolded set_iterator_map_linord_def]]
-    by (simp add: sorted_sorted_wrt)
+      OF A[unfolded set_iterator_map_linord_def]] .
 
   lemma (in linorder) map_it_to_list_rev_linord_correct:
     assumes A: "map_iterator_rev_linord (it s) m"
     shows "map_of (it_to_list it s) = m
       \<and> distinct (map fst (it_to_list it s))
       \<and> sorted (rev (map fst (it_to_list it s)))"
     using map_it_to_list_genord_correct[where it=it,
       OF A[unfolded set_iterator_map_rev_linord_def]]
     by simp
 
  
 end
diff --git a/thys/Collections/Iterator/SetIterator.thy b/thys/Collections/Iterator/SetIterator.thy
--- a/thys/Collections/Iterator/SetIterator.thy
+++ b/thys/Collections/Iterator/SetIterator.thy
@@ -1,795 +1,795 @@
 (*  Title:       Iterators over Finite Sets
     Author:      Thomas Tuerk <tuerk@in.tum.de>
     Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
 *)
 section \<open>\isaheader{Iterators over Finite Sets}\<close>
 theory SetIterator
 imports 
   Automatic_Refinement.Misc 
   Automatic_Refinement.Foldi 
   (*"../../Refine_Monadic/Refine_Monadic"*)
 begin
 
 text \<open>When reasoning about finite sets, it is often handy to be able to iterate over the elements
   of the set. If the finite set is represented by a list, the @{term fold} operation can be used.
   For general finite sets, the order of elements is not fixed though. Therefore, nondeterministic
   iterators are introduced in this theory.\<close>
 
 subsection \<open>General Iterators\<close>
 
 type_synonym ('x,'\<sigma>) set_iterator = "('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('x\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
 
 locale set_iterator_genord =
   fixes iti::"('x,'\<sigma>) set_iterator" 
     and S0::"'x set" 
     and R::"'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes foldli_transform:
     "\<exists>l0. distinct l0 \<and> S0 = set l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0"
 begin
   text \<open>Let's prove some trivial lemmata to show that the formalisation agrees with
           the view of iterators described above.\<close>
   lemma set_iterator_weaken_R :
     "(\<And>x y. \<lbrakk>x \<in> S0; y \<in> S0; R x y\<rbrakk> \<Longrightarrow> R' x y) \<Longrightarrow> 
              set_iterator_genord iti S0 R'"
     by (metis set_iterator_genord.intro foldli_transform sorted_wrt_mono_rel)
 
   lemma finite_S0 :
     shows "finite S0"
     by (metis finite_set foldli_transform)
 
   lemma iti_stop_rule_cond :
     assumes not_c: "\<not>(c \<sigma>)"
     shows "iti c f \<sigma> = \<sigma>"
   proof -
     from foldli_transform obtain l0 where l0_props:
       "iti c = foldli l0 c" by blast
     with foldli_not_cond [of c \<sigma> l0 f, OF not_c]
     show ?thesis by simp
   qed
 
   lemma iti_stop_rule_emp :
     assumes S0_emp: "S0 = {}"
     shows "iti c f \<sigma> = \<sigma>"
   proof -
     from foldli_transform obtain l0 where l0_props:
       "S0 = set l0" "iti c = foldli l0 c" by blast
     with foldli.simps(1) [of c f \<sigma>] S0_emp
     show ?thesis by simp
   qed
 
   text \<open>Reducing everything to folding is cumbersome. Let's
           define a few high-level inference rules.\<close>
 
   lemma iteratei_rule_P:
     assumes 
       "I S0 \<sigma>0"
       "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; 
                  \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0 - S. R y x\<rbrakk> 
                  \<Longrightarrow> I (S - {x}) (f x \<sigma>)"
       "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
       "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> c \<sigma>; I S \<sigma>;
                \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
     shows "P (iti c f \<sigma>0)"
   proof -
     { fix P I \<sigma>0 f
       assume
         I: "I S0 \<sigma>0" and 
         R: "\<And>S \<sigma> x. \<lbrakk>c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>S-{x}. R x y\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>)" and
         C1: "I {} (iti c f \<sigma>0) \<Longrightarrow> P" and
         C2:"\<And>S. \<lbrakk>S \<subseteq> S0; S \<noteq> {}; \<not> c (iti c f \<sigma>0); I S (iti c f \<sigma>0)\<rbrakk> \<Longrightarrow> P"
 
       from foldli_transform obtain l0 where l0_props:
          "distinct l0" "S0 = set l0" "sorted_wrt R l0"  "iti c = foldli l0 c" by auto
 
       from I R  
       have "I {} (iti c f \<sigma>0) \<or> 
           (\<exists>S. S \<subseteq> S0 \<and> S \<noteq> {} \<and> 
                \<not> (c (iti c f \<sigma>0)) \<and> 
                I S (iti c f \<sigma>0))" 
         unfolding l0_props using l0_props(1,3)
       proof (induct l0 arbitrary: \<sigma>0)
         case Nil thus ?case by simp
       next
         case (Cons x l0)
         note ind_hyp = Cons(1)
         note I_x_l0 = Cons(2)
         note step = Cons(3)
         from Cons(4) have dist_l0: "distinct l0" and x_nin_l0: "x \<notin> set l0" by simp_all
         from Cons(5) have R_l0: "\<forall>y\<in>set l0. R x y" and 
                           sort_l0: "sorted_wrt R l0" by simp_all
 
         show ?case
         proof (cases "c \<sigma>0")
           case False
           with I_x_l0 show ?thesis
             apply (rule_tac disjI2)
             apply (rule_tac exI[where x="set (x # l0)"])
             apply (simp)
           done
         next
           case True note c_\<sigma>0 = this
 
           from step[of \<sigma>0 x "set (x # l0)"] I_x_l0 R_l0 c_\<sigma>0 x_nin_l0
           have step': "I (set l0) (f x \<sigma>0)"
             by (simp_all add: Ball_def)
 
           from ind_hyp [OF step' step dist_l0 sort_l0]
           have "I {} (foldli l0 c f (f x \<sigma>0)) \<or> 
                 (\<exists>S. S \<subseteq> set l0 \<and> S \<noteq> {} \<and>
                 \<not> c (foldli l0 c f (f x \<sigma>0)) \<and> I S (foldli l0 c f (f x \<sigma>0)))" 
             by (fastforce)
           thus ?thesis
             by (simp add: c_\<sigma>0 subset_iff) metis
         qed
       qed
       with C1 C2 have "P" by blast
     } note aux = this
 
     from assms
     show ?thesis 
       apply (rule_tac aux [of "\<lambda>S \<sigma>. I S \<sigma> \<and> (\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x)" \<sigma>0 f])
       apply auto
     done
   qed
 
   text \<open>Instead of removing elements one by one from the invariant, adding them is sometimes more natural.\<close>
   lemma iteratei_rule_insert_P:
   assumes pre :
       "I {} \<sigma>0"
       "\<And>S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<forall>y\<in>(S0 - S) - {x}. R x y;
                  \<forall>y\<in>S. R y x\<rbrakk> 
                   \<Longrightarrow> I (insert x S) (f x \<sigma>)"
       "\<And>\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>"
       "\<And>\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> S0; 
               \<not> (c \<sigma>); I S \<sigma>; \<forall>x\<in>S0-S. \<forall>y\<in>S. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
   shows "P (iti c f \<sigma>0)"
   proof -
     let ?I' = "\<lambda>S \<sigma>. I (S0 - S) \<sigma>"
 
     have pre1: 
       "!!\<sigma> S. \<lbrakk> S \<subseteq> S0; S \<noteq> {}; \<not> (c \<sigma>); ?I' S \<sigma>;
              \<forall>x\<in>S. \<forall>y\<in>S0-S. R y x\<rbrakk> \<Longrightarrow> P \<sigma>"
     proof -
       fix S \<sigma>
       assume AA: 
         "S \<subseteq> S0" "S \<noteq> {}"
         "\<not> (c \<sigma>)" 
         "?I' S \<sigma>" "\<forall>x\<in>S. \<forall>y\<in>S0-S. R y x"
       with pre(4) [of "S0 - S"]
       show "P \<sigma>" by auto
     qed
 
     have pre2 :"\<And>x S \<sigma>. \<lbrakk>c \<sigma>; x \<in> S; S \<subseteq> S0; ?I' S \<sigma>; \<forall>y\<in>S - {x}. R x y; \<forall>y\<in>S0-S. R y x \<rbrakk> \<Longrightarrow> ?I' (S - {x}) (f x \<sigma>)"
     proof -
       fix x S \<sigma>
       assume AA : "c \<sigma>" "x \<in> S" "S \<subseteq> S0" "?I' S \<sigma>" "\<forall>y\<in>S - {x}. R x y" "\<forall>y\<in>S0 - S. R y x" 
 
       from AA(2) AA(3) have "S0 - (S - {x}) = insert x (S0 - S)" "S0 - (S0 - S) = S" by auto
       moreover 
       note pre(2) [of \<sigma> x "S0 - S"] AA
       ultimately show "?I' (S - {x}) (f x \<sigma>)"
         by auto
     qed
 
     show "P (iti c f \<sigma>0)" 
       apply (rule iteratei_rule_P [of ?I' \<sigma>0 c f P])
       apply (simp add: pre)
       apply (rule pre2) apply simp_all
       apply (simp add: pre(3))
       apply (simp add: pre1)
     done
   qed
 
   text \<open>Show that iti without interruption is related to fold\<close>
   lemma iti_fold: 
   assumes lc_f: "comp_fun_commute f"
     shows "iti (\<lambda>_. True) f \<sigma>0 = Finite_Set.fold f \<sigma>0 S0"
   proof (rule iteratei_rule_insert_P [where I = "\<lambda>X \<sigma>'. \<sigma>' = Finite_Set.fold f \<sigma>0 X"])
     fix S \<sigma> x
     assume "x \<in> S0 - S" "S \<subseteq> S0" and \<sigma>_eq: "\<sigma> = Finite_Set.fold f \<sigma>0 S"
     from finite_S0 \<open>S \<subseteq> S0\<close> have fin_S: "finite S" by (metis finite_subset)
     from \<open>x \<in> S0 - S\<close> have x_nin_S: "x \<notin> S" by simp
     note fold_eq = comp_fun_commute.fold_insert [OF lc_f fin_S x_nin_S]
 
     show "f x \<sigma> = Finite_Set.fold f \<sigma>0 (insert x S)" 
       by (simp add: fold_eq \<sigma>_eq)
   qed simp_all
 end
 
 
 subsection \<open>Iterators over Maps\<close>
 
 type_synonym ('k,'v,'\<sigma>) map_iterator = "('k\<times>'v,'\<sigma>) set_iterator"
 
 text \<open>Iterator over the key-value pairs of a finite map are called iterators over maps.\<close>
 abbreviation "map_iterator_genord it m R \<equiv> set_iterator_genord it (map_to_set m) R"
 
 subsection \<open>Unordered Iterators\<close>
 
 text \<open>Often one does not care about the order in which the elements are processed. 
         Therefore, the selection function can be set to not impose any further restrictings.
         This leads to considerably simpler theorems.\<close>
 
 definition "set_iterator it S0 \<equiv> set_iterator_genord it S0 (\<lambda>_ _. True)"
 abbreviation "map_iterator it m \<equiv> set_iterator it (map_to_set m)"
 
 lemma set_iterator_intro :
     "set_iterator_genord it S0 R \<Longrightarrow> set_iterator it S0"
 unfolding set_iterator_def
 apply (rule set_iterator_genord.set_iterator_weaken_R [where R = R])
 apply simp_all
 done
 
 lemma set_iterator_no_cond_rule_P:
 "\<lbrakk> set_iterator it S0;
    I S0 \<sigma>0;
    !!S \<sigma> x. \<lbrakk> x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
    !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
  \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
 unfolding set_iterator_def
 using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
 by simp 
 
 lemma set_iterator_no_cond_rule_insert_P:
 "\<lbrakk> set_iterator it S0;
    I {} \<sigma>0;
    !!S \<sigma> x. \<lbrakk> x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
    !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>
  \<rbrakk> \<Longrightarrow> P (it (\<lambda>_. True) f \<sigma>0)"
 unfolding set_iterator_def
 using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
 by simp 
 
 lemma set_iterator_rule_P:
 "\<lbrakk> set_iterator it S0;
    I S0 \<sigma>0;
    !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0 \<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
    !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
    !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
  \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
 unfolding set_iterator_def
 using set_iterator_genord.iteratei_rule_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
 by simp 
 
 lemma set_iterator_rule_insert_P:
 "\<lbrakk> set_iterator it S0;
    I {} \<sigma>0;
    !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0 \<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
    !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
    !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
  \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
 unfolding set_iterator_def
 using set_iterator_genord.iteratei_rule_insert_P [of it S0 "\<lambda>_ _. True" I \<sigma>0 c f P]
 by simp  
 
 
 text\<open>The following rules is adapted for maps. Instead of a set of key-value pairs the invariant
        now only sees the keys.\<close>
 lemma map_iterator_genord_rule_P:
   assumes "map_iterator_genord it m R"
       and I0: "I (dom m) \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>; 
                              \<forall>k' v'. k' \<in> it-{k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                              \<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)\<rbrakk> \<Longrightarrow> 
                             I (it - {k}) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
       and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                          \<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow> 
                                      R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
   shows "P (it c f \<sigma>0)"
 proof (rule set_iterator_genord.iteratei_rule_P [of it "map_to_set m" R "\<lambda>S \<sigma>. I (fst ` S) \<sigma>" \<sigma>0 c f P])
   show "map_iterator_genord it m R" by fact
 next
   show "I (fst ` map_to_set m) \<sigma>0" using I0 by (simp add: map_to_set_dom[symmetric])
 next
   fix \<sigma>
   assume "I (fst ` {}) \<sigma>"
   with IF show "P \<sigma>" by simp
 next
   fix \<sigma> S
   assume "S \<subseteq> map_to_set m" "S \<noteq> {}" "\<not> c \<sigma>" "I (fst ` S) \<sigma>"  
          and R_prop: "\<forall>x\<in>S. \<forall>y\<in>map_to_set m - S. R y x"
   let ?S' = "fst ` S"
 
   show "P \<sigma>"
   proof (rule II [where it = ?S'])
     from \<open>S \<subseteq> map_to_set m\<close>
     show "?S' \<subseteq> dom m"
       unfolding map_to_set_dom
       by auto
   next
     from \<open>S \<noteq> {}\<close> show "?S' \<noteq> {}" by auto
   next
     show "\<not> (c \<sigma>)" by fact
   next
     show "I (fst ` S) \<sigma>" by fact
   next
     show "\<forall>k v k' v'.
        k \<notin> fst ` S \<and>
        m k = Some v \<and>
        k' \<in> fst ` S \<and> m k' = Some v' \<longrightarrow>
        R (k, v) (k', v')" 
     proof (intro allI impI, elim conjE )
       fix k v k' v'
       assume pre_k: "k \<notin> fst ` S" "m k = Some v"
       assume pre_k': "k' \<in> fst ` S" "m k' = Some v'"
 
       from \<open>S \<subseteq> map_to_set m\<close> pre_k' 
       have kv'_in: "(k', v') \<in> S"
         unfolding map_to_set_def by auto
 
       from \<open>S \<subseteq> map_to_set m\<close> pre_k
       have kv_in: "(k, v) \<in> map_to_set m - S"
         unfolding map_to_set_def 
         by (auto simp add: image_iff)
 
       from R_prop kv_in kv'_in
       show "R (k, v) (k',v')" by simp
     qed
   qed
 next
   fix \<sigma> S kv
   assume "S \<subseteq> map_to_set m" "kv \<in> S" "c \<sigma>" and I_S': "I (fst ` S) \<sigma>" and 
          R_S: "\<forall>kv'\<in>S - {kv}. R kv kv'" and
          R_not_S: "\<forall>kv'\<in>map_to_set m - S. R kv' kv"
   let ?S' = "fst ` S" 
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   have "I (fst ` S - {k}) (f (k, v) \<sigma>)"
   proof (rule IP)
     show "c \<sigma>" by fact
   next
     from \<open>kv \<in> S\<close> show "k \<in> ?S'" by (auto simp add: image_iff Bex_def)
   next
     from \<open>kv \<in> S\<close> \<open>S \<subseteq> map_to_set m\<close> 
     have "kv \<in> map_to_set m" by auto
     thus m_k_eq: "m k = Some v" unfolding map_to_set_def by simp
   next
     from \<open>S \<subseteq> map_to_set m\<close>
     show S'_subset: "?S' \<subseteq> dom m"
       unfolding map_to_set_dom
       by auto
   next
     show "I (fst ` S) \<sigma>" by fact
   next
     from \<open>S \<subseteq> map_to_set m\<close> \<open>kv \<in> S\<close>
     have S_simp: "{(k', v'). k' \<in> (fst ` S) - {k} \<and> m k' = Some v'} = S - {kv}"
       unfolding map_to_set_def subset_iff
       apply (auto simp add: image_iff Bex_def)
       apply (metis option.inject)
     done
 
     from R_S[unfolded S_simp[symmetric]] R_not_S
     show "\<forall>k' v'. k' \<in> fst ` S - {k} \<and> m k' = Some v' \<longrightarrow>
                   R (k, v) (k', v') " 
       by simp
   next
     from \<open>S \<subseteq> map_to_set m\<close> R_not_S
     show "\<forall>k' v'. k' \<notin> fst ` S \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)" 
       apply (simp add: Ball_def map_to_set_def subset_iff image_iff)
       apply metis
     done
   qed
 
   moreover 
     from \<open>S \<subseteq> map_to_set m\<close> \<open>kv \<in> S\<close>
     have "fst ` (S - {kv}) = fst ` S - {k}"
       apply (simp add: set_eq_iff image_iff Bex_def map_to_set_def subset_iff)
       apply (metis option.inject)
     done
 
   ultimately show "I (fst ` (S - {kv})) (f kv \<sigma>)" by simp
 qed
 
 lemma map_iterator_genord_rule_insert_P:
   assumes "map_iterator_genord it m R"
       and I0: "I {} \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>; 
                              \<forall>k' v'. k' \<in> (dom m - it) - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v');
                              \<forall>k' v'. k' \<in> it \<and> m k' = Some v' \<longrightarrow> 
                                R (k', v') (k, v)\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
       and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                          \<forall>k v k' v'. k \<in> it \<and> m k = Some v \<and> k' \<notin> it \<and> m k' = Some v' \<longrightarrow> 
                                      R (k, v) (k', v') \<rbrakk> \<Longrightarrow> P \<sigma>"
   shows "P (it c f \<sigma>0)"
 proof (rule map_iterator_genord_rule_P [of it m R "\<lambda>S \<sigma>. I (dom m - S) \<sigma>"])
   show "map_iterator_genord it m R" by fact
 next
   show "I (dom m - dom m) \<sigma>0" using I0 by simp
 next
   fix \<sigma>
   assume "I (dom m - {}) \<sigma>"
   with IF show "P \<sigma>" by simp
 next
   fix \<sigma> it
   assume assms: "it \<subseteq> dom m" "it \<noteq> {}" "\<not> c \<sigma>" "I (dom m - it) \<sigma>"
                 "\<forall>k v k' v'. k \<notin> it \<and> m k = Some v \<and> k' \<in> it \<and> m k' = Some v' \<longrightarrow>
                              R (k, v) (k', v')"
   from assms have "dom m - it \<noteq> dom m" by auto
   with II[of "dom m - it" \<sigma>] assms
   show "P \<sigma>" 
     apply (simp add: subset_iff dom_def)
     apply (metis option.simps(2))
   done
 next
   fix k v it \<sigma>
   assume assms: "c \<sigma>" "k \<in> it" "m k = Some v" "it \<subseteq> dom m" "I (dom m - it) \<sigma>"
                 "\<forall>k' v'. k' \<in> it - {k} \<and> m k' = Some v' \<longrightarrow> R (k, v) (k', v')"
                 "\<forall>k' v'. k' \<notin> it \<and> m k' = Some v' \<longrightarrow> R (k', v') (k, v)"
 
   hence "insert k (dom m - it) = (dom m - (it - {k}))" "dom m - (dom m - it) = it" by auto
   with assms IP[of \<sigma> k "dom m - it" v]
   show "I (dom m - (it - {k})) (f (k, v) \<sigma>)" by (simp_all add: subset_iff)
 qed
 
 lemma map_iterator_rule_P:
   assumes "map_iterator it m"
       and I0: "I (dom m) \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
       and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
   shows "P (it c f \<sigma>0)"
 using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
 unfolding set_iterator_def
 by simp
 
 lemma map_iterator_rule_insert_P:
   assumes "map_iterator it m"
       and I0: "I {} \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
       and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
   shows "P (it c f \<sigma>0)"
 using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 c f P]
 unfolding set_iterator_def
 by simp
 
 lemma map_iterator_no_cond_rule_P:
   assumes "map_iterator it m"
       and I0: "I (dom m) \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
   shows "P (it (\<lambda>_. True) f \<sigma>0)"
 using assms map_iterator_genord_rule_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
 unfolding set_iterator_def
 by simp
 
 lemma map_iterator_no_cond_rule_insert_P:
   assumes "map_iterator it m"
       and I0: "I {} \<sigma>0"
       and IP: "!!k v it \<sigma>. \<lbrakk> k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma> \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
       and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
   shows "P (it (\<lambda>_. True) f \<sigma>0)"
 using assms map_iterator_genord_rule_insert_P[of it m "\<lambda>_ _. True" I \<sigma>0 "\<lambda>_. True" f P]
 unfolding set_iterator_def
 by simp
 
 
 subsection \<open>Ordered Iterators\<close>
 
 text \<open>Selecting according to a linear order is another case that is interesting. 
  Ordered iterators over maps, i.\,e.\ iterators over key-value pairs,
  use an order on the keys.\<close>
 
 context linorder begin
   definition "set_iterator_linord it S0 
     \<equiv> set_iterator_genord it S0 (\<le>)"
   definition "set_iterator_rev_linord it S0 
     \<equiv> set_iterator_genord it S0 (\<ge>)"
   definition "set_iterator_map_linord it S0 \<equiv> 
      set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<le>k')"
   definition "set_iterator_map_rev_linord it S0 \<equiv> 
      set_iterator_genord it S0 (\<lambda>(k,_) (k',_). k\<ge>k')"
   abbreviation "map_iterator_linord it m \<equiv> 
     set_iterator_map_linord it (map_to_set m)"
   abbreviation "map_iterator_rev_linord it m \<equiv> 
     set_iterator_map_rev_linord it (map_to_set m)"
 
   lemma set_iterator_linord_rule_P:
   "\<lbrakk> set_iterator_linord it S0;
      I S0 \<sigma>0;
      !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_linord_def
   apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(\<le>)" I \<sigma>0 c f P])
   apply (simp_all add: Ball_def)
   apply (metis order_refl)
   done
 
   lemma set_iterator_linord_rule_insert_P:
   "\<lbrakk> set_iterator_linord it S0;
      I {} \<sigma>0;
      !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x \<le> x'\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
      !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x' \<le> x) \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_linord_def
   apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(\<le>)" I \<sigma>0 c f P])
   apply (simp_all add: Ball_def)
   apply (metis order_refl)
   done
 
   lemma set_iterator_rev_linord_rule_P:
   "\<lbrakk> set_iterator_rev_linord it S0;
      I S0 \<sigma>0;
      !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S0-S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S \<Longrightarrow> x' \<le> x\<rbrakk> \<Longrightarrow> I (S - {x}) (f x \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>x x'. \<lbrakk>x \<in> S; x' \<in> S0-S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_rev_linord_def
   apply (rule set_iterator_genord.iteratei_rule_P [of it S0 "(\<ge>)" I \<sigma>0 c f P])
   apply (simp_all add: Ball_def)
   apply (metis order_refl)
   done
 
   lemma set_iterator_rev_linord_rule_insert_P:
   "\<lbrakk> set_iterator_rev_linord it S0;
      I {} \<sigma>0;
      !!S \<sigma> x. \<lbrakk> c \<sigma>; x \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>x'. x' \<in> S \<Longrightarrow> x \<le> x'; \<And>x'. x' \<in> S0 - S \<Longrightarrow> x' \<le> x\<rbrakk>  \<Longrightarrow> I (insert x S) (f x \<sigma>);
      !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow>  (\<And>x x'. \<lbrakk>x \<in> S0-S; x' \<in> S\<rbrakk> \<Longrightarrow> x \<le> x') \<Longrightarrow> \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_rev_linord_def
   apply (rule set_iterator_genord.iteratei_rule_insert_P [of it S0 "(\<ge>)" I \<sigma>0 c f P])
   apply (simp_all add: Ball_def)
   apply (metis order_refl)
   done
 
 
   lemma set_iterator_map_linord_rule_P:
   "\<lbrakk> set_iterator_map_linord it S0;
      I S0 \<sigma>0;
      !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k' \<le> k;
                   \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
          \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_map_linord_def
   apply (rule set_iterator_genord.iteratei_rule_P 
     [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
   apply simp_all
   apply (auto simp add: Ball_def)
   apply (metis order_refl)
   apply metis
   done
 
   lemma set_iterator_map_linord_rule_insert_P:
   "\<lbrakk> set_iterator_map_linord it S0;
      I {} \<sigma>0;
      !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k;
                   \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k \<le> k'\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
      !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k \<le> k') \<Longrightarrow>
             \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_map_linord_def
   apply (rule set_iterator_genord.iteratei_rule_insert_P 
     [of it S0 "(\<lambda>(k,_) (k',_). k \<le> k')" I \<sigma>0 c f P])
   apply simp_all
   apply (auto simp add: Ball_def)
   apply (metis order_refl)
   apply metis
   done
 
   lemma set_iterator_map_rev_linord_rule_P:
   "\<lbrakk> set_iterator_map_rev_linord it S0;
      I S0 \<sigma>0;
      !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S0-S \<Longrightarrow> k \<le> k';
                   \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (S - {(k,v)}) (f (k,v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> {} \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S0-S; (k', v') \<in> S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow> 
             \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_map_rev_linord_def
   apply (rule set_iterator_genord.iteratei_rule_P 
     [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
   apply simp_all
   apply (auto simp add: Ball_def)
   apply (metis order_refl)
   apply metis
   done
 
   lemma set_iterator_map_rev_linord_rule_insert_P:
   "\<lbrakk> set_iterator_map_rev_linord it S0;
      I {} \<sigma>0;
      !!S \<sigma> k v. \<lbrakk> c \<sigma>; (k, v) \<in> S0 - S; I S \<sigma>; S \<subseteq> S0; \<And>k' v'. (k', v') \<in> S \<Longrightarrow> k \<le> k';
                  \<And>k' v'. (k',v') \<in> S0 - S \<Longrightarrow> k' \<le> k\<rbrakk>  \<Longrightarrow> I (insert (k,v) S) (f (k,v) \<sigma>);
      !!\<sigma>. I S0 \<sigma> \<Longrightarrow> P \<sigma>;
      !!\<sigma> S. S \<subseteq> S0 \<Longrightarrow> S \<noteq> S0 \<Longrightarrow> (\<And>k v k' v'. \<lbrakk>(k, v) \<in> S; (k', v') \<in> S0-S\<rbrakk> \<Longrightarrow> k' \<le> k) \<Longrightarrow> 
             \<not> c \<sigma> \<Longrightarrow> I S \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (it c f \<sigma>0)"
   unfolding set_iterator_map_rev_linord_def
   apply (rule set_iterator_genord.iteratei_rule_insert_P 
     [of it S0 "(\<lambda>(k,_) (k',_). k \<ge> k')" I \<sigma>0 c f P])
   apply simp_all
   apply (auto simp add: Ball_def)
   apply (metis order_refl)
   apply metis
   done
 
 
   lemma map_iterator_linord_rule_P:
     assumes "map_iterator_linord it m"
         and I0: "I (dom m) \<sigma>0"
         and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                  \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k'; 
                  \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
         and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
         and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                   \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
     shows "P (it c f \<sigma>0)"
   using assms
   unfolding set_iterator_map_linord_def
   by (rule map_iterator_genord_rule_P) auto
 
   lemma map_iterator_linord_rule_insert_P:
     assumes "map_iterator_linord it m"
         and I0: "I {} \<sigma>0"
         and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                  \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k \<le> k'; 
                  \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k \<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
         and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
         and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                   \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> P \<sigma>"
     shows "P (it c f \<sigma>0)"
   using assms
   unfolding set_iterator_map_linord_def
   by (rule map_iterator_genord_rule_insert_P) auto
 
   lemma map_iterator_rev_linord_rule_P:
     assumes "map_iterator_rev_linord it m"
         and I0: "I (dom m) \<sigma>0"
         and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                  \<And>k'. k' \<in> it \<Longrightarrow> k' \<le> k; 
                  \<And>k'. k' \<in> (dom m)-it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
         and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
         and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> {}; \<not> c \<sigma>; I it \<sigma>;
                   \<And>k k'. \<lbrakk>k \<in> (dom m)-it; k' \<in> it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
     shows "P (it c f \<sigma>0)"
   using assms
   unfolding set_iterator_map_rev_linord_def
   by (rule map_iterator_genord_rule_P) auto
 
   lemma map_iterator_rev_linord_rule_insert_P:
     assumes "map_iterator_rev_linord it m"
         and I0: "I {} \<sigma>0"
         and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> dom m - it; m k = Some v; it \<subseteq> dom m; I it \<sigma>;
                  \<And>k'. k' \<in> (dom m - it) \<Longrightarrow> k' \<le> k; 
                  \<And>k'. k' \<in> it \<Longrightarrow> k \<le> k'\<rbrakk> \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
         and IF: "!!\<sigma>. I (dom m) \<sigma> \<Longrightarrow> P \<sigma>"
         and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom m; it \<noteq> dom m; \<not> c \<sigma>; I it \<sigma>;
                   \<And>k k'. \<lbrakk>k \<in> it; k' \<in> (dom m)-it\<rbrakk> \<Longrightarrow> k' \<le> k\<rbrakk> \<Longrightarrow> P \<sigma>"
     shows "P (it c f \<sigma>0)"
   using assms
   unfolding set_iterator_map_rev_linord_def
   by (rule map_iterator_genord_rule_insert_P) auto
 end
 
 subsection \<open>Conversions to foldli\<close>
 
 lemma set_iterator_genord_foldli_conv :
   "set_iterator_genord iti S R \<longleftrightarrow>
    (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0)"
 unfolding set_iterator_genord_def by simp
 
 lemma set_iterator_genord_I [intro] :
   "\<lbrakk>distinct l0; S = set l0; sorted_wrt R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
    set_iterator_genord iti S R" unfolding set_iterator_genord_foldli_conv
    by blast
 
 lemma set_iterator_foldli_conv :
   "set_iterator iti S \<longleftrightarrow>
    (\<exists>l0. distinct l0 \<and> S = set l0 \<and> iti = foldli l0)"
 unfolding set_iterator_def set_iterator_genord_def by simp
 
 lemma set_iterator_I [intro] :
   "\<lbrakk>distinct l0; S = set l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
    set_iterator iti S" 
    unfolding set_iterator_foldli_conv
    by blast
 
 context linorder begin
   lemma set_iterator_linord_foldli_conv :
     "set_iterator_linord iti S \<longleftrightarrow>
      (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted l0 \<and> iti = foldli l0)"
-  unfolding set_iterator_linord_def set_iterator_genord_def by (simp add: sorted_sorted_wrt)
+  unfolding set_iterator_linord_def set_iterator_genord_def by simp
 
   lemma set_iterator_linord_I [intro] :
     "\<lbrakk>distinct l0; S = set l0; sorted l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
      set_iterator_linord iti S" 
      unfolding set_iterator_linord_foldli_conv
      by blast
 
   lemma set_iterator_rev_linord_foldli_conv :
     "set_iterator_rev_linord iti S \<longleftrightarrow>
      (\<exists>l0. distinct l0 \<and> S = set l0 \<and> sorted (rev l0) \<and> iti = foldli l0)"
   unfolding set_iterator_rev_linord_def set_iterator_genord_def by simp
 
   lemma set_iterator_rev_linord_I [intro] :
     "\<lbrakk>distinct l0; S = set l0; sorted (rev l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
      set_iterator_rev_linord iti S" 
      unfolding set_iterator_rev_linord_foldli_conv
      by blast
 end
 
 
 lemma map_iterator_genord_foldli_conv :
   "map_iterator_genord iti m R \<longleftrightarrow>
    (\<exists>(l0::('k \<times> 'v) list). distinct (map fst l0) \<and> m = map_of l0 \<and> sorted_wrt R l0 \<and> iti = foldli l0)"
 proof -
   { fix l0 :: "('k \<times> 'v) list"
     assume dist: "distinct l0"
     have "(map_to_set m = set l0) \<longleftrightarrow>
           (distinct (map fst l0) \<and>
            m = map_of l0)"
     proof (cases "distinct (map fst l0)")
       case True thus ?thesis by (metis map_of_map_to_set)
     next
       case False note not_dist_fst = this
 
       with dist have "~(inj_on fst (set l0))" by (simp add: distinct_map)
       hence "set l0 \<noteq> map_to_set m"
         by (rule_tac notI) (simp add: map_to_set_def inj_on_def)
       with not_dist_fst show ?thesis by simp
     qed
   } 
   thus ?thesis
     unfolding set_iterator_genord_def distinct_map
     by metis
 qed
 
 lemma map_iterator_genord_I [intro] :
   "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted_wrt R l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
    map_iterator_genord iti m R" 
    unfolding map_iterator_genord_foldli_conv
    by blast
 
 lemma map_iterator_foldli_conv :
   "map_iterator iti m \<longleftrightarrow>
    (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> iti = foldli l0)"
 unfolding set_iterator_def map_iterator_genord_foldli_conv 
 by simp
 
 lemma map_iterator_I [intro] :
   "\<lbrakk>distinct (map fst l0); m = map_of l0; iti = foldli l0\<rbrakk> \<Longrightarrow>
    map_iterator iti m" 
    unfolding map_iterator_foldli_conv
    by blast
 
 context linorder begin
 
   lemma sorted_wrt_keys_map_fst:
     "sorted_wrt (\<lambda>(k,_) (k',_). R k k') l = sorted_wrt R (map fst l)"
     by (induct l) auto
 
   lemma map_iterator_linord_foldli_conv :
     "map_iterator_linord iti m \<longleftrightarrow>
      (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (map fst l0) \<and> iti = foldli l0)"
   unfolding set_iterator_map_linord_def map_iterator_genord_foldli_conv
-  by (simp add: sorted_wrt_keys_map_fst sorted_sorted_wrt)
+  by (simp add: sorted_wrt_keys_map_fst)
 
   lemma map_iterator_linord_I [intro] :
     "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted (map fst l0); iti = foldli l0\<rbrakk> \<Longrightarrow>
      map_iterator_linord iti m" 
      unfolding map_iterator_linord_foldli_conv
      by blast
 
   lemma map_iterator_rev_linord_foldli_conv :
     "map_iterator_rev_linord iti m \<longleftrightarrow>
      (\<exists>l0. distinct (map fst l0) \<and> m = map_of l0 \<and> sorted (rev (map fst l0)) \<and> iti = foldli l0)"
   unfolding set_iterator_map_rev_linord_def map_iterator_genord_foldli_conv 
   by (simp add: sorted_wrt_keys_map_fst)
 
   lemma map_iterator_rev_linord_I [intro] :
     "\<lbrakk>distinct (map fst l0); m = map_of l0; sorted (rev (map fst l0)); iti = foldli l0\<rbrakk> \<Longrightarrow>
      map_iterator_rev_linord iti m" 
      unfolding map_iterator_rev_linord_foldli_conv
      by blast
 
 end
 
 end
diff --git a/thys/Containers/RBT_ext.thy b/thys/Containers/RBT_ext.thy
--- a/thys/Containers/RBT_ext.thy
+++ b/thys/Containers/RBT_ext.thy
@@ -1,358 +1,358 @@
 (*  Title:      Containers/RBT_ext.thy
     Author:     Andreas Lochbihler, KIT *)
 
 theory RBT_ext
 imports
   "HOL-Library.RBT_Impl"
   Containers_Auxiliary
   List_Fusion
 begin
 
 section \<open>More on red-black trees\<close>
 
 subsection \<open>More lemmas\<close>
 
 context linorder begin
 
 lemma is_rbt_fold_rbt_insert_impl:
   "is_rbt t \<Longrightarrow> is_rbt (RBT_Impl.fold rbt_insert t' t)"
 by(simp add: rbt_insert_def is_rbt_fold_rbt_insertwk)
 
 lemma rbt_sorted_fold_insert: "rbt_sorted t \<Longrightarrow> rbt_sorted (RBT_Impl.fold rbt_insert t' t)"
 by(induct t' arbitrary: t)(simp_all add: rbt_insert_rbt_sorted)
 
 lemma rbt_lookup_rbt_insert': "rbt_sorted t \<Longrightarrow> rbt_lookup (rbt_insert k v t) = rbt_lookup t(k \<mapsto> v)"
 by(simp add: rbt_insert_def rbt_lookup_rbt_insertwk fun_eq_iff split: option.split)
 
 lemma rbt_lookup_fold_rbt_insert_impl:
   "rbt_sorted t2 \<Longrightarrow> 
   rbt_lookup (RBT_Impl.fold rbt_insert t1 t2) = rbt_lookup t2 ++ map_of (rev (RBT_Impl.entries t1))"
 proof(induction t1 arbitrary: t2)
   case Empty thus ?case by simp
 next
   case (Branch c l x k r)
   show ?case using Branch.prems
     by(simp add: map_add_def Branch.IH rbt_insert_rbt_sorted rbt_sorted_fold_insert rbt_lookup_rbt_insert' fun_eq_iff split: option.split)
 qed
 
 end
 
 subsection \<open>Build the cross product of two RBTs\<close>
 
 context fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e" begin
 
 definition alist_product :: "('a \<times> 'b) list \<Rightarrow> ('c \<times> 'd) list \<Rightarrow> (('a \<times> 'c) \<times> 'e) list"
 where "alist_product xs ys = concat (map (\<lambda>(a, b). map (\<lambda>(c, d). ((a, c), f a b c d)) ys) xs)"
 
 lemma alist_product_simps [simp]:
   "alist_product [] ys = []"
   "alist_product xs [] = []"
   "alist_product ((a, b) # xs) ys = map (\<lambda>(c, d). ((a, c), f a b c d)) ys @ alist_product xs ys"
 by(simp_all add: alist_product_def)
 
 lemma append_alist_product_conv_fold:
   "zs @ alist_product xs ys = rev (fold (\<lambda>(a, b). fold (\<lambda>(c, d) rest. ((a, c), f a b c d) # rest) ys) xs (rev zs))"
 proof(induction xs arbitrary: zs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   obtain a b where x: "x = (a, b)" by(cases x)
   have "\<And>zs. fold (\<lambda>(c, d). (#) ((a, c), f a b c d)) ys zs =
     rev (map (\<lambda>(c, d). ((a, c), f a b c d)) ys) @ zs"
     by(induct ys) auto
   with Cons.IH[of "zs @ map (\<lambda>(c, d). ((a, c), f a b c d)) ys"] x
   show ?case by simp
 qed
 
 lemma alist_product_code [code]:
   "alist_product xs ys =
   rev (fold (\<lambda>(a, b). fold (\<lambda>(c, d) rest. ((a, c), f a b c d) # rest) ys) xs [])"
 using append_alist_product_conv_fold[of "[]" xs ys]
 by simp
 
 lemma set_alist_product:
   "set (alist_product xs ys) =
   (\<lambda>((a, b), (c, d)). ((a, c), f a b c d)) ` (set xs \<times> set ys)"
 by(auto 4 3 simp add: alist_product_def intro: rev_image_eqI rev_bexI)
 
 lemma distinct_alist_product:
   "\<lbrakk> distinct (map fst xs); distinct (map fst ys) \<rbrakk>
   \<Longrightarrow> distinct (map fst (alist_product xs ys))"
 proof(induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   obtain a b where x: "x = (a, b)" by(cases x)
   have "distinct (map (fst \<circ> (\<lambda>(c, d). ((a, c), f a b c d))) ys)"
     using \<open>distinct (map fst ys)\<close> by(induct ys)(auto intro: rev_image_eqI)
   thus ?case using Cons x by(auto simp add: set_alist_product intro: rev_image_eqI)
 qed
 
 lemma map_of_alist_product:
   "map_of (alist_product xs ys) (a, c) = 
   (case map_of xs a of None \<Rightarrow> None
    | Some b \<Rightarrow> map_option (f a b c) (map_of ys c))"
 proof(induction xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   obtain a b where x: "x = (a, b)" by (cases x)
   let ?map = "map (\<lambda>(c, d). ((a, c), f a b c d)) ys"
   have "map_of ?map (a, c) = map_option (f a b c) (map_of ys c)"
     by(induct ys) auto
   moreover {
     fix a' assume "a' \<noteq> a"
     hence "map_of ?map (a', c) = None"
       by(induct ys) auto }
   ultimately show ?case using x Cons.IH
     by(auto simp add: map_add_def split: option.split)
 qed
 
 definition rbt_product :: "('a, 'b) rbt \<Rightarrow> ('c, 'd) rbt \<Rightarrow> ('a \<times> 'c, 'e) rbt"
 where
   "rbt_product rbt1 rbt2 = rbtreeify (alist_product (RBT_Impl.entries rbt1) (RBT_Impl.entries rbt2))"
 
 lemma rbt_product_code [code]:
   "rbt_product rbt1 rbt2 =
    rbtreeify (rev (RBT_Impl.fold (\<lambda>a b. RBT_Impl.fold (\<lambda>c d rest. ((a, c), f a b c d) # rest) rbt2) rbt1 []))"
 unfolding rbt_product_def alist_product_code RBT_Impl.fold_def ..
 
 end
 
 context
   fixes leq_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>a" 50) 
   and less_a :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>a" 50) 
   and leq_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubseteq>\<^sub>b" 50) 
   and less_b :: "'b \<Rightarrow> 'b \<Rightarrow> bool" (infix "\<sqsubset>\<^sub>b" 50) 
   assumes lin_a: "class.linorder leq_a less_a" 
   and lin_b: "class.linorder leq_b less_b"
 begin
 
 abbreviation (input) less_eq_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
 where "less_eq_prod' \<equiv> less_eq_prod leq_a less_a leq_b"
 
 abbreviation (input) less_prod' :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" (infix "\<sqsubset>" 50)
 where "less_prod' \<equiv> less_prod leq_a less_a less_b"
 
 lemmas linorder_prod = linorder_prod[OF lin_a lin_b]
 
 lemma sorted_alist_product: 
   assumes xs: "linorder.sorted leq_a (map fst xs)" "distinct (map fst xs)"
   and ys: "linorder.sorted (\<sqsubseteq>\<^sub>b) (map fst ys)"
   shows "linorder.sorted (\<sqsubseteq>) (map fst (alist_product f xs ys))"
 proof -
   interpret a: linorder "(\<sqsubseteq>\<^sub>a)" "(\<sqsubset>\<^sub>a)" by(fact lin_a)
 
   note [simp] = 
-    linorder.sorted.simps(1)[OF linorder_prod] linorder.sorted.simps(2)[OF linorder_prod]
+    linorder.sorted0[OF linorder_prod] linorder.sorted1[OF linorder_prod]
     linorder.sorted_append[OF linorder_prod]
-    linorder.sorted.simps(2)[OF lin_b]
+    linorder.sorted1[OF lin_b]
 
   show ?thesis using xs
   proof(induction xs)
     case Nil show ?case by simp
   next
     case (Cons x xs)
     obtain a b where x: "x = (a, b)" by(cases x)
     have "linorder.sorted (\<sqsubseteq>) (map fst (map (\<lambda>(c, d). ((a, c), f a b c d)) ys))"
       using ys by(induct ys) auto
     thus ?case using x Cons
       by(fastforce simp add: set_alist_product a.not_less dest: bspec a.order_antisym intro: rev_image_eqI)
   qed
 qed
 
 lemma is_rbt_rbt_product:
   "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
   \<Longrightarrow> ord.is_rbt (\<sqsubset>) (rbt_product f rbt1 rbt2)"
 unfolding rbt_product_def
 by(blast intro: linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b])
 
 lemma rbt_lookup_rbt_product:
   "\<lbrakk> ord.is_rbt (\<sqsubset>\<^sub>a) rbt1; ord.is_rbt (\<sqsubset>\<^sub>b) rbt2 \<rbrakk>
   \<Longrightarrow> ord.rbt_lookup (\<sqsubset>) (rbt_product f rbt1 rbt2) (a, c) =
      (case ord.rbt_lookup (\<sqsubset>\<^sub>a) rbt1 a of None \<Rightarrow> None
       | Some b \<Rightarrow> map_option (f a b c) (ord.rbt_lookup (\<sqsubset>\<^sub>b) rbt2 c))"
 by(simp add: rbt_product_def linorder.rbt_lookup_rbtreeify[OF linorder_prod] linorder.is_rbt_rbtreeify[OF linorder_prod] sorted_alist_product linorder.rbt_sorted_entries[OF lin_a] ord.is_rbt_rbt_sorted linorder.distinct_entries[OF lin_a] linorder.rbt_sorted_entries[OF lin_b] distinct_alist_product linorder.distinct_entries[OF lin_b] map_of_alist_product linorder.map_of_entries[OF lin_a] linorder.map_of_entries[OF lin_b] cong: option.case_cong)
 
 end
 
 hide_const less_eq_prod' less_prod'
 
 subsection \<open>Build an RBT where keys are paired with themselves\<close>
 
 primrec RBT_Impl_diag :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'a, 'b) rbt"
 where
   "RBT_Impl_diag rbt.Empty = rbt.Empty"
 | "RBT_Impl_diag (rbt.Branch c l k v r) = rbt.Branch c (RBT_Impl_diag l) (k, k) v (RBT_Impl_diag r)"
 
 lemma entries_RBT_Impl_diag:
   "RBT_Impl.entries (RBT_Impl_diag t) = map (\<lambda>(k, v). ((k, k), v)) (RBT_Impl.entries t)"
 by(induct t) simp_all
 
 lemma keys_RBT_Impl_diag:
   "RBT_Impl.keys (RBT_Impl_diag t) = map (\<lambda>k. (k, k)) (RBT_Impl.keys t)"
 by(simp add: RBT_Impl.keys_def entries_RBT_Impl_diag split_beta)
 
 lemma rbt_sorted_RBT_Impl_diag:
   "ord.rbt_sorted lt t \<Longrightarrow> ord.rbt_sorted (less_prod leq lt lt) (RBT_Impl_diag t)"
 by(induct t)(auto simp add: ord.rbt_sorted.simps ord.rbt_less_prop ord.rbt_greater_prop keys_RBT_Impl_diag)
 
 lemma bheight_RBT_Impl_diag:
   "bheight (RBT_Impl_diag t) = bheight t"
 by(induct t) simp_all
 
 lemma inv_RBT_Impl_diag:
   assumes "inv1 t" "inv2 t"
   shows "inv1 (RBT_Impl_diag t)" "inv2 (RBT_Impl_diag t)"
   and "color_of t = color.B \<Longrightarrow> color_of (RBT_Impl_diag t) = color.B"
 using assms by(induct t)(auto simp add: bheight_RBT_Impl_diag)
 
 lemma is_rbt_RBT_Impl_diag:
   "ord.is_rbt lt t \<Longrightarrow> ord.is_rbt (less_prod leq lt lt) (RBT_Impl_diag t)"
 by(simp add: ord.is_rbt_def rbt_sorted_RBT_Impl_diag inv_RBT_Impl_diag)
 
 lemma (in linorder) rbt_lookup_RBT_Impl_diag:
   "ord.rbt_lookup (less_prod (\<le>) (<) (<)) (RBT_Impl_diag t) =
   (\<lambda>(k, k'). if k = k' then ord.rbt_lookup (<) t k else None)"
 by(induct t)(auto simp add: ord.rbt_lookup.simps fun_eq_iff)
 
 subsection \<open>Folding and quantifiers over RBTs\<close>
 
 definition RBT_Impl_fold1 :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a, unit) RBT_Impl.rbt \<Rightarrow> 'a"
 where "RBT_Impl_fold1 f rbt = fold f (tl (RBT_Impl.keys rbt)) (hd (RBT_Impl.keys rbt))"
 
 lemma RBT_Impl_fold1_simps [simp, code]:
   "RBT_Impl_fold1 f rbt.Empty = undefined"
   "RBT_Impl_fold1 f (Branch c rbt.Empty k v r) = RBT_Impl.fold (\<lambda>k v. f k) r k"
   "RBT_Impl_fold1 f (Branch c (Branch c' l' k' v' r') k v r) = 
    RBT_Impl.fold (\<lambda>k v. f k) r (f k (RBT_Impl_fold1 f (Branch c' l' k' v' r')))"
 by(simp_all add: RBT_Impl_fold1_def RBT_Impl.keys_def fold_map RBT_Impl.fold_def split_def o_def tl_append hd_def split: list.split)
 
 definition RBT_Impl_rbt_all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
 where [code del]: "RBT_Impl_rbt_all P rbt = (\<forall>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"
 
 lemma RBT_Impl_rbt_all_simps [simp, code]:
   "RBT_Impl_rbt_all P rbt.Empty \<longleftrightarrow> True"
   "RBT_Impl_rbt_all P (Branch c l k v r) \<longleftrightarrow> P k v \<and> RBT_Impl_rbt_all P l \<and> RBT_Impl_rbt_all P r"
 by(auto simp add: RBT_Impl_rbt_all_def)
 
 definition RBT_Impl_rbt_ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
 where [code del]: "RBT_Impl_rbt_ex P rbt = (\<exists>(k, v) \<in> set (RBT_Impl.entries rbt). P k v)"
 
 lemma RBT_Impl_rbt_ex_simps [simp, code]:
   "RBT_Impl_rbt_ex P rbt.Empty \<longleftrightarrow> False"
   "RBT_Impl_rbt_ex P (Branch c l k v r) \<longleftrightarrow> P k v \<or> RBT_Impl_rbt_ex P l \<or> RBT_Impl_rbt_ex P r"
 by(auto simp add: RBT_Impl_rbt_ex_def)
 
 subsection \<open>List fusion for RBTs\<close>
 
 type_synonym ('a, 'b, 'c) rbt_generator_state = "('c \<times> ('a, 'b) RBT_Impl.rbt) list \<times> ('a, 'b) RBT_Impl.rbt"
 
 fun rbt_has_next :: "('a, 'b, 'c) rbt_generator_state \<Rightarrow> bool"
 where
   "rbt_has_next ([], rbt.Empty) = False"
 | "rbt_has_next _ = True"
 
 fun rbt_keys_next :: "('a, 'b, 'a) rbt_generator_state \<Rightarrow> 'a \<times> ('a, 'b, 'a) rbt_generator_state"
 where
   "rbt_keys_next ((k, t) # kts, rbt.Empty) = (k, kts, t)"
 | "rbt_keys_next (kts, rbt.Branch c l k v r) = rbt_keys_next ((k, r) # kts, l)"
 
 lemma rbt_generator_induct [case_names empty split shuffle]:
   assumes "P ([], rbt.Empty)"
   and "\<And>k t kts. P (kts, t) \<Longrightarrow> P ((k, t) # kts, rbt.Empty)"
   and "\<And>kts c l k v r. P ((f k v, r) # kts, l) \<Longrightarrow> P (kts, Branch c l k v r)"
   shows "P ktst"
 using assms
 apply(induction_schema)
 apply pat_completeness
 apply(relation "measure (\<lambda>(kts, t). size_list (\<lambda>(k, t). size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t) kts + size_rbt (\<lambda>_. 1) (\<lambda>_. 1) t)")
 apply simp_all
 done
 
 lemma terminates_rbt_keys_generator:
   "terminates (rbt_has_next, rbt_keys_next)"
 proof
   fix ktst :: "('a \<times> ('a, 'b) rbt) list \<times> ('a, 'b) rbt"
   show "ktst \<in> terminates_on (rbt_has_next, rbt_keys_next)"
     by(induct ktst taking: "\<lambda>k _. k" rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
 qed
 
 lift_definition rbt_keys_generator :: "('a, ('a, 'b, 'a) rbt_generator_state) generator"
   is "(rbt_has_next, rbt_keys_next)"
 by(rule terminates_rbt_keys_generator)
 
 definition rbt_init :: "('a, 'b) rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
 where "rbt_init = Pair []"
 
 lemma has_next_rbt_keys_generator [simp]:
   "list.has_next rbt_keys_generator = rbt_has_next"
 by transfer simp
 
 lemma next_rbt_keys_generator [simp]:
   "list.next rbt_keys_generator = rbt_keys_next"
 by transfer simp
 
 lemma unfoldr_rbt_keys_generator_aux:
   "list.unfoldr rbt_keys_generator (kts, t) = 
   RBT_Impl.keys t @ concat (map (\<lambda>(k, t). k # RBT_Impl.keys t) kts)"
 proof(induct "(kts, t)" arbitrary: kts t taking: "\<lambda>k _. k" rule: rbt_generator_induct)
   case empty thus ?case
     by(simp add: list.unfoldr.simps)
 next
   case split thus ?case
     by(subst list.unfoldr.simps) simp
 next
   case shuffle thus ?case
     by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
 qed
 
 corollary unfoldr_rbt_keys_generator:
   "list.unfoldr rbt_keys_generator (rbt_init t) = RBT_Impl.keys t"
 by(simp add: unfoldr_rbt_keys_generator_aux rbt_init_def)
 
 fun rbt_entries_next :: 
   "('a, 'b, 'a \<times> 'b) rbt_generator_state \<Rightarrow> ('a \<times> 'b) \<times> ('a, 'b, 'a \<times> 'b) rbt_generator_state"
 where
   "rbt_entries_next ((kv, t) # kts, rbt.Empty) = (kv, kts, t)"
 | "rbt_entries_next (kts, rbt.Branch c l k v r) = rbt_entries_next (((k, v), r) # kts, l)"
 
 lemma terminates_rbt_entries_generator:
   "terminates (rbt_has_next, rbt_entries_next)"
 proof(rule terminatesI)
   fix ktst :: "('a, 'b, 'a \<times> 'b) rbt_generator_state"
   show "ktst \<in> terminates_on (rbt_has_next, rbt_entries_next)"
     by(induct ktst taking: Pair rule: rbt_generator_induct)(auto 4 3 intro: terminates_on.intros elim: terminates_on.cases)
 qed
 
 lift_definition rbt_entries_generator :: "('a \<times> 'b, ('a, 'b, 'a \<times> 'b) rbt_generator_state) generator"
   is "(rbt_has_next, rbt_entries_next)"
 by(rule terminates_rbt_entries_generator)
 
 lemma has_next_rbt_entries_generator [simp]:
   "list.has_next rbt_entries_generator = rbt_has_next"
 by transfer simp
 
 lemma next_rbt_entries_generator [simp]:
   "list.next rbt_entries_generator = rbt_entries_next"
 by transfer simp
 
 lemma unfoldr_rbt_entries_generator_aux:
   "list.unfoldr rbt_entries_generator (kts, t) = 
   RBT_Impl.entries t @ concat (map (\<lambda>(k, t). k # RBT_Impl.entries t) kts)"
 proof(induct "(kts, t)" arbitrary: kts t taking: Pair rule: rbt_generator_induct)
   case empty thus ?case
     by(simp add: list.unfoldr.simps)
 next
   case split thus ?case
     by(subst list.unfoldr.simps) simp
 next
   case shuffle thus ?case
     by(subst list.unfoldr.simps)(subst (asm) list.unfoldr.simps, simp)
 qed
 
 corollary unfoldr_rbt_entries_generator:
   "list.unfoldr rbt_entries_generator (rbt_init t) = RBT_Impl.entries t"
 by(simp add: unfoldr_rbt_entries_generator_aux rbt_init_def)
 
 end
diff --git a/thys/Containers/Set_Linorder.thy b/thys/Containers/Set_Linorder.thy
--- a/thys/Containers/Set_Linorder.thy
+++ b/thys/Containers/Set_Linorder.thy
@@ -1,2481 +1,2481 @@
 (*  Title:      Containers/Set_Linorder.thy
     Author:     Andreas Lochbihler, KIT *)
 
 theory Set_Linorder 
 imports
   Containers_Auxiliary
   Lexicographic_Order
   Extend_Partial_Order
   "HOL-Library.Cardinality"
 begin
 
 section \<open>An executable linear order on sets\<close>
 
 subsection \<open>Definition of the linear order\<close>
 
 subsubsection \<open>Extending finite and cofinite sets\<close>
 
 text \<open>
   Partition sets into finite and cofinite sets and distribute the rest arbitrarily such that
   complement switches between the two.
 \<close>
 
 consts infinite_complement_partition :: "'a set set"
 
 specification (infinite_complement_partition)
   finite_complement_partition: "finite (A :: 'a set) \<Longrightarrow> A \<in> infinite_complement_partition"
   complement_partition: "\<not> finite (UNIV :: 'a set)
     \<Longrightarrow> (A :: 'a set) \<in> infinite_complement_partition \<longleftrightarrow> - A \<notin> infinite_complement_partition"
 proof(cases "finite (UNIV :: 'a set)")
   case False
   define Field_r where "Field_r = {\<P> :: 'a set set. (\<forall>C \<in> \<P>. - C \<notin> \<P>) \<and> (\<forall>A. finite A \<longrightarrow> A \<in> \<P>)}"
   define r where "r = {(\<P>1, \<P>2). \<P>1 \<subseteq> \<P>2 \<and> \<P>1 \<in> Field_r \<and> \<P>2 \<in> Field_r}"
   have in_Field_r [simp]: "\<And>\<P>. \<P> \<in> Field_r \<longleftrightarrow> (\<forall>C \<in> \<P>. - C \<notin> \<P>) \<and> (\<forall>A. finite A \<longrightarrow> A \<in> \<P>)"
     unfolding Field_r_def by simp
   have in_r [simp]: "\<And>\<P>1 \<P>2. (\<P>1, \<P>2) \<in> r \<longleftrightarrow> \<P>1 \<subseteq> \<P>2 \<and> \<P>1 \<in> Field_r \<and> \<P>2 \<in> Field_r"
     unfolding r_def by simp
   have Field_r [simp]: "Field r = Field_r" by(auto simp add: Field_def Field_r_def)
   
   have "Partial_order r"
     by(auto simp add: Field_def r_def partial_order_on_def preorder_on_def intro!: refl_onI transI antisymI)
   moreover have "\<exists>\<B> \<in> Field r. \<forall>\<A> \<in> \<CC>. (\<A>, \<B>) \<in> r" if \<CC>: "\<CC> \<in> Chains r" for \<CC>
   proof -
     let ?\<B> = "\<Union>\<CC> \<union> {A. finite A}"
     have *: "?\<B> \<in> Field r" using False \<CC>
       by clarsimp(safe, drule (2) ChainsD, auto 4 4 dest: Chains_Field)
     hence "\<And>\<A>. \<A> \<in> \<CC> \<Longrightarrow> (\<A>, ?\<B>) \<in> r"
       using \<CC> by(auto simp del: in_Field_r dest: Chains_Field)
     with * show "\<exists>\<B> \<in> Field r. \<forall>\<A> \<in> \<CC>. (\<A>, \<B>) \<in> r" by blast
   qed
   ultimately have "\<exists>\<P> \<in> Field r. \<forall>\<A> \<in> Field r. (\<P>, \<A>) \<in> r \<longrightarrow> \<A> = \<P>"
     by(rule Zorns_po_lemma)
   then obtain \<P> where \<P>: "\<P> \<in> Field r" 
     and max: "\<And>\<A>. \<lbrakk> \<A> \<in> Field r; (\<P>, \<A>) \<in> r \<rbrakk> \<Longrightarrow> \<A> = \<P>" by blast
   have "\<forall>A. finite A \<longrightarrow> A \<in> \<P>" using \<P> by simp
   moreover {
     fix C
     have "C \<in> \<P> \<or> - C \<in> \<P>"
     proof(rule ccontr)
       assume "\<not> ?thesis"
       hence C: "C \<notin> \<P>" "- C \<notin> \<P>" by simp_all
       let ?\<A> = "insert C \<P>"
       have *: "?\<A> \<in> Field r" using C \<P> by auto
       hence "(\<P>, ?\<A>) \<in> r" using \<P> by auto
       with * have "?\<A> = \<P>" by(rule max)
       thus False using C by auto
     qed
     hence "C \<in> \<P> \<longleftrightarrow> - C \<notin> \<P>" using \<P> by auto }
   ultimately have "\<exists>\<P> :: 'a set set. (\<forall>A. finite A \<longrightarrow> A \<in> \<P>) \<and> (\<forall>C. C \<in> \<P> \<longleftrightarrow> - C \<notin> \<P>)"
     by blast
   thus ?thesis by metis
 qed auto
 
 lemma not_in_complement_partition:
   "\<not> finite (UNIV :: 'a set)
   \<Longrightarrow> (A :: 'a set) \<notin> infinite_complement_partition \<longleftrightarrow> - A \<in> infinite_complement_partition"
 by(metis complement_partition)
 
 lemma not_in_complement_partition_False:
   "\<lbrakk> (A :: 'a set) \<in> infinite_complement_partition; \<not> finite (UNIV :: 'a set) \<rbrakk> 
   \<Longrightarrow> - A \<in> infinite_complement_partition = False"
 by(simp add: not_in_complement_partition)
 
 lemma infinite_complement_partition_finite [simp]:
   "finite (UNIV :: 'a set) \<Longrightarrow> infinite_complement_partition = (UNIV :: 'a set set)"
 by(auto intro: finite_subset finite_complement_partition)
 
 lemma Compl_eq_empty_iff: "- A = {} \<longleftrightarrow> A = UNIV"
 by auto
 
 subsubsection \<open>A lexicographic-style order on finite subsets\<close>
 
 context ord begin
 
 definition set_less_aux :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubset>''" 50)
 where "A \<sqsubset>' B \<longleftrightarrow> finite A \<and> finite B \<and> (\<exists>y \<in> B - A. \<forall>z \<in> (A - B) \<union> (B - A). y \<le> z \<and> (z \<le> y \<longrightarrow> y = z))"
 
 definition set_less_eq_aux :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''" 50)
 where "A \<sqsubseteq>' B \<longleftrightarrow> A \<in> infinite_complement_partition \<and> A = B \<or> A \<sqsubset>' B"
 
 lemma set_less_aux_irrefl [iff]: "\<not> A \<sqsubset>' A"
 by(auto simp add: set_less_aux_def)
 
 lemma set_less_eq_aux_refl [iff]: "A \<sqsubseteq>' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 by(simp add: set_less_eq_aux_def)
 
 lemma set_less_aux_empty [simp]: "\<not> A \<sqsubset>' {}"
 by(auto simp add: set_less_aux_def intro: finite_subset finite_complement_partition)
 
 lemma set_less_eq_aux_empty [simp]: "A \<sqsubseteq>' {} \<longleftrightarrow> A = {}"
 by(auto simp add: set_less_eq_aux_def finite_complement_partition)
 
 lemma set_less_aux_antisym: "\<lbrakk> A \<sqsubset>' B; B \<sqsubset>' A \<rbrakk> \<Longrightarrow> False"
 by(auto simp add: set_less_aux_def split: if_split_asm)
 
 lemma set_less_aux_conv_set_less_eq_aux:
   "A \<sqsubset>' B \<longleftrightarrow> A \<sqsubseteq>' B \<and> \<not> B \<sqsubseteq>' A"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_antisym)
 
 lemma set_less_eq_aux_antisym: "\<lbrakk> A \<sqsubseteq>' B; B \<sqsubseteq>' A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_antisym)
 
 lemma set_less_aux_finiteD: "A \<sqsubset>' B \<Longrightarrow> finite A \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_aux_def finite_complement_partition)
 
 lemma set_less_eq_aux_infinite_complement_partitionD:
   "A \<sqsubseteq>' B \<Longrightarrow> A \<in> infinite_complement_partition \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_finiteD intro: finite_complement_partition)
 
 lemma Compl_set_less_aux_Compl:
   "finite (UNIV :: 'a set) \<Longrightarrow> - A \<sqsubset>' - B \<longleftrightarrow> B \<sqsubset>' A"
 by(auto simp add: set_less_aux_def finite_subset[OF subset_UNIV])
 
 lemma Compl_set_less_eq_aux_Compl: 
   "finite (UNIV :: 'a set) \<Longrightarrow> - A \<sqsubseteq>' - B \<longleftrightarrow> B \<sqsubseteq>' A"
 by(auto simp add: set_less_eq_aux_def Compl_set_less_aux_Compl)
 
 lemma set_less_aux_insert_same:
   "x \<in> A \<longleftrightarrow> x \<in> B \<Longrightarrow> insert x A \<sqsubset>' insert x B \<longleftrightarrow> A \<sqsubset>' B"
 by(auto simp add: set_less_aux_def)
 
 lemma set_less_eq_aux_insert_same:
   "\<lbrakk> A \<in> infinite_complement_partition; insert x B \<in> infinite_complement_partition;
     x \<in> A \<longleftrightarrow> x \<in> B \<rbrakk>
   \<Longrightarrow> insert x A \<sqsubseteq>' insert x B \<longleftrightarrow> A \<sqsubseteq>' B"
 by(auto simp add: set_less_eq_aux_def set_less_aux_insert_same)
 
 end
 
 context order begin
 
 lemma set_less_aux_singleton_iff: "A \<sqsubset>' {x} \<longleftrightarrow> finite A \<and> (\<forall>a\<in>A. x < a)"
 by(auto simp add: set_less_aux_def less_le Bex_def)
 
 end
 
 context linorder begin
 
 lemma wlog_le [case_names sym le]:
   assumes "\<And>a b. P a b \<Longrightarrow> P b a"
   and "\<And>a b. a \<le> b \<Longrightarrow> P a b"
   shows "P b a"
 by (metis assms linear)
 
 lemma empty_set_less_aux [simp]: "{} \<sqsubset>' A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
 by(auto 4 3 simp add: set_less_aux_def intro!: Min_eqI intro: bexI[where x="Min A"] order_trans[where y="Min A"] Min_in)
 
 lemma empty_set_less_eq_aux [simp]: "{} \<sqsubseteq>' A \<longleftrightarrow> finite A"
 by(auto simp add: set_less_eq_aux_def finite_complement_partition)
 
 lemma set_less_aux_trans:
   assumes AB: "A \<sqsubset>' B" and BC: "B \<sqsubset>' C"
   shows "A \<sqsubset>' C"
 proof -
   from AB BC have A: "finite A" and B: "finite B" and C: "finite C"
     by(auto simp add: set_less_aux_def)
   from AB A B obtain ab where ab: "ab \<in> B - A"
     and minAB: "\<And>x. \<lbrakk> x \<in> A; x \<notin> B \<rbrakk> \<Longrightarrow> ab \<le> x \<and> (x \<le> ab \<longrightarrow> ab = x)"
     and minBA: "\<And>x. \<lbrakk> x \<in> B; x \<notin> A \<rbrakk> \<Longrightarrow> ab \<le> x \<and> (x \<le> ab \<longrightarrow> ab = x)" 
     unfolding set_less_aux_def by auto
   from BC B C obtain bc where bc: "bc \<in> C - B"
     and minBC: "\<And>x. \<lbrakk> x \<in> B; x \<notin> C \<rbrakk> \<Longrightarrow> bc \<le> x \<and> (x \<le> bc \<longrightarrow> bc = x)"
     and minCB: "\<And>x. \<lbrakk> x \<in> C; x \<notin> B \<rbrakk> \<Longrightarrow> bc \<le> x \<and> (x \<le> bc \<longrightarrow> bc = x)"
     unfolding set_less_aux_def by auto
   show ?thesis
   proof(cases "ab \<le> bc")
     case True
     hence "ab \<in> C - A" "ab \<notin> A - C"
       using ab bc by(auto dest: minBC antisym)
     moreover {
       fix x
       assume x: "x \<in> (C - A) \<union> (A - C)"
       hence "ab \<le> x" 
         by(cases "x \<in> B")(auto dest: minAB minBA minBC minCB intro: order_trans[OF True])
       moreover hence "ab \<noteq> x \<longrightarrow> \<not> x \<le> ab" using ab bc x
         by(cases "x \<in> B")(auto dest: antisym)
       moreover note calculation }
     ultimately show ?thesis using A C unfolding set_less_aux_def by auto
   next
     case False
     with linear[of ab bc] have "bc \<le> ab" by simp
     with ab bc have "bc \<in> C - A" "bc \<notin> A - C" by(auto dest: minAB antisym)
     moreover {
       fix x
       assume x: "x \<in> (C - A) \<union> (A - C)"
       hence "bc \<le> x"
         by(cases "x \<in> B")(auto dest: minAB minBA minBC minCB intro: order_trans[OF \<open>bc \<le> ab\<close>])
       moreover hence "bc \<noteq> x \<longrightarrow> \<not> x \<le> bc" using ab bc x
         by(cases "x \<in> B")(auto dest: antisym) 
       moreover note calculation }
     ultimately show ?thesis using A C unfolding set_less_aux_def by auto
   qed
 qed
 
 lemma set_less_eq_aux_trans [trans]:
   "\<lbrakk> A \<sqsubseteq>' B; B \<sqsubseteq>' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' C"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_trans)
 
 lemma set_less_trans_set_less_eq [trans]:
   "\<lbrakk> A \<sqsubset>' B; B \<sqsubseteq>' C \<rbrakk> \<Longrightarrow> A \<sqsubset>' C"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_trans)
 
 lemma set_less_eq_aux_porder: "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>' B}"
 by(auto simp add: preorder_on_def partial_order_on_def intro!: refl_onI transI antisymI dest: set_less_eq_aux_infinite_complement_partitionD intro: set_less_eq_aux_antisym set_less_eq_aux_trans del: equalityI)
 
 lemma psubset_finite_imp_set_less_aux:
   assumes AsB: "A \<subset> B" and B: "finite B"
   shows "A \<sqsubset>' B"
 proof -
   from AsB B have A: "finite A" by(auto intro: finite_subset)
   moreover from AsB B have "Min (B - A) \<in> B - A" by - (rule Min_in, auto)
   ultimately show ?thesis using B AsB
     by(auto simp add: set_less_aux_def intro!: rev_bexI[where x="Min (B - A)"] Min_eqI dest: Min_ge_iff[THEN iffD1, rotated 2])
 qed
 
 lemma subset_finite_imp_set_less_eq_aux:
   "\<lbrakk> A \<subseteq> B; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B"
 by(cases "A = B")(auto simp add: set_less_eq_aux_def finite_complement_partition intro: psubset_finite_imp_set_less_aux)
 
 lemma empty_set_less_aux_finite_iff: 
   "finite A \<Longrightarrow> {} \<sqsubset>' A \<longleftrightarrow> A \<noteq> {}"
 by(auto intro: psubset_finite_imp_set_less_aux)
 
 lemma set_less_aux_finite_total:
   assumes A: "finite A" and B: "finite B"
   shows "A \<sqsubset>' B \<or> A = B \<or> B \<sqsubset>' A"
 proof(cases "A \<subseteq> B \<or> B \<subseteq> A")
   case True thus ?thesis
     using A B psubset_finite_imp_set_less_aux[of A B] psubset_finite_imp_set_less_aux[of B A]
     by auto
 next
   case False
   hence A': "\<not> A \<subseteq> B" and B': "\<not> B \<subseteq> A" and AnB: "A \<noteq> B" by auto
   thus ?thesis using A B
   proof(induct "Min (B - A)" "Min (A - B)" arbitrary: A B rule: wlog_le)
     case (sym m n)
     from sym.hyps[OF refl refl] sym.prems show ?case by blast
   next
     case (le A B)
     note A = \<open>finite A\<close> and B = \<open>finite B\<close>
       and A' = \<open>\<not> A \<subseteq> B\<close> and B' = \<open>\<not> B \<subseteq> A\<close>
     { fix z
       assume z: "z \<in> (A - B) \<union> (B - A)"
       hence "Min (B - A) \<le> z \<and> (z \<le> Min (B - A) \<longrightarrow> Min (B - A) = z)"
       proof
         assume "z \<in> B - A" 
         hence "Min (B - A) \<le> z" by(simp add: B)
         thus ?thesis by auto
       next
         assume "z \<in> A - B"
         hence "Min (A - B) \<le> z" by(simp add: A)
         with le.hyps show ?thesis by(auto)
       qed }
     moreover have "Min (B - A) \<in> B - A" by(rule Min_in)(simp_all add: B B')
     ultimately have "A \<sqsubset>' B" using A B by(auto simp add: set_less_aux_def)
     thus ?case ..
   qed
 qed
 
 lemma set_less_eq_aux_finite_total:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B \<or> A = B \<or> B \<sqsubseteq>' A"
 by(drule (1) set_less_aux_finite_total)(auto simp add: set_less_eq_aux_def)
 
 lemma set_less_eq_aux_finite_total2:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B \<or> B \<sqsubseteq>' A"
 by(drule (1) set_less_eq_aux_finite_total)(auto simp add: finite_complement_partition)
 
 lemma set_less_aux_rec:
   assumes A: "finite A" and B: "finite B"
   and A': "A \<noteq> {}" and B': "B \<noteq> {}"
   shows "A \<sqsubset>' B \<longleftrightarrow> Min B < Min A \<or> Min A = Min B \<and> A - {Min A} \<sqsubset>' B - {Min A}"
 proof(cases "Min A = Min B")
   case True
   from A A' B B' have "insert (Min A) A = A" "insert (Min B) B = B"
     by(auto simp add: ex_in_conv[symmetric] exI)
   with True show ?thesis
     by(subst (2) set_less_aux_insert_same[symmetric, where x="Min A"]) simp_all
 next
   case False
   have "A \<sqsubset>' B \<longleftrightarrow> Min B < Min A"
   proof
     assume AB: "A \<sqsubset>' B"
     with B A obtain ab where ab: "ab \<in> B - A"
       and AB: "\<And>x. \<lbrakk> x \<in> A; x \<notin> B \<rbrakk> \<Longrightarrow> ab \<le> x"
       by(auto simp add: set_less_aux_def)
     { fix a assume "a \<in> A"
       hence "Min B \<le> a" using A A' B B' ab
         by(cases "a \<in> B")(auto intro: order_trans[where y=ab] dest: AB) }
     hence "Min B \<le> Min A" using A A' by simp
     with False show "Min B < Min A" using False by auto
   next
     assume "Min B < Min A"
     hence "\<forall>z\<in>A - B \<union> (B - A). Min B \<le> z \<and> (z \<le> Min B \<longrightarrow> Min B = z)"
       using A B A' B' by(auto 4 4 intro: Min_in Min_eqI dest: bspec bspec[where x="Min B"])
     moreover have "Min B \<notin> A" using \<open>Min B < Min A\<close> by (metis A Min_le not_less)
     ultimately show "A \<sqsubset>' B" using A B A' B' by(simp add: set_less_aux_def bexI[where x="Min B"])
   qed
   thus ?thesis using False by simp
 qed
 
 lemma set_less_eq_aux_rec:
   assumes "finite A" "finite B" "A \<noteq> {}" "B \<noteq> {}"
   shows "A \<sqsubseteq>' B \<longleftrightarrow> Min B < Min A \<or> Min A = Min B \<and> A - {Min A} \<sqsubseteq>' B - {Min A}"
 proof(cases "A = B")
   case True thus ?thesis using assms by(simp add: finite_complement_partition)
 next
   case False
   moreover 
   hence "Min A = Min B \<Longrightarrow> A - {Min A} \<noteq> B - {Min B}"
     by (metis (lifting) assms Min_in insert_Diff)
   ultimately show ?thesis using set_less_aux_rec[OF assms]
     by(simp add: set_less_eq_aux_def cong: conj_cong)
 qed
 
 lemma set_less_aux_Min_antimono:
   "\<lbrakk> Min A < Min B;  finite A; finite B; A \<noteq> {} \<rbrakk> \<Longrightarrow> B \<sqsubset>' A"
 using set_less_aux_rec[of B A] 
 by(cases "B = {}")(simp_all add: empty_set_less_aux_finite_iff)
 
 lemma sorted_Cons_Min: "sorted (x # xs) \<Longrightarrow> Min (insert x (set xs)) = x"
   by(auto simp add: intro: Min_eqI)
 
 lemma set_less_aux_code:
   "\<lbrakk> sorted xs; distinct xs; sorted ys; distinct ys \<rbrakk>
   \<Longrightarrow> set xs \<sqsubset>' set ys \<longleftrightarrow> ord.lexordp (>) xs ys"
   apply(induct xs ys rule: list_induct2')
      apply(simp_all add: empty_set_less_aux_finite_iff sorted_Cons_Min set_less_aux_rec neq_Nil_conv)
   apply(auto cong: conj_cong)
   done
 
 lemma set_less_eq_aux_code:
   assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys"
   shows "set xs \<sqsubseteq>' set ys \<longleftrightarrow> ord.lexordp_eq (>) xs ys"
 proof -
   have dual: "class.linorder (\<ge>) (>)"
     by(rule linorder.dual_linorder) unfold_locales
   from assms show ?thesis
     by(auto simp add: set_less_eq_aux_def finite_complement_partition linorder.lexordp_eq_conv_lexord[OF dual] set_less_aux_code intro: sorted_distinct_set_unique)
 qed
 
 end
 
 subsubsection \<open>Extending @{term set_less_eq_aux} to have @{term "{}"} as least element\<close>
 
 context ord begin
 
 definition set_less_eq_aux' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''''" 50)
 where "A \<sqsubseteq>'' B \<longleftrightarrow> A \<sqsubseteq>' B \<or> A = {} \<and> B \<in> infinite_complement_partition"
 
 lemma set_less_eq_aux'_refl:
   "A \<sqsubseteq>'' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def)
 
 lemma set_less_eq_aux'_antisym: "\<lbrakk> A \<sqsubseteq>'' B; B \<sqsubseteq>'' A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_aux'_def intro: set_less_eq_aux_antisym del: equalityI)
 
 lemma set_less_eq_aux'_infinite_complement_partitionD:
   "A \<sqsubseteq>'' B \<Longrightarrow> A \<in> infinite_complement_partition \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def intro: finite_complement_partition dest: set_less_eq_aux_infinite_complement_partitionD)
 
 lemma empty_set_less_eq_def [simp]: "{} \<sqsubseteq>'' B \<longleftrightarrow> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def dest: set_less_eq_aux_infinite_complement_partitionD)
 
 end
 
 context linorder begin
 
 lemma set_less_eq_aux'_trans: "\<lbrakk> A \<sqsubseteq>'' B; B \<sqsubseteq>'' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>'' C"
 by(auto simp add: set_less_eq_aux'_def del: equalityI intro: set_less_eq_aux_trans dest: set_less_eq_aux_infinite_complement_partitionD)
 
 lemma set_less_eq_aux'_porder: "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>'' B}"
 by(auto simp add: partial_order_on_def preorder_on_def intro!: refl_onI transI antisymI dest: set_less_eq_aux'_antisym set_less_eq_aux'_infinite_complement_partitionD simp add: set_less_eq_aux'_refl intro: set_less_eq_aux'_trans)
 
 end
 
 subsubsection \<open>Extend @{term set_less_eq_aux'} to a total order on @{term infinite_complement_partition}\<close>
 
 context ord begin
 
 definition set_less_eq_aux'' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''''''" 50)
 where "set_less_eq_aux'' =
   (SOME sleq. 
     (linear_order_on UNIV {(a, b). a \<le> b} \<longrightarrow> linear_order_on infinite_complement_partition {(A, B). sleq A B}) \<and> order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). sleq A B})"
 
 lemma set_less_eq_aux''_spec:
   shows "linear_order {(a, b). a \<le> b} \<Longrightarrow> linear_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>''' B}"
   (is "PROP ?thesis1")
   and "order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). A \<sqsubseteq>''' B}" (is ?thesis2)
 proof -
   let ?P = "\<lambda>sleq. (linear_order {(a, b). a \<le> b} \<longrightarrow> linear_order_on infinite_complement_partition {(A, B). sleq A B}) \<and> 
                   order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). sleq A B}"
   have "Ex ?P"
   proof(cases "linear_order {(a, b). a \<le> b}")
     case False
     have "antisym {(a, b). a \<sqsubseteq>'' b}"
       by (rule antisymI) (simp add: set_less_eq_aux'_antisym)
     then show ?thesis using False
       by (auto intro: antisym_order_consistent_self)
   next
     case True
     hence "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>'' B}"
       by(rule linorder.set_less_eq_aux'_porder[OF linear_order_imp_linorder])
     then obtain s where "linear_order_on infinite_complement_partition s"
       and "order_consistent {(A, B). A \<sqsubseteq>'' B} s" by(rule porder_extend_to_linorder)
     thus ?thesis by(auto intro: exI[where x="\<lambda>A B. (A, B) \<in> s"])
   qed
   hence "?P (Eps ?P)" by(rule someI_ex)
   thus "PROP ?thesis1" ?thesis2 by(simp_all add: set_less_eq_aux''_def)
 qed
 
 end
 
 context linorder begin
 
 lemma set_less_eq_aux''_linear_order:
   "linear_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>''' B}"
 by(rule set_less_eq_aux''_spec)(rule linear_order)
 
 lemma set_less_eq_aux''_refl [iff]: "A \<sqsubseteq>''' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: refl_onD refl_onD1)
 
 lemma set_less_eq_aux'_into_set_less_eq_aux'':
   assumes "A \<sqsubseteq>'' B" 
   shows "A \<sqsubseteq>''' B"
 proof(rule ccontr)
   assume nleq: "\<not> ?thesis"
   moreover from assms have A: "A \<in> infinite_complement_partition" 
     and B: "B \<in> infinite_complement_partition"
     by(auto dest: set_less_eq_aux'_infinite_complement_partitionD)
   with set_less_eq_aux''_linear_order have "A \<sqsubseteq>''' B \<or> A = B \<or> B \<sqsubseteq>''' A"
     by(auto simp add: linear_order_on_def dest: total_onD)
   ultimately have "B \<sqsubseteq>''' A" using B by auto
   with assms have "A = B" using set_less_eq_aux''_spec(2)
     by(simp add: order_consistent_def)
   with A nleq show False by simp
 qed
 
 lemma finite_set_less_eq_aux''_finite:
   assumes "finite A" and "finite B"
   shows "A \<sqsubseteq>''' B \<longleftrightarrow> A \<sqsubseteq>'' B"
 proof
   assume "A \<sqsubseteq>''' B"
   from assms have "A \<sqsubseteq>' B \<or> B \<sqsubseteq>' A" by(rule set_less_eq_aux_finite_total2)
   hence "A \<sqsubseteq>'' B \<or> B \<sqsubseteq>'' A" by(auto simp add: set_less_eq_aux'_def)
   thus "A \<sqsubseteq>'' B"
   proof
     assume "B \<sqsubseteq>'' A"
     hence "B \<sqsubseteq>''' A" by(rule set_less_eq_aux'_into_set_less_eq_aux'')
     with \<open>A \<sqsubseteq>''' B\<close> set_less_eq_aux''_linear_order have "A = B"
       by(auto simp add: linear_order_on_def partial_order_on_def dest: antisymD)
     thus ?thesis using assms by(simp add: finite_complement_partition set_less_eq_aux'_def)
   qed
 qed(rule set_less_eq_aux'_into_set_less_eq_aux'')
 
 lemma set_less_eq_aux''_finite:
   "finite (UNIV :: 'a set) \<Longrightarrow> set_less_eq_aux'' = set_less_eq_aux"
 by(auto simp add: fun_eq_iff finite_set_less_eq_aux''_finite set_less_eq_aux'_def finite_subset[OF subset_UNIV])
 
 lemma set_less_eq_aux''_antisym:
   "\<lbrakk> A \<sqsubseteq>''' B; B \<sqsubseteq>''' A; 
      A \<in> infinite_complement_partition; B \<in> infinite_complement_partition \<rbrakk>
   \<Longrightarrow> A = B"
 using set_less_eq_aux''_linear_order 
 by(auto simp add: linear_order_on_def partial_order_on_def dest: antisymD del: equalityI)
 
 lemma set_less_eq_aux''_trans: "\<lbrakk> A \<sqsubseteq>''' B; B \<sqsubseteq>''' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>''' C"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: transD)
 
 lemma set_less_eq_aux''_total:
   "\<lbrakk> A \<in> infinite_complement_partition; B \<in> infinite_complement_partition \<rbrakk>
   \<Longrightarrow> A \<sqsubseteq>''' B \<or> B \<sqsubseteq>''' A"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def dest: total_onD)
 
 end
 
 subsubsection \<open>Extend @{term set_less_eq_aux''} to cofinite sets\<close>
 
 context ord begin
 
 definition set_less_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
 where 
   "A \<sqsubseteq> B \<longleftrightarrow> 
   (if A \<in> infinite_complement_partition then A \<sqsubseteq>''' B \<or> B \<notin> infinite_complement_partition
    else B \<notin> infinite_complement_partition \<and> - B \<sqsubseteq>''' - A)"
 
 definition set_less :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubset>" 50)
 where "A \<sqsubset> B \<longleftrightarrow> A \<sqsubseteq> B \<and> \<not> B \<sqsubseteq> A"
 
 lemma set_less_eq_def2:
   "A \<sqsubseteq> B \<longleftrightarrow>
   (if finite (UNIV :: 'a set) then A \<sqsubseteq>''' B 
    else if A \<in> infinite_complement_partition then A \<sqsubseteq>''' B \<or> B \<notin> infinite_complement_partition
    else B \<notin> infinite_complement_partition \<and> - B \<sqsubseteq>''' - A)"
 by(simp add: set_less_eq_def)
 
 end
 
 context linorder begin
 
 lemma set_less_eq_refl [iff]: "A \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 not_in_complement_partition)
 
 lemma set_less_eq_antisym: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_def2 set_less_eq_aux''_finite not_in_complement_partition not_in_complement_partition_False del: equalityI split: if_split_asm dest: set_less_eq_aux_antisym set_less_eq_aux''_antisym)
 
 lemma set_less_eq_trans: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> C \<rbrakk> \<Longrightarrow> A \<sqsubseteq> C"
 by(auto simp add: set_less_eq_def split: if_split_asm intro: set_less_eq_aux''_trans)
 
 lemma set_less_eq_total: "A \<sqsubseteq> B \<or> B \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 set_less_eq_aux''_finite not_in_complement_partition not_in_complement_partition_False intro: set_less_eq_aux_finite_total2 finite_subset[OF subset_UNIV] del: disjCI dest: set_less_eq_aux''_total)
 
 lemma set_less_eq_linorder: "class.linorder (\<sqsubseteq>) (\<sqsubset>)"
 by(unfold_locales)(auto simp add: set_less_def set_less_eq_antisym set_less_eq_total intro: set_less_eq_trans)
 
 lemma set_less_eq_conv_set_less: "set_less_eq A B \<longleftrightarrow> A = B \<or> set_less A B"
 by(auto simp add: set_less_def del: equalityI dest: set_less_eq_antisym)
 
 lemma Compl_set_less_eq_Compl: "- A \<sqsubseteq> - B \<longleftrightarrow> B \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 not_in_complement_partition_False not_in_complement_partition set_less_eq_aux''_finite Compl_set_less_eq_aux_Compl)
 
 lemma Compl_set_less_Compl: "- A \<sqsubset> - B \<longleftrightarrow> B \<sqsubset> A"
 by(simp add: set_less_def Compl_set_less_eq_Compl)
 
 lemma set_less_eq_finite_iff: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq> B \<longleftrightarrow> A \<sqsubseteq>' B"
 by(auto simp add: set_less_eq_def finite_complement_partition set_less_eq_aux'_def finite_set_less_eq_aux''_finite)
 
 lemma set_less_finite_iff: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubset> B \<longleftrightarrow> A \<sqsubset>' B"
 by(simp add: set_less_def set_less_aux_conv_set_less_eq_aux set_less_eq_finite_iff)
 
 lemma infinite_set_less_eq_Complement:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> A \<sqsubseteq> - B"
 by(simp add: set_less_eq_def finite_complement_partition not_in_complement_partition)
 
 lemma infinite_set_less_Complement:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> A \<sqsubset> - B"
 by(auto simp add: set_less_def dest: set_less_eq_antisym intro: infinite_set_less_eq_Complement)
 
 lemma infinite_Complement_set_less_eq:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> \<not> - A \<sqsubseteq> B"
 using infinite_set_less_eq_Complement[of A B] Compl_set_less_eq_Compl[of A "- B"]
 by(auto dest: set_less_eq_antisym)
 
 lemma infinite_Complement_set_less:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> \<not> - A \<sqsubset> B"
 using infinite_Complement_set_less_eq[of A B]
 by(simp add: set_less_def)
 
 lemma empty_set_less_eq [iff]: "{} \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def finite_complement_partition intro: set_less_eq_aux'_into_set_less_eq_aux'')
 
 lemma set_less_eq_empty [iff]: "A \<sqsubseteq> {} \<longleftrightarrow> A = {}"
 by (metis empty_set_less_eq set_less_eq_antisym)
 
 lemma empty_set_less_iff [iff]: "{} \<sqsubset> A \<longleftrightarrow> A \<noteq> {}"
 by(simp add: set_less_def)
 
 lemma not_set_less_empty [simp]: "\<not> A \<sqsubset> {}"
 by(simp add: set_less_def)
 
 lemma set_less_eq_UNIV [iff]: "A \<sqsubseteq> UNIV"
 using Compl_set_less_eq_Compl[of "- A" "{}"] by simp
 
 lemma UNIV_set_less_eq [iff]: "UNIV \<sqsubseteq> A \<longleftrightarrow> A = UNIV"
 using Compl_set_less_eq_Compl[of "{}" "- A"]
 by(simp add: Compl_eq_empty_iff)
 
 lemma set_less_UNIV_iff [iff]: "A \<sqsubset> UNIV \<longleftrightarrow> A \<noteq> UNIV"
 by(simp add: set_less_def)
 
 lemma not_UNIV_set_less [simp]: "\<not> UNIV \<sqsubset> A"
 by(simp add: set_less_def)
 
 end
 
 subsection \<open>Implementation based on sorted lists\<close>
 
 type_synonym 'a proper_interval = "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
 
 class proper_intrvl = ord +
   fixes proper_interval :: "'a proper_interval"
 
 class proper_interval = proper_intrvl +
   assumes proper_interval_simps:
   "proper_interval None None = True"
   "proper_interval None (Some y) = (\<exists>z. z < y)"
   "proper_interval (Some x) None = (\<exists>z. x < z)"
   "proper_interval (Some x) (Some y) = (\<exists>z. x < z \<and> z < y)"
 
 context proper_intrvl begin
 
 function set_less_eq_aux_Compl :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "set_less_eq_aux_Compl ao [] ys \<longleftrightarrow> True"
 | "set_less_eq_aux_Compl ao xs [] \<longleftrightarrow> True"
 | "set_less_eq_aux_Compl ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then proper_interval ao (Some x) \<or> set_less_eq_aux_Compl (Some x) xs (y # ys)
    else if y < x then proper_interval ao (Some y) \<or> set_less_eq_aux_Compl (Some y) (x # xs) ys
    else proper_interval ao (Some y))"
 by(pat_completeness) simp_all
 termination by(lexicographic_order)
 
 fun Compl_set_less_eq_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "Compl_set_less_eq_aux ao [] [] \<longleftrightarrow> \<not> proper_interval ao None"
 | "Compl_set_less_eq_aux ao [] (y # ys) \<longleftrightarrow> \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux (Some y) [] ys"
 | "Compl_set_less_eq_aux ao (x # xs) [] \<longleftrightarrow> \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux (Some x) xs []"
 | "Compl_set_less_eq_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux (Some x) xs (y # ys)
    else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some y))"
 
 fun set_less_aux_Compl :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "set_less_aux_Compl ao [] [] \<longleftrightarrow> proper_interval ao None"
 | "set_less_aux_Compl ao [] (y # ys) \<longleftrightarrow> proper_interval ao (Some y) \<or> set_less_aux_Compl (Some y) [] ys"
 | "set_less_aux_Compl ao (x # xs) [] \<longleftrightarrow> proper_interval ao (Some x) \<or> set_less_aux_Compl (Some x) xs []"
 | "set_less_aux_Compl ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then proper_interval ao (Some x) \<or> set_less_aux_Compl (Some x) xs (y # ys)
    else if y < x then proper_interval ao (Some y) \<or> set_less_aux_Compl (Some y) (x # xs) ys
    else proper_interval ao (Some y))"
 
 function Compl_set_less_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "Compl_set_less_aux ao [] ys \<longleftrightarrow> False"
 | "Compl_set_less_aux ao xs [] \<longleftrightarrow> False"
 | "Compl_set_less_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_aux (Some x) xs (y # ys)
    else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some y))"
 by pat_completeness simp_all
 termination by lexicographic_order
 
 end
 
 lemmas [code] =
   proper_intrvl.set_less_eq_aux_Compl.simps
   proper_intrvl.set_less_aux_Compl.simps
   proper_intrvl.Compl_set_less_eq_aux.simps
   proper_intrvl.Compl_set_less_aux.simps
 
 class linorder_proper_interval = linorder + proper_interval 
 begin
 
 theorem assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs"
   and ys: "sorted ys" "distinct ys"
   shows set_less_eq_aux_Compl2_conv_set_less_eq_aux_Compl:
   "set xs \<sqsubseteq>' - set ys \<longleftrightarrow> set_less_eq_aux_Compl None xs ys" (is ?Compl2)
   and Compl1_set_less_eq_aux_conv_Compl_set_less_eq_aux:
   "- set xs \<sqsubseteq>' set ys \<longleftrightarrow> Compl_set_less_eq_aux None xs ys" (is ?Compl1)
 proof -
   note fin' [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     and proper_interval_None2: "\<And>ao. proper_interval ao None \<longleftrightarrow> above ao \<noteq> {}"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao x A B
     assume ex: "proper_interval ao (Some x)"
       and A: "\<forall>a \<in> A. x \<le> a"
       and B: "\<forall>b \<in> B. x \<le> b"
     from ex obtain z where z_ao: "z \<in> above ao" and z: "z < x"
       by(auto simp add: proper_interval_Some2)
     with A have A_eq: "A \<inter> above ao = A"
       by(auto simp add: above_upclosed)
     from z_ao z B have B_eq: "B \<inter> above ao = B"
       by(auto simp add: above_upclosed)
     define w where "w = Min (above ao)"
     with z_ao have "w \<le> z" "\<forall>z \<in> above ao. w \<le> z" "w \<in> above ao"
       by(auto simp add: Min_le_iff intro: Min_in)
     hence "A \<inter> above ao \<sqsubset>' (- B) \<inter> above ao" (is "?lhs \<sqsubset>' ?rhs")
       using A B z by(auto simp add: set_less_aux_def intro!: bexI[where x="w"])
     hence "A \<sqsubseteq>' ?rhs" unfolding A_eq by(simp add: set_less_eq_aux_def)
     moreover 
     from z_ao z A B have "z \<in> - A \<inter> above ao" "z \<notin> B" by auto
     hence neq: "- A \<inter> above ao \<noteq> B \<inter> above ao" by auto
     have "\<not> - A \<inter> above ao \<sqsubset>' B \<inter> above ao" (is "\<not> ?lhs' \<sqsubset>' ?rhs'")
       using A B z z_ao by(force simp add: set_less_aux_def not_less dest: bspec[where x=z])
     with neq have "\<not> ?lhs' \<sqsubseteq>' B" unfolding B_eq by(auto simp add: set_less_eq_aux_def)
     moreover note calculation }
   note proper_interval_set_less_eqI = this(1)
     and proper_interval_not_set_less_eq_auxI = this(2)
 
   { fix ao
     assume "set xs \<union> set ys \<subseteq> above ao"
     with xs ys
     have "set_less_eq_aux_Compl ao xs ys \<longleftrightarrow> set xs \<sqsubseteq>' (- set ys) \<inter> above ao"
     proof(induction ao xs ys rule: set_less_eq_aux_Compl.induct)
       case 1 thus ?case by simp
     next
       case 2 thus ?case by(auto intro: subset_finite_imp_set_less_eq_aux)
     next
       case (3 ao x xs y ys)
       note ao = \<open>set (x # xs) \<union> set (y # ys) \<subseteq> above ao\<close>
       hence x_ao: "x \<in> above ao" and y_ao: "y \<in> above ao" by simp_all
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y' \<in> set ys. y < y'"
         by(auto simp add: less_le)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x' \<in> set xs. x < x'"
         by(auto simp add: less_le)
       let ?lhs = "set (x # xs)" and ?rhs = "- set (y # ys) \<inter> above ao"
       show ?case
       proof(cases "x < y")
         case True
         show ?thesis
         proof(cases "proper_interval ao (Some x)")
           case True
           hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x < y\<close>
             by(auto intro!: proper_interval_set_less_eqI)
           with True show ?thesis using \<open>x < y\<close> by simp
         next
           case False
           have "set xs \<union> set (y # ys) \<subseteq> above (Some x)" using True x_Min y_Min by auto
           with True xs yys
           have IH: "set_less_eq_aux_Compl (Some x) xs (y # ys) = 
             (set xs \<sqsubseteq>' - set (y # ys) \<inter> above (Some x))"
             by(rule "3.IH")
           from True y_Min x_ao have "x \<in> - set (y # ys) \<inter> above ao" by auto
           hence "?rhs \<noteq> {}" by blast
           moreover have "Min ?lhs = x" using x_Min x_ao by(auto intro!: Min_eqI)
           moreover have "Min ?rhs = x" using \<open>x < y\<close> y_Min x_ao False
             by(auto intro!: Min_eqI simp add: proper_interval_Some2)
           moreover have "set xs = set xs - {x}"
             using ao x_Min by auto
           moreover have "- set (y # ys) \<inter> above (Some x) = - set (y # ys) \<inter> above ao - {x}"
             using False x_ao by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           ultimately show ?thesis using True False IH
             by(simp del: set_simps)(subst (2) set_less_eq_aux_rec, simp_all add: x_ao)
         qed
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis
           proof(cases "proper_interval ao (Some y)")
             case True
             hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>\<not> x < y\<close>
               by(auto intro!: proper_interval_set_less_eqI)
             with True show ?thesis using \<open>\<not> x < y\<close> by simp
           next
             case False
             have "set (x # xs) \<union> set ys \<subseteq> above (Some y)"
               using \<open>y < x\<close> x_Min y_Min by auto
             with \<open>\<not> x < y\<close> \<open>y < x\<close> xxs ys
             have IH: "set_less_eq_aux_Compl (Some y) (x # xs) ys = 
               (set (x # xs) \<sqsubseteq>' - set ys \<inter> above (Some y))"
               by(rule "3.IH")
             moreover have "- set ys \<inter> above (Some y) = ?rhs"
               using y_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
             ultimately show ?thesis using \<open>\<not> x < y\<close> True False by simp
           qed
         next
           case False with \<open>\<not> x < y\<close> have "x = y" by auto
           { assume "proper_interval ao (Some y)"
             hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x = y\<close>
               by(auto intro!: proper_interval_set_less_eqI) }
           moreover
           { assume "?lhs \<sqsubseteq>' ?rhs"
             moreover have "?lhs \<noteq> ?rhs"
             proof
               assume eq: "?lhs = ?rhs"
               have "x \<in> ?lhs" using x_ao by simp
               also note eq also note \<open>x = y\<close>
               finally show False by simp
             qed
             ultimately obtain z where "z \<in> above ao" "z < y" using \<open>x = y\<close> y_ao
               by(fastforce simp add: set_less_eq_aux_def set_less_aux_def not_le dest!: bspec[where x=y])
             hence "proper_interval ao (Some y)" by(auto simp add: proper_interval_Some2) }
           ultimately show ?thesis using \<open>x = y\<close> \<open>\<not> x < y\<close> \<open>\<not> y < x\<close> by auto
         qed
       qed
     qed }
   from this[of None] show ?Compl2 by simp
   
   { fix ao
     assume "set xs \<union> set ys \<subseteq> above ao"
     with xs ys
     have "Compl_set_less_eq_aux ao xs ys \<longleftrightarrow> (- set xs) \<inter> above ao \<sqsubseteq>' set ys"
     proof(induction ao xs ys rule: Compl_set_less_eq_aux.induct)
       case 1 thus ?case by(simp add: proper_interval_None2)
     next
       case (2 ao y ys)
       from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       have ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y' \<in> set ys. y < y'"
         by(auto simp add: less_le)
       show ?case
       proof(cases "proper_interval ao (Some y)")
         case True 
         hence "\<not> - set [] \<inter> above ao \<sqsubseteq>' set (y # ys)" using y_Min
           by -(erule proper_interval_not_set_less_eq_auxI, auto)
         thus ?thesis using True by simp
       next
         case False
         note ao = \<open>set [] \<union> set (y # ys) \<subseteq> above ao\<close> 
         hence y_ao: "y \<in> above ao" by simp
         from ao y_Min have "set [] \<union> set ys \<subseteq> above (Some y)" by auto
         with \<open>sorted []\<close> \<open>distinct []\<close> ys
         have "Compl_set_less_eq_aux (Some y) [] ys \<longleftrightarrow> - set [] \<inter> above (Some y) \<sqsubseteq>' set ys"
           by(rule "2.IH")
         moreover have "above ao \<noteq> {}" using y_ao by auto
         moreover have "Min (above ao) = y" 
           and "Min (set (y # ys)) = y"
           using y_ao False ao by(auto intro!: Min_eqI simp add: proper_interval_Some2 not_less)
         moreover have "above ao - {y} = above (Some y)" using False y_ao
           by(auto simp add: proper_interval_Some2 intro: above_upclosed)
         moreover have "set ys - {y} = set ys" 
           using y_Min y_ao by(auto)
         ultimately show ?thesis using False y_ao
           by(simp)(subst (2) set_less_eq_aux_rec, simp_all)
       qed
     next
       case (3 ao x xs)
       from \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       have xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       show ?case
       proof(cases "proper_interval ao (Some x)")
         case True
         then obtain z where "z \<in> above ao" "z < x" by(auto simp add: proper_interval_Some2)
         hence "z \<in> - set (x # xs) \<inter> above ao" using x_Min by auto
         thus ?thesis using True by auto
       next
         case False
         note ao = \<open>set (x # xs) \<union> set [] \<subseteq> above ao\<close>
         hence x_ao: "x \<in> above ao" by simp
         from ao have "set xs \<union> set [] \<subseteq> above (Some x)" using x_Min by auto
         with xs \<open>sorted []\<close> \<open>distinct []\<close> 
         have "Compl_set_less_eq_aux (Some x) xs [] \<longleftrightarrow>
           - set xs \<inter> above (Some x) \<sqsubseteq>' set []"
           by(rule "3.IH")
         moreover have "- set (x # xs) \<inter> above ao = - set xs \<inter> above (Some x)" 
           using False x_ao by(auto simp add: proper_interval_Some2 intro: above_upclosed)
         ultimately show ?thesis using False by simp
       qed
     next
       case (4 ao x xs y ys)
       note ao = \<open>set (x # xs) \<union> set (y # ys) \<subseteq> above ao\<close>
       hence x_ao: "x \<in> above ao" and y_ao: "y \<in> above ao" by simp_all
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
       let ?lhs = "- set (x # xs) \<inter> above ao" and ?rhs = "set (y # ys)"
       show ?case
       proof(cases "x < y")
         case True
         show ?thesis
         proof(cases "proper_interval ao (Some x)")
           case True
           hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x < y\<close>
             by -(erule proper_interval_not_set_less_eq_auxI, auto)
           thus ?thesis using True \<open>x < y\<close> by simp
         next
           case False
           have "set xs \<union> set (y # ys) \<subseteq> above (Some x)" 
             using ao x_Min y_Min True by auto
           with True xs yys
           have "Compl_set_less_eq_aux (Some x) xs (y # ys) \<longleftrightarrow> 
             - set xs \<inter> above (Some x) \<sqsubseteq>' set (y # ys)"
             by(rule "4.IH")
           moreover have "- set xs \<inter> above (Some x) = ?lhs"
             using x_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
           ultimately show ?thesis using False True by simp
         qed
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis
           proof(cases "proper_interval ao (Some y)")
             case True
             hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>y < x\<close>
               by -(erule proper_interval_not_set_less_eq_auxI, auto)
             thus ?thesis using True \<open>y < x\<close> \<open>\<not> x < y\<close> by simp
           next
             case False
             from ao True x_Min y_Min 
             have "set (x # xs) \<union> set ys \<subseteq> above (Some y)" by auto
             with \<open>\<not> x < y\<close> True xxs ys
             have "Compl_set_less_eq_aux (Some y) (x # xs) ys \<longleftrightarrow>
               - set (x # xs) \<inter> above (Some y) \<sqsubseteq>' set ys"
               by(rule "4.IH")
             moreover have "y \<in> ?lhs" using True x_Min y_ao by auto
             hence "?lhs \<noteq> {}" by auto
             moreover have "Min ?lhs = y" using True False x_Min y_ao
               by(auto intro!: Min_eqI simp add: not_le not_less proper_interval_Some2)
             moreover have "Min ?rhs = y" using y_Min y_ao by(auto intro!: Min_eqI)
             moreover have "- set (x # xs) \<inter> above (Some y) = ?lhs - {y}"
               using y_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
             moreover have "set ys = set ys - {y}"
               using y_ao y_Min by(auto intro: above_upclosed)
             ultimately show ?thesis using True False \<open>\<not> x < y\<close> y_ao
               by(simp)(subst (2) set_less_eq_aux_rec, simp_all)
           qed
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by auto
           { assume "proper_interval ao (Some y)"
             hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x = y\<close>
               by -(erule proper_interval_not_set_less_eq_auxI, auto) }
           moreover
           { assume "\<not> ?lhs \<sqsubseteq>' ?rhs"
             also have "?rhs = set (y # ys) \<inter> above ao"
               using ao by auto
             finally obtain z where "z \<in> above ao" "z < y" 
               using \<open>x = y\<close> x_ao x_Min[unfolded Ball_def]
               by(fastforce simp add: set_less_eq_aux_def set_less_aux_def simp add: less_le not_le dest!: bspec[where x=y])
             hence "proper_interval ao (Some y)" 
               by(auto simp add: proper_interval_Some2) }
           ultimately show ?thesis using \<open>x = y\<close> by auto
         qed
       qed
     qed }
   from this[of None] show ?Compl1 by simp
 qed
 
 lemma set_less_aux_Compl_iff:
   "set_less_aux_Compl ao xs ys \<longleftrightarrow> set_less_eq_aux_Compl ao xs ys \<and> \<not> Compl_set_less_eq_aux ao ys xs"
 by(induct ao xs ys rule: set_less_aux_Compl.induct)(auto simp add: not_less_iff_gr_or_eq)
 
 lemma Compl_set_less_aux_Compl_iff:
   "Compl_set_less_aux ao xs ys \<longleftrightarrow> Compl_set_less_eq_aux ao xs ys \<and> \<not> set_less_eq_aux_Compl ao ys xs"
 by(induct ao xs ys rule: Compl_set_less_aux.induct)(auto simp add: not_less_iff_gr_or_eq)
 
 theorem assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs"
   and ys: "sorted ys" "distinct ys"
   shows set_less_aux_Compl2_conv_set_less_aux_Compl:
   "set xs \<sqsubset>' - set ys \<longleftrightarrow> set_less_aux_Compl None xs ys" (is ?Compl2)
   and Compl1_set_less_aux_conv_Compl_set_less_aux:
   "- set xs \<sqsubset>' set ys \<longleftrightarrow> Compl_set_less_aux None xs ys" (is ?Compl1)
 using assms
 by(simp_all only: set_less_aux_conv_set_less_eq_aux set_less_aux_Compl_iff Compl_set_less_aux_Compl_iff set_less_eq_aux_Compl2_conv_set_less_eq_aux_Compl Compl1_set_less_eq_aux_conv_Compl_set_less_eq_aux)
 
 end
 
 subsection \<open>Implementation of proper intervals for sets\<close>
 
 definition length_last :: "'a list \<Rightarrow> nat \<times> 'a"
 where "length_last xs = (length xs, last xs)"
 
 lemma length_last_Nil [code]: "length_last [] = (0, undefined)"
 by(simp add: length_last_def last_def)
 
 lemma length_last_Cons_code [symmetric, code]:
   "fold (\<lambda>x (n, _) . (n + 1, x)) xs (1, x) = length_last (x # xs)"
 by(induct xs rule: rev_induct)(simp_all add: length_last_def)
 
 context proper_intrvl begin
 
 fun exhaustive_above :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
   "exhaustive_above x [] \<longleftrightarrow> \<not> proper_interval (Some x) None"
 | "exhaustive_above x (y # ys) \<longleftrightarrow> \<not> proper_interval (Some x) (Some y) \<and> exhaustive_above y ys"
 
 fun exhaustive :: "'a list \<Rightarrow> bool" where 
   "exhaustive [] = False"
 | "exhaustive (x # xs) \<longleftrightarrow> \<not> proper_interval None (Some x) \<and> exhaustive_above x xs"
 
 fun proper_interval_set_aux :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_set_aux xs [] \<longleftrightarrow> False"
 | "proper_interval_set_aux [] (y # ys) \<longleftrightarrow> ys \<noteq> [] \<or> proper_interval (Some y) None"
 | "proper_interval_set_aux (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then False
    else if y < x then proper_interval (Some y) (Some x) \<or> ys \<noteq> [] \<or> \<not> exhaustive_above x xs
    else proper_interval_set_aux xs ys)"
 
 fun proper_interval_set_Compl_aux :: "'a option \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_set_Compl_aux ao n [] [] \<longleftrightarrow>
    CARD('a) > n + 1"
 | "proper_interval_set_Compl_aux ao n [] (y # ys) \<longleftrightarrow>
    (let m = CARD('a) - n; (len_y, y') = length_last (y # ys)
     in m \<noteq> len_y \<and> (m = len_y + 1 \<longrightarrow> \<not> proper_interval (Some y') None))"
 | "proper_interval_set_Compl_aux ao n (x # xs) [] \<longleftrightarrow>
    (let m = CARD('a) - n; (len_x, x') = length_last (x # xs)
     in m \<noteq> len_x \<and> (m = len_x + 1 \<longrightarrow> \<not> proper_interval (Some x') None))"
 | "proper_interval_set_Compl_aux ao n (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then 
      proper_interval ao (Some x) \<or> 
      proper_interval_set_Compl_aux (Some x) (n + 1) xs (y # ys)
    else if y < x then 
      proper_interval ao (Some y) \<or> 
      proper_interval_set_Compl_aux (Some y) (n + 1) (x # xs) ys
    else proper_interval ao (Some x) \<and> 
      (let m = card (UNIV :: 'a set) - n in m - length ys \<noteq> 2 \<or> m - length xs \<noteq> 2))"
 
 fun proper_interval_Compl_set_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_Compl_set_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then 
      \<not> proper_interval ao (Some x) \<and> 
      proper_interval_Compl_set_aux (Some x) xs (y # ys)
    else if y < x then
      \<not> proper_interval ao (Some y) \<and>
      proper_interval_Compl_set_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some x) \<and> (ys = [] \<longrightarrow> xs \<noteq> []))"
 | "proper_interval_Compl_set_aux ao _ _ \<longleftrightarrow> False"
 
 end
 
 lemmas [code] = 
   proper_intrvl.exhaustive_above.simps
   proper_intrvl.exhaustive.simps
   proper_intrvl.proper_interval_set_aux.simps
   proper_intrvl.proper_interval_set_Compl_aux.simps
   proper_intrvl.proper_interval_Compl_set_aux.simps
 
 context linorder_proper_interval begin
 
 lemma exhaustive_above_iff:
   "\<lbrakk> sorted xs; distinct xs; \<forall>x'\<in>set xs. x < x' \<rbrakk> \<Longrightarrow> exhaustive_above x xs \<longleftrightarrow> set xs = {z. z > x}"
 proof(induction x xs rule: exhaustive_above.induct)
   case 1 thus ?case by(simp add: proper_interval_simps)
 next
   case (2 x y ys)
   from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
   have ys: "sorted ys" "distinct ys" and y: "\<forall>y'\<in>set ys. y < y'"
     by(auto simp add: less_le)
   hence "exhaustive_above y ys = (set ys = {z. y < z})" by(rule "2.IH")
   moreover from \<open>\<forall>y'\<in>set (y # ys). x < y'\<close> have "x < y" by simp
   ultimately show ?case using y 
     by(fastforce simp add: proper_interval_simps)
 qed
 
 lemma exhaustive_correct:
   assumes "sorted xs" "distinct xs"
   shows "exhaustive xs \<longleftrightarrow> set xs = UNIV"
 proof(cases xs)
   case Nil thus ?thesis by auto
 next
   case Cons
   show ?thesis using assms unfolding Cons exhaustive.simps
     apply(subst exhaustive_above_iff)
        apply(auto simp add: less_le proper_interval_simps not_less intro: order_antisym)
     done
 qed
 
 theorem proper_interval_set_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys"
   shows "proper_interval_set_aux xs ys \<longleftrightarrow> (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
   show ?thesis using xs ys
   proof(induction xs ys rule: proper_interval_set_aux.induct)
     case 1 thus ?case by simp
   next
     case (2 y ys)
     hence "\<forall>y'\<in>set ys. y < y'" by(auto simp add: less_le)
     thus ?case
       by(cases ys)(auto simp add: proper_interval_simps set_less_aux_singleton_iff intro: psubset_finite_imp_set_less_aux)
   next
     case (3 x xs y ys)
     from \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
     have xs: "sorted xs" "distinct xs" and x: "\<forall>x'\<in>set xs. x < x'"
       by(auto simp add: less_le)
     from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
     have ys: "sorted ys" "distinct ys" and y: "\<forall>y'\<in>set ys. y < y'"
       by(auto simp add: less_le)
     have Minxxs: "Min (set (x # xs)) = x" and xnxs: "x \<notin> set xs"
       using x by(auto intro!: Min_eqI)
     have Minyys: "Min (set (y # ys)) = y" and ynys: "y \<notin> set ys" 
       using y by(auto intro!: Min_eqI)
     show ?case
     proof(cases "x < y")
       case True
       hence "set (y # ys) \<sqsubset>' set (x # xs)" using Minxxs Minyys
         by -(rule set_less_aux_Min_antimono, simp_all)
       thus ?thesis using True by(auto dest: set_less_aux_trans set_less_aux_antisym)
     next
       case False
       show ?thesis
       proof(cases "y < x")
         case True
         { assume "proper_interval (Some y) (Some x)"
           then obtain z where z: "y < z" "z < x" by(auto simp add: proper_interval_simps)
           hence "set (x # xs) \<sqsubset>' {z}" using x
             by -(rule set_less_aux_Min_antimono, auto)
           moreover have "{z} \<sqsubset>' set (y # ys)" using z y Minyys
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { assume "ys \<noteq> []"
           hence "{y} \<sqsubset>' set (y # ys)" using y
             by -(rule psubset_finite_imp_set_less_aux, auto simp add: neq_Nil_conv)
           moreover have "set (x # xs) \<sqsubset>' {y}" using False True x
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { assume "\<not> exhaustive_above x xs"
           then obtain z where z: "z > x" "z \<notin> set xs" using x
             by(auto simp add: exhaustive_above_iff[OF xs x])
           let ?A = "insert z (set (x # xs))"
           have "set (x # xs) \<sqsubset>' ?A" using z
             by -(rule psubset_finite_imp_set_less_aux, auto)
           moreover have "?A \<sqsubset>' set (y # ys)" using Minyys False True z x
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { fix A
           assume A: "set (x # xs) \<sqsubset>' A" and A': "A \<sqsubset>' {y}"
             and pi: "\<not> proper_interval (Some y) (Some x)"
           from A have nempty: "A \<noteq> {}" by auto
           have "y \<notin> A"
           proof
             assume "y \<in> A"
             moreover with A' have "A \<noteq> {y}" by auto
             ultimately have "{y} \<sqsubset>' A" by -(rule psubset_finite_imp_set_less_aux, auto)
             with A' show False by(rule set_less_aux_antisym)
           qed
           have "y < Min A" unfolding not_le[symmetric]
           proof
             assume "Min A \<le> y"
             moreover have "Min A \<noteq> y" using \<open>y \<notin> A\<close> nempty by clarsimp
             ultimately have "Min A < Min {y}" by simp
             hence "{y} \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' show False by(rule set_less_aux_antisym)
           qed
           with pi nempty have "x \<le> Min A" by(auto simp add: proper_interval_simps)
           moreover
           from A obtain z where z: "z \<in> A" "z \<notin> set (x # xs)"
             by(auto simp add: set_less_aux_def)
           with \<open>x \<le> Min A\<close> nempty have "x < z" by auto
           with z have "\<not> exhaustive_above x xs"
             by(auto simp add: exhaustive_above_iff[OF xs x]) }
         ultimately show ?thesis using True False by fastforce
       next
         case False
         with \<open>\<not> x < y\<close> have "x = y" by auto
         from \<open>\<not> x < y\<close> False
         have "proper_interval_set_aux xs ys = (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)" 
           using xs ys by(rule "3.IH")
         also have "\<dots> = (\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys))"
           (is "?lhs = ?rhs")
         proof
           assume ?lhs
           then obtain A where A: "set xs \<sqsubset>' A" 
             and A': "A \<sqsubset>' set ys" by blast
           hence nempty: "A \<noteq> {}" "ys \<noteq> []" by auto
           let ?A = "insert y A"
           { assume "Min A \<le> y"
             also from y nempty have "y < Min (set ys)" by auto
             finally have "set ys \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' have False by(rule set_less_aux_antisym) }
           hence MinA: "y < Min A" by(metis not_le)
           with nempty have "y \<notin> A" by auto
           moreover
           with MinA nempty have MinyA: "Min ?A = y" by -(rule Min_eqI, auto)
           ultimately have A1: "set (x # xs) \<sqsubset>' ?A" using \<open>x = y\<close> A Minxxs xnxs
             by(subst set_less_aux_rec) simp_all
           moreover
           have "?A \<sqsubset>' set (y # ys)" using \<open>x = y\<close> MinyA \<open>y \<notin> A\<close> A' Minyys ynys
             by(subst set_less_aux_rec) simp_all
           ultimately show ?rhs by blast
         next
           assume "?rhs"
           then obtain A where A: "set (x # xs) \<sqsubset>' A"
             and A': "A \<sqsubset>' set (y # ys)" by blast
           let ?A = "A - {x}"
           from A have nempty: "A \<noteq> {}" by auto
           { assume "x < Min A"
             hence "Min (set (x # xs)) < Min A" unfolding Minxxs .
             hence "A \<sqsubset>' set (x # xs)"
               by(rule set_less_aux_Min_antimono) simp_all
             with A have False by(rule set_less_aux_antisym) }
           moreover
           { assume "Min A < x"
             hence "Min A < Min (set (y # ys))" unfolding \<open>x = y\<close> Minyys .
             hence "set (y # ys) \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' have False by(rule set_less_aux_antisym) }
           ultimately have MinA: "Min A = x" by(metis less_linear)
           hence "x \<in> A" using nempty by(metis Min_in \<open>finite A\<close>)
           
           from A nempty Minxxs xnxs have "set xs \<sqsubset>' ?A"
             by(subst (asm) set_less_aux_rec)(auto simp add: MinA)
           moreover from A' \<open>x = y\<close> nempty Minyys MinA ynys have "?A \<sqsubset>' set ys"
             by(subst (asm) set_less_aux_rec) simp_all
           ultimately show ?lhs by blast
         qed
         finally show ?thesis using \<open>x = y\<close> by simp
       qed
     qed
   qed
 qed
 
 lemma proper_interval_set_Compl_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys" 
   shows "proper_interval_set_Compl_aux None 0 xs ys \<longleftrightarrow> (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' - set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao n
     assume "set xs \<subseteq> above ao" "set ys \<subseteq> above ao"
     from xs \<open>set xs \<subseteq> above ao\<close> ys \<open>set ys \<subseteq> above ao\<close>
     have "proper_interval_set_Compl_aux ao (card (UNIV - above ao)) xs ys \<longleftrightarrow>
           (\<exists>A \<subseteq> above ao. set xs \<sqsubset>' A \<and> A \<sqsubset>' - set ys \<inter> above ao)"
     proof(induct ao n\<equiv>"card (UNIV - above ao)" xs ys rule: proper_interval_set_Compl_aux.induct)
       case (1 ao)
       have "card (UNIV - above ao) + 1 < CARD('a) \<longleftrightarrow> (\<exists>A \<subseteq> above ao. A \<noteq> {} \<and> A \<sqsubset>' above ao)"
         (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence "card (UNIV - (UNIV - above ao)) > 1" by(simp add: card_Diff_subset)
         from card_gt_1D[OF this]
         obtain x y where above: "x \<in> above ao" "y \<in> above ao"
           and neq: "x \<noteq> y" by blast
         hence "{x} \<sqsubset>' {x, y} \<inter> above ao"
           by(simp_all add: psubsetI psubset_finite_imp_set_less_aux)
         also have "\<dots> \<sqsubseteq>' above ao"
           by(auto intro: subset_finite_imp_set_less_eq_aux)
         finally show ?rhs using above by blast
       next
         assume ?rhs
         then obtain A where nempty: "A \<inter> above ao \<noteq> {}"
           and subset: "A \<subseteq> above ao"
           and less: "A \<sqsubset>' above ao" by blast
         from nempty obtain x where x: "x \<in> A" "x \<in> above ao" by blast
         show ?lhs
         proof(rule ccontr)
           assume "\<not> ?lhs"
           moreover have "CARD('a) \<ge> card (UNIV - above ao)" by(rule card_mono) simp_all
           moreover from card_Un_disjoint[of "UNIV - above ao" "above ao"]
           have "CARD('a) = card (UNIV - above ao) + card (above ao)" by auto
           ultimately have "card (above ao) = 1" using x
             by(cases "card (above ao)")(auto simp add: not_less_eq less_Suc_eq_le)
           with x have "above ao = {x}" unfolding card_eq_1_iff by auto
           moreover with x subset have A: "A = {x}" by auto
           ultimately show False using less by simp
         qed
       qed
       thus ?case by simp
     next
       case (2 ao y ys)
       note ys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close> \<open>set (y # ys) \<subseteq> above ao\<close>
       have len_ys: "length ys = card (set ys)"
         using ys by(auto simp add: List.card_set intro: sym)
 
       define m where "m = CARD('a) - card (UNIV - above ao)"
       have "CARD('a) = card (above ao) + card (UNIV - above ao)"
         using card_Un_disjoint[of "above ao" "UNIV - above ao"] by auto
       hence m_eq: "m = card (above ao)" unfolding m_def by simp
         
       have "m \<noteq> length ys + 1 \<and> (m = length ys + 2 \<longrightarrow> \<not> proper_interval (Some (last (y # ys))) None) \<longleftrightarrow>
         (\<exists>A \<subseteq> above ao. A \<noteq> {} \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)" (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence m: "m \<noteq> length ys + 1"
           and pi: "m = length ys + 2 \<Longrightarrow> \<not> proper_interval (Some (last (y # ys))) None"
           by simp_all
         have "length ys + 1 = card (set (y # ys))" using ys len_ys by simp
         also have "\<dots> \<le> m" unfolding m_eq by(rule card_mono)(simp, rule ys)
         finally have "length ys + 2 \<le> m" using m by simp
         show ?rhs
         proof(cases "m = length ys + 2")
           case True
           hence "card (UNIV - (UNIV - above ao) - set (y # ys)) = 1"
             using ys len_ys
             by(subst card_Diff_subset)(auto simp add: m_def card_Diff_subset)
           then obtain z where z: "z \<in> above ao" "z \<noteq> y" "z \<notin> set ys"
             unfolding card_eq_1_iff by auto
           from True have "\<not> proper_interval (Some (last (y # ys))) None" by(rule pi)
           hence "z \<le> last (y # ys)" by(simp add: proper_interval_simps not_less del: last.simps)
           moreover have ly: "last (y # ys) \<in> set (y # ys)" by(rule last_in_set) simp
           with z have "z \<noteq> last (y # ys)" by auto
           ultimately have "z < last (y # ys)" by simp
           hence "{last (y # ys)} \<sqsubset>' {z}"
             using z ly ys by(auto 4 3 simp add: set_less_aux_def)
           also have "\<dots> \<sqsubseteq>' - set (y # ys) \<inter> above ao"
             using z by(auto intro: subset_finite_imp_set_less_eq_aux)
           also have "{last (y # ys)} \<noteq> {}" using ly ys by blast
           moreover have "{last (y # ys)} \<subseteq> above ao" using ys by auto
           ultimately show ?thesis by blast
         next
           case False
           with \<open>length ys + 2 \<le> m\<close> ys len_ys
           have "card (UNIV - (UNIV - above ao) - set (y # ys)) > 1"
             by(subst card_Diff_subset)(auto simp add: card_Diff_subset m_def)
           from card_gt_1D[OF this]
           obtain x x' where x: "x \<in> above ao" "x \<noteq> y" "x \<notin> set ys"
             and x': "x' \<in> above ao" "x' \<noteq> y" "x' \<notin> set ys"
             and neq: "x \<noteq> x'" by auto
           hence "{x} \<sqsubset>' {x, x'} \<inter> above ao"
             by(simp_all add: psubsetI psubset_finite_imp_set_less_aux)
           also have "\<dots> \<sqsubseteq>' - set (y # ys) \<inter> above ao" using x x' ys
             by(auto intro: subset_finite_imp_set_less_eq_aux)
           also have "{x} \<inter> above ao \<noteq> {}" using x by simp
           ultimately show ?rhs by blast
         qed
       next
         assume ?rhs
         then obtain A where nempty: "A \<noteq> {}"
           and less: "A \<sqsubset>' - set (y # ys) \<inter> above ao"
           and subset: "A \<subseteq> above ao" by blast
         have "card (set (y # ys)) \<le> card (above ao)" using ys(3) by(simp add: card_mono)
         hence "length ys + 1 \<le> m" unfolding m_eq using ys by(simp add: len_ys)
         have "m \<noteq> length ys + 1"
         proof
           assume "m = length ys + 1"
           hence "card (above ao) \<le> card (set (y # ys))"
             unfolding m_eq using ys len_ys by auto
           from card_seteq[OF _ _ this] ys have "set (y # ys) = above ao" by simp
           with nempty less show False by(auto simp add: set_less_aux_def)
         qed
         moreover
         { assume "m = length ys + 2"
           hence "card (above ao - set (y # ys)) = 1"
             using ys len_ys m_eq by(auto simp add: card_Diff_subset)
           then obtain z where z: "above ao - set (y # ys) = {z}"
             unfolding card_eq_1_iff ..
           hence eq_z: "- set (y # ys) \<inter> above ao = {z}" by auto
           with less have "A \<sqsubset>' {z}" by simp
           have "\<not> proper_interval (Some (last (y # ys))) None"
           proof
             assume "proper_interval (Some (last (y # ys))) None"
             then obtain z' where z': "last (y # ys) < z'"
               by(clarsimp simp add: proper_interval_simps)
             have "last (y # ys) \<in> set (y # ys)" by(rule last_in_set) simp
             with ys z' have "z' \<in> above ao" "z' \<notin> set (y # ys)"
-              by(auto simp del: last.simps sorted.simps(2) intro: above_upclosed dest: sorted_last)
+              using above_upclosed local.not_less local.sorted_last ys(1) z' by blast+
             with eq_z have "z = z'" by fastforce
             from z' have "\<And>x. x \<in> set (y # ys) \<Longrightarrow> x < z'" using ys
-              by(auto dest: sorted_last simp del: sorted.simps(2))
+              by(auto dest: sorted_last simp del: sorted_wrt.simps(2))
             with eq_z \<open>z = z'\<close>
             have "\<And>x. x \<in> above ao \<Longrightarrow> x \<le> z'" by(fastforce)
             with \<open>A \<sqsubset>' {z}\<close> nempty \<open>z = z'\<close> subset
             show False by(auto simp add: set_less_aux_def)
           qed }
         ultimately show ?lhs by simp
       qed
       thus ?case by(simp add: length_last_def m_def Let_def)
     next
       case (3 ao x xs)
       note xs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close> \<open>set (x # xs) \<subseteq> above ao\<close>
       have len_xs: "length xs = card (set xs)"
         using xs by(auto simp add: List.card_set intro: sym)
       
       define m where "m = CARD('a) - card (UNIV - above ao)"
       have "CARD('a) = card (above ao) + card (UNIV - above ao)"
         using card_Un_disjoint[of "above ao" "UNIV - above ao"] by auto
       hence m_eq: "m = card (above ao)" unfolding m_def by simp
       have "m \<noteq> length xs + 1 \<and> (m = length xs + 2 \<longrightarrow> \<not> proper_interval (Some (last (x # xs))) None) \<longleftrightarrow>
         (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' above ao)" (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence m: "m \<noteq> length xs + 1"
           and pi: "m = length xs + 2 \<Longrightarrow> \<not> proper_interval (Some (last (x # xs))) None"
           by simp_all
         have "length xs + 1 = card (set (x # xs))" using xs len_xs by simp
         also have "\<dots> \<le> m" unfolding m_eq by(rule card_mono)(simp, rule xs)
         finally have "length xs + 2 \<le> m" using m by simp
         show ?rhs
         proof(cases "m = length xs + 2")
           case True
           hence "card (UNIV - (UNIV - above ao) - set (x # xs)) = 1"
             using xs len_xs
             by(subst card_Diff_subset)(auto simp add: m_def card_Diff_subset)
           then obtain z where z: "z \<in> above ao" "z \<noteq> x" "z \<notin> set xs"
             unfolding card_eq_1_iff by auto
           define A where "A = insert z {y. y \<in> set (x # xs) \<and> y < z}"
 
           from True have "\<not> proper_interval (Some (last (x # xs))) None" by(rule pi)
           hence "z \<le> last (x # xs)" by(simp add: proper_interval_simps not_less del: last.simps)
           moreover have lx: "last (x # xs) \<in> set (x # xs)" by(rule last_in_set) simp
           with z have "z \<noteq> last (x # xs)" by auto
           ultimately have "z < last (x # xs)" by simp
           hence "set (x # xs) \<sqsubset>' A" 
             using z xs by(auto simp add: A_def set_less_aux_def intro: rev_bexI[where x=z])
           moreover have "last (x # xs) \<notin> A" using xs \<open>z < last (x # xs)\<close>
             by(auto simp add: A_def simp del: last.simps)
           hence "A \<subset> insert (last (x # xs)) A" by blast
           hence less': "A \<sqsubset>' insert (last (x # xs)) A"
             by(rule psubset_finite_imp_set_less_aux) simp
           have "\<dots> \<subseteq> above ao" using xs lx z
             by(auto simp del: last.simps simp add: A_def)
           hence "insert (last (x # xs)) A \<sqsubseteq>' above ao"
             by(auto intro: subset_finite_imp_set_less_eq_aux)
           with less' have "A \<sqsubset>' above ao"
             by(rule set_less_trans_set_less_eq)
           moreover have "A \<subseteq> above ao" using xs z by(auto simp add: A_def)
           ultimately show ?thesis by blast
         next
           case False
           with \<open>length xs + 2 \<le> m\<close> xs len_xs
           have "card (UNIV - (UNIV - above ao) - set (x # xs)) > 1"
             by(subst card_Diff_subset)(auto simp add: card_Diff_subset m_def)
           from card_gt_1D[OF this]
           obtain y y' where y: "y \<in> above ao" "y \<noteq> x" "y \<notin> set xs"
             and y': "y' \<in> above ao" "y' \<noteq> x" "y' \<notin> set xs"
             and neq: "y \<noteq> y'" by auto
           define A where "A = insert y (set (x # xs) \<inter> above ao)"
           hence "set (x # xs) \<subset> A" using y xs by auto
           hence "set (x # xs) \<sqsubset>' \<dots>"
             by(fastforce intro: psubset_finite_imp_set_less_aux)
           moreover have *: "\<dots> \<subset> above ao"
             using y y' neq by(auto simp add: A_def)
           moreover from * have "A \<sqsubset>' above ao"
             by(auto intro: psubset_finite_imp_set_less_aux)
           ultimately show ?thesis by blast
         qed
       next
         assume ?rhs
         then obtain A where lessA: "set (x # xs) \<sqsubset>' A"
           and Aless: "A \<sqsubset>' above ao" and subset: "A \<subseteq> above ao" by blast
         have "card (set (x # xs)) \<le> card (above ao)" using xs(3) by(simp add: card_mono)
         hence "length xs + 1 \<le> m" unfolding m_eq using xs by(simp add: len_xs)
         have "m \<noteq> length xs + 1"
         proof
           assume "m = length xs + 1"
           hence "card (above ao) \<le> card (set (x # xs))"
             unfolding m_eq using xs len_xs by auto
           from card_seteq[OF _ _ this] xs have "set (x # xs) = above ao" by simp
           with lessA Aless show False by(auto dest: set_less_aux_antisym)
         qed
         moreover
         { assume "m = length xs + 2"
           hence "card (above ao - set (x # xs)) = 1"
             using xs len_xs m_eq by(auto simp add: card_Diff_subset)
           then obtain z where z: "above ao - set (x # xs) = {z}"
             unfolding card_eq_1_iff ..
           have "\<not> proper_interval (Some (last (x # xs))) None"
           proof
             assume "proper_interval (Some (last (x # xs))) None"
             then obtain z' where z': "last (x # xs) < z'"
               by(clarsimp simp add: proper_interval_simps)
             have "last (x # xs) \<in> set (x # xs)" by(rule last_in_set) simp
             with xs z' have "z' \<in> above ao" "z' \<notin> set (x # xs)"
-              by(auto simp del: last.simps sorted.simps(2) intro: above_upclosed dest: sorted_last)
+              by(auto simp del: last.simps sorted_wrt.simps(2) intro: above_upclosed dest: sorted_last)
             with z have "z = z'" by fastforce
             from z' have y_less: "\<And>y. y \<in> set (x # xs) \<Longrightarrow> y < z'" using xs
-              by(auto simp del: sorted.simps(2) dest: sorted_last)
+              by(auto simp del: sorted_wrt.simps(2) dest: sorted_last)
             with z \<open>z = z'\<close> have "\<And>y. y \<in> above ao \<Longrightarrow> y \<le> z'" by(fastforce)
             
             from lessA subset obtain y where y: "y \<in> A" "y \<in> above ao" "y \<notin> set (x # xs)"
               and min: "\<And>y'. \<lbrakk> y' \<in> set (x # xs); y' \<in> above ao; y' \<notin> A \<rbrakk> \<Longrightarrow> y \<le> y'"
               by(auto simp add: set_less_aux_def)
             with z \<open>z = z'\<close> have "y = z'" by auto
             have "set (x # xs) \<subseteq> A"
             proof
               fix y'
               assume y': "y' \<in> set (x # xs)"
               show "y' \<in> A"
               proof(rule ccontr)
                 assume "y' \<notin> A"
                 from y' xs have "y' \<in> above ao" by auto
                 with y' have "y \<le> y'" using \<open>y' \<notin> A\<close> by(rule min)
                 moreover from y' have "y' < z'" by(rule y_less)
                 ultimately show False using \<open>y = z'\<close> by simp
               qed
             qed
             moreover from z xs have "above ao = insert z (set (x # xs))" by auto
             ultimately have "A = above ao" using y \<open>y = z'\<close> \<open>z = z'\<close> subset by auto
             with Aless show False by simp
           qed }
         ultimately show ?lhs by simp
       qed
       thus ?case by(simp add: length_last_def m_def Let_def del: last.simps)
     next
       case (4 ao x xs y ys)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
         and yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
         and xxs_above = \<open>set (x # xs) \<subseteq> above ao\<close>
         and yys_above = \<open>set (y # ys) \<subseteq> above ao\<close>
       from xxs have xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       from yys have ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
 
       have len_xs: "length xs = card (set xs)"
         using xs by(auto simp add: List.card_set intro: sym)
       have len_ys: "length ys = card (set ys)"
         using ys by(auto simp add: List.card_set intro: sym)
 
       show ?case
       proof(cases "x < y")
         case True
 
         have "proper_interval ao (Some x) \<or>
           proper_interval_set_Compl_aux (Some x) (card (UNIV - above ao) + 1) xs (y # ys) \<longleftrightarrow>
           (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
           (is "?lhs \<longleftrightarrow> ?rhs")
         proof(cases "proper_interval ao (Some x)")
           case True
           then obtain z where z: "z \<in> above ao" "z < x"
             by(clarsimp simp add: proper_interval_Some2)
           moreover with xxs have "\<forall>x'\<in>set xs. z < x'" by(auto)
           ultimately have "set (x # xs) \<sqsubset>' {z}"
             by(auto simp add: set_less_aux_def intro!: bexI[where x=z])
           moreover {
             from z yys \<open>x < y\<close> have "z < y" "\<forall>y'\<in>set ys. z < y'"
               by(auto)
             hence subset: "{z} \<subseteq> - set (y # ys) \<inter> above ao"
               using ys \<open>x < y\<close> z by auto
             moreover have "x \<in> \<dots>" using yys xxs \<open>x < y\<close> xxs_above by(auto)
             ultimately have "{z} \<subset> \<dots>" using \<open>z < x\<close> by fastforce
             hence "{z} \<sqsubset>' \<dots>"
               by(fastforce intro: psubset_finite_imp_set_less_aux) }
           moreover have "{z} \<subseteq> above ao" using z by simp
           ultimately have ?rhs by blast
           thus ?thesis using True by simp
         next
           case False
           hence above_eq: "above ao = insert x (above (Some x))" using xxs_above
             by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           moreover have "card (above (Some x)) < CARD('a)"
             by(rule psubset_card_mono)(auto)
           ultimately have card_eq: "card (UNIV - above ao) + 1 = card (UNIV - above (Some x))"
             by(simp add: card_Diff_subset)
           from xxs_above x_Min have xs_above: "set xs \<subseteq> above (Some x)" by(auto)
           from \<open>x < y\<close> y_Min have "set (y # ys) \<subseteq> above (Some x)" by(auto)
           with \<open>x < y\<close> card_eq xs xs_above yys
           have "proper_interval_set_Compl_aux (Some x) (card (UNIV - above ao) + 1) xs (y # ys) \<longleftrightarrow>
                (\<exists>A \<subseteq> above (Some x). set xs \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above (Some x))"
             by(subst card_eq)(rule 4)
           also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
           proof
             assume ?lhs'
             then obtain A where less_A: "set xs \<sqsubset>' A"
               and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above (Some x)"
               and subset: "A \<subseteq> above (Some x)" by blast
             let ?A = "insert x A"
 
             have Min_A': "Min ?A = x" using xxs_above False subset
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "Min (set (x # xs)) = x"
               using x_Min by(auto intro!: Min_eqI)
             moreover have Amx: "A - {x} = A"
               using False subset 
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             moreover have "set xs - {x} = set xs" using x_Min by auto
             ultimately have less_A': "set (x # xs) \<sqsubset>' ?A"
               using less_A xxs_above x_Min by(subst set_less_aux_rec) simp_all
             
             have "x \<in> - insert y (set ys) \<inter> above ao"
               using \<open>x < y\<close> xxs_above y_Min by auto
             hence "- insert y (set ys) \<inter> above ao \<noteq> {}" by auto
             moreover have "Min (- insert y (set ys) \<inter> above ao) = x"
               using yys y_Min xxs_above \<open>x < y\<close> False
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "- set (y # ys) \<inter> above ao - {x} = - set (y # ys) \<inter> above (Some x)"
               using yys_above False xxs_above
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             ultimately have A'_less: "?A \<sqsubset>' - set (y # ys) \<inter> above ao"
               using Min_A' A_less Amx xxs_above by(subst set_less_aux_rec) simp_all
             moreover have "?A \<subseteq> above ao" using subset xxs_above by(auto intro: above_upclosed)
             ultimately show ?rhs using less_A' by blast
           next
             assume ?rhs
             then obtain A where less_A: "set (x # xs) \<sqsubset>' A"
               and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao" 
               and subset: "A \<subseteq> above ao" by blast
             let ?A = "A - {x}"
 
             from less_A subset xxs_above have "set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
               by(simp add: Int_absorb2)
             with False xxs_above subset have "x \<in> A"
               by(auto simp add: set_less_aux_def proper_interval_Some2)
             hence "\<dots> \<noteq> {}" by auto
             moreover from \<open>x \<in> A\<close> False subset
             have Min_A: "Min A = x"
               by(auto intro!: Min_eqI simp add: proper_interval_Some2 not_less)
             moreover have "Min (set (x # xs)) = x"
               using x_Min by(auto intro!: Min_eqI)
             moreover have eq_A: "?A \<subseteq> above (Some x)"
               using xxs_above False subset 
               by(fastforce simp add: proper_interval_Some2 not_less intro: above_upclosed)
             moreover have "set xs - {x} = set xs"
               using x_Min by(auto)
             ultimately have less_A': "set xs \<sqsubset>' ?A"
               using xxs_above less_A by(subst (asm) set_less_aux_rec)(simp_all cong: conj_cong)
             
             have "x \<in> - insert y (set ys) \<inter> above ao"
               using \<open>x < y\<close> xxs_above y_Min by auto
             hence "- insert y (set ys) \<inter> above ao \<noteq> {}" by auto
             moreover have "Min (- set (y # ys) \<inter> above ao) = x"
               using yys y_Min xxs_above \<open>x < y\<close> False
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "- set (y # ys) \<inter> above (Some x) = - set (y # ys) \<inter> above ao - {x}"
               by(auto simp add: above_eq)
             ultimately have "?A \<sqsubset>' - set (y # ys) \<inter> above (Some x)"
               using A_less \<open>A \<noteq> {}\<close> eq_A Min_A
               by(subst (asm) set_less_aux_rec) simp_all
             
             with less_A' eq_A show ?lhs' by blast
           qed
           finally show ?thesis using False by simp
         qed
         thus ?thesis using True by simp
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           have "proper_interval ao (Some y) \<or> 
                 proper_interval_set_Compl_aux (Some y) (card (UNIV - above ao) + 1) (x # xs) ys \<longleftrightarrow>
                (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
             (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some y)")
             case True
             then obtain z where z: "z \<in> above ao" "z < y"
               by(clarsimp simp add: proper_interval_Some2)
             from xxs \<open>y < x\<close> have "\<forall>x'\<in>set (x # xs). y < x'" by(auto)
             hence less_A: "set (x # xs) \<sqsubset>' {y}" 
               by(auto simp add: set_less_aux_def intro!: bexI[where x=y])
 
             have "{y} \<sqsubset>' {z}"
               using z y_Min by(auto simp add: set_less_aux_def intro: bexI[where x=z])
             also have "\<dots> \<subseteq> - set (y # ys) \<inter> above ao" using z y_Min by auto
             hence "{z} \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
             finally have "{y} \<sqsubset>' \<dots>" .
             moreover have "{y} \<subseteq> above ao" using yys_above by auto
             ultimately have ?rhs using less_A by blast
             thus ?thesis using True by simp
           next
             case False
             hence above_eq: "above ao = insert y (above (Some y))" using yys_above
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             moreover have "card (above (Some y)) < CARD('a)"
               by(rule psubset_card_mono)(auto)
             ultimately have card_eq: "card (UNIV - above ao) + 1 = card (UNIV - above (Some y))"
               by(simp add: card_Diff_subset)
             from yys_above y_Min have ys_above: "set ys \<subseteq> above (Some y)" by(auto)
 
             have eq_ys: "- set ys \<inter> above (Some y) = - set (y # ys) \<inter> above ao"
               by(auto simp add: above_eq)
 
             from \<open>y < x\<close> x_Min have "set (x # xs) \<subseteq> above (Some y)" by(auto)
             with \<open>\<not> x < y\<close> \<open>y < x\<close> card_eq xxs ys ys_above
             have "proper_interval_set_Compl_aux (Some y) (card (UNIV - above ao) + 1) (x # xs) ys \<longleftrightarrow>
               (\<exists>A \<subseteq> above (Some y). set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set ys \<inter> above (Some y))"
               by(subst card_eq)(rule 4)
             also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof
               assume ?lhs'
               then obtain A where "set (x # xs) \<sqsubset>' A" and subset: "A \<subseteq> above (Some y)"
                 and "A \<sqsubset>' - set ys \<inter> above (Some y)" by blast
               moreover from subset have "A - {y} = A" by auto
               ultimately have "set (x # xs) \<sqsubset>' A - {y}"
                 and "A - {y} \<sqsubset>' - set (y # ys) \<inter> above ao"
                 using eq_ys by simp_all
               moreover from subset have "A - {y} \<subseteq> above ao"
                 using yys_above by(auto intro: above_upclosed)
               ultimately show ?rhs by blast
             next
               assume ?rhs
               then obtain A where "set (x # xs) \<sqsubset>' A" 
                 and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao" 
                 and subset: "A \<subseteq> above ao" by blast
               moreover
               from A_less False yys_above have "y \<notin> A"
                 by(auto simp add: set_less_aux_def proper_interval_Some2 not_less)
               ultimately have "set (x # xs) \<sqsubset>' A"
                 and "A \<sqsubset>' - set ys \<inter> above (Some y)"
                 using eq_ys by simp_all
               moreover from \<open>y \<notin> A\<close> subset above_eq have "A \<subseteq> above (Some y)" by auto
               ultimately show ?lhs' by blast
             qed
             finally show ?thesis using False by simp
           qed
           with False True show ?thesis by simp
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by simp
           have "proper_interval ao (Some x) \<and> 
                 (CARD('a) - (card (UNIV - above ao) + length ys) \<noteq> 2 \<or>
                  CARD('a) - (card (UNIV - above ao) + length xs) \<noteq> 2) \<longleftrightarrow>
                (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
             (is "?below \<and> ?card \<longleftrightarrow> ?rhs")
           proof(cases "?below")
             case False
             hence "- set (y # ys) \<inter> above ao \<sqsubset>' set (x # xs)"
               using \<open>x = y\<close> yys_above xxs_above y_Min
               by(auto simp add: not_less set_less_aux_def proper_interval_Some2 intro!: bexI[where x=y])
             with False show ?thesis by(auto dest: set_less_aux_trans)
           next
             case True
             then obtain z where z: "z \<in> above ao" "z < x"
               by(clarsimp simp add: proper_interval_Some2)
 
             have "?card \<longleftrightarrow> ?rhs"
             proof
               assume ?rhs
               then obtain A where less_A: "set (x # xs)  \<sqsubset>' A"
                 and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao"
                 and subset: "A \<subseteq> above ao" by blast
 
               { 
                 assume c_ys: "CARD('a) - (card (UNIV - above ao) + length ys) = 2"
                   and c_xs: "CARD('a) - (card (UNIV - above ao) + length xs) = 2"
                 from c_ys yys_above len_ys y_Min have "card (UNIV - (UNIV - above ao) - set (y # ys)) = 1"
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 then obtain z' where eq_y: "- set (y # ys) \<inter> above ao = {z'}"
                   unfolding card_eq_1_iff by auto
                 moreover from z have "z \<notin> set (y # ys)" using \<open>x = y\<close> y_Min by auto
                 ultimately have "z' = z" using z by fastforce
                 
                 from c_xs xxs_above len_xs x_Min have "card (UNIV - (UNIV - above ao) - set (x # xs)) = 1"
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 then obtain z'' where eq_x: "- set (x # xs) \<inter> above ao = {z''}"
                   unfolding card_eq_1_iff by auto
                 moreover from z have "z \<notin> set (x # xs)" using x_Min by auto
                 ultimately have "z'' = z" using z by fastforce
 
                 from less_A subset obtain q where "q \<in> A" "q \<in> above ao" "q \<notin> set (x # xs)"
                   by(auto simp add: set_less_aux_def)
                 hence "q \<in> {z''}" unfolding eq_x[symmetric] by simp
                 hence "q = z''" by simp
                 with \<open>q \<in> A\<close> \<open>z' = z\<close> \<open>z'' = z\<close> z 
                 have "- set (y # ys) \<inter> above ao \<subseteq> A"
                   unfolding eq_y by simp
                 hence "- set (y # ys) \<inter> above ao \<sqsubseteq>' A"
                   by(auto intro: subset_finite_imp_set_less_eq_aux)
                 with A_less have False by(auto dest: set_less_trans_set_less_eq) }
               thus ?card by auto
             next
               assume ?card (is "?card_ys \<or> ?card_xs")
               thus ?rhs
               proof
                 assume ?card_ys
                 let ?YS = "UNIV - (UNIV - above ao) - set (y # ys)"
                 from \<open>?card_ys\<close> yys_above len_ys y_Min have "card ?YS \<noteq> 1" 
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 moreover have "?YS \<noteq> {}" using True y_Min yys_above \<open>x = y\<close>
                   by(fastforce simp add: proper_interval_Some2)
                 hence "card ?YS \<noteq> 0" by simp
                 ultimately have "card ?YS > 1" by(cases "card ?YS") simp_all
                 from card_gt_1D[OF this] obtain x' y' 
                   where x': "x' \<in> above ao" "x' \<notin> set (y # ys)"
                   and y': "y' \<in> above ao" "y' \<notin> set (y # ys)"
                   and neq: "x' \<noteq> y'" by auto
                 let ?A = "{z}"
                 have "set (x # xs) \<sqsubset>' ?A" using z x_Min
                   by(auto simp add: set_less_aux_def intro!: rev_bexI)
                 moreover
                 { have "?A \<subseteq> - set (y # ys) \<inter> above ao"
                     using z \<open>x = y\<close> y_Min by(auto)
                   moreover have "x' \<notin> ?A \<or> y' \<notin> ?A" using neq by auto
                   with x' y' have "?A \<noteq> - set (y # ys) \<inter> above ao" by auto
                   ultimately have "?A \<subset> - set (y # ys) \<inter> above ao" by(rule psubsetI)
                   hence "?A \<sqsubset>' \<dots>" by(fastforce intro: psubset_finite_imp_set_less_aux) } 
                 ultimately show ?thesis using z by blast
               next
                 assume ?card_xs
                 let ?XS = "UNIV - (UNIV - above ao) - set (x # xs)"
                 from \<open>?card_xs\<close> xxs_above len_xs x_Min have "card ?XS \<noteq> 1" 
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 moreover have "?XS \<noteq> {}" using True x_Min xxs_above
                   by(fastforce simp add: proper_interval_Some2)
                 hence "card ?XS \<noteq> 0" by simp
                 ultimately have "card ?XS > 1" by(cases "card ?XS") simp_all
                 from card_gt_1D[OF this] obtain x' y' 
                   where x': "x' \<in> above ao" "x' \<notin> set (x # xs)"
                   and y': "y' \<in> above ao" "y' \<notin> set (x # xs)"
                   and neq: "x' \<noteq> y'" by auto
 
                 define A
                   where "A = (if x' = Min (above ao) then insert y' (set (x # xs)) else insert x' (set (x # xs)))"
                 hence "set (x # xs) \<subseteq> A" by auto
                 moreover have "set (x # xs) \<noteq> \<dots>"
                   using neq x' y' by(auto simp add: A_def)
                 ultimately have "set (x # xs) \<subset> A" ..
                 hence "set (x # xs) \<sqsubset>' \<dots>"
                   by(fastforce intro: psubset_finite_imp_set_less_aux)
                 moreover {
                   have nempty: "above ao \<noteq> {}" using z by auto
                   have "A \<sqsubset>' {Min (above ao)}" 
                     using z x' y' neq \<open>x = y\<close> x_Min xxs_above
                     by(auto 6 4 simp add: set_less_aux_def A_def nempty intro!: rev_bexI Min_eqI)
                   also have "Min (above ao) \<le> z" using z by(simp)
                   hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
                   with \<open>x = y\<close> y_Min have "Min (above ao) \<notin> set (y # ys)" by auto
                   hence "{Min (above ao)} \<subseteq> - set (y # ys) \<inter> above ao"
                     by(auto simp add: nempty)
                   hence "{Min (above ao)} \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
                   finally have "A \<sqsubset>' \<dots>" . }
                 moreover have "A \<subseteq> above ao" using xxs_above yys_above x' y' 
                   by(auto simp add: A_def)
                 ultimately show ?rhs by blast
               qed
             qed
             thus ?thesis using True by simp
           qed            
           thus ?thesis using \<open>x = y\<close> by simp
         qed
       qed
     qed }
   from this[of None]
   show ?thesis by(simp)
 qed
 
 lemma proper_interval_Compl_set_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys" 
   shows "proper_interval_Compl_set_aux None xs ys \<longleftrightarrow> (\<exists>A. - set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao n
     assume "set xs \<subseteq> above ao" "set ys \<subseteq> above ao"
     from xs \<open>set xs \<subseteq> above ao\<close> ys \<open>set ys \<subseteq> above ao\<close>
     have "proper_interval_Compl_set_aux ao xs ys \<longleftrightarrow>
           (\<exists>A. - set xs \<inter> above ao \<sqsubset>' A \<inter> above ao \<and> A \<inter> above ao \<sqsubset>' set ys \<inter> above ao)"
     proof(induction ao xs ys rule: proper_interval_Compl_set_aux.induct)
       case ("2_1" ao ys)
       { fix A
         assume "above ao \<sqsubset>' A \<inter> above ao"
         also have "\<dots> \<subseteq> above ao" by simp
         hence "A \<inter> above ao \<sqsubseteq>' above ao"
           by(auto intro: subset_finite_imp_set_less_eq_aux)
         finally have False by simp }
       thus ?case by auto
     next
       case ("2_2" ao xs) thus ?case by simp
     next
       case (1 ao x xs y ys)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x' \<in> set xs. x < x'"
         by(auto simp add: less_le)
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
       note xxs_above = \<open>set (x # xs) \<subseteq> above ao\<close>
       note yys_above = \<open>set (y # ys) \<subseteq> above ao\<close>
 
       show ?case
       proof(cases "x < y")
         case True
         have "\<not> proper_interval ao (Some x) \<and> proper_interval_Compl_set_aux (Some x) xs (y # ys) \<longleftrightarrow>
               (\<exists>A. - set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao \<and> A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao)"
           (is "?lhs \<longleftrightarrow> ?rhs")
         proof(cases "proper_interval ao (Some x)")
           case True
           then obtain z where z: "z < x" "z \<in> above ao"
             by(auto simp add: proper_interval_Some2)
           hence nempty: "above ao \<noteq> {}" by auto
           with z have "Min (above ao) \<le> z" by auto
           hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
           hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
             using y_Min x_Min z \<open>x < y\<close>
             by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
           thus ?thesis using True by(auto dest: set_less_aux_trans set_less_aux_antisym)
         next
           case False
           hence above_eq: "above ao = insert x (above (Some x))"
             using xxs_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           from x_Min have xs_above: "set xs \<subseteq> above (Some x)" by auto
           from \<open>x < y\<close> y_Min have ys_above: "set (y # ys) \<subseteq> above (Some x)" by auto
 
           have eq_xs: "- set xs \<inter> above (Some x) = - set (x # xs) \<inter> above ao"
             using above_eq by auto
           have eq_ys: "set (y # ys) \<inter> above (Some x) = set (y # ys) \<inter> above ao"
             using y_Min \<open>x < y\<close> xxs_above by(auto intro: above_upclosed)
           
           from \<open>x < y\<close> xs xs_above yys ys_above
           have "proper_interval_Compl_set_aux (Some x) xs (y # ys) \<longleftrightarrow>
                (\<exists>A. - set xs \<inter> above (Some x) \<sqsubset>' A \<inter> above (Some x) \<and>
                     A \<inter> above (Some x) \<sqsubset>' set (y # ys) \<inter> above (Some x))"
             by(rule "1.IH")
           also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs \<longleftrightarrow> _")
           proof
             assume ?lhs
             then obtain A where "- set xs \<inter> above (Some x) \<sqsubset>' A \<inter> above (Some x)"
               and "A \<inter> above (Some x) \<sqsubset>' set (y # ys) \<inter> above (Some x)" by blast
             moreover have "A \<inter> above (Some x) = (A - {x}) \<inter> above ao"
               using above_eq by auto
             ultimately have "- set (x # xs) \<inter> above ao \<sqsubset>' (A - {x}) \<inter> above ao"
               and "(A - {x}) \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao"
               using eq_xs eq_ys by simp_all
             thus ?rhs by blast
           next
             assume ?rhs
             then obtain A where "- set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
               and A_less: "A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao" by blast
             moreover have "x \<notin> A"
             proof
               assume "x \<in> A"
               hence "set (y # ys) \<inter> above ao \<sqsubset>' A \<inter> above ao"
                 using y_Min \<open>x < y\<close> by(auto simp add: above_eq set_less_aux_def intro!: bexI[where x=x])
               with A_less show False by(auto dest: set_less_aux_antisym)
             qed
             hence "A \<inter> above ao = A \<inter> above (Some x)" using above_eq by auto
             ultimately show ?lhs using eq_xs eq_ys by auto
           qed
           finally show ?thesis using False by simp
         qed
         thus ?thesis using True by simp
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some y)")
             case True
             then obtain z where z: "z < y" "z \<in> above ao"
               by(auto simp add: proper_interval_Some2)
             hence nempty: "above ao \<noteq> {}" by auto
             with z have "Min (above ao) \<le> z" by auto
             hence "Min (above ao) < y" using \<open>z < y\<close> by(rule le_less_trans)
             hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
               using y_Min x_Min z \<open>y < x\<close>
               by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
             thus ?thesis using True \<open>y < x\<close> by(auto dest: set_less_aux_trans set_less_aux_antisym)
           next
             case False
             hence above_eq: "above ao = insert y (above (Some y))"
               using yys_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             from y_Min have ys_above: "set ys \<subseteq> above (Some y)" by auto
             from \<open>y < x\<close> x_Min have xs_above: "set (x # xs) \<subseteq> above (Some y)" by auto
 
             have "y \<in> - set (x # xs) \<inter> above ao" using \<open>y < x\<close> x_Min yys_above by auto
             hence nempty: "- set (x # xs) \<inter> above ao \<noteq> {}" by auto
             have Min_x: "Min (- set (x # xs) \<inter> above ao) = y"
               using above_eq \<open>y < x\<close> x_Min by(auto intro!: Min_eqI)
             have Min_y: "Min (set (y # ys) \<inter> above ao) = y"
               using y_Min above_eq by(auto intro!: Min_eqI)
             have eq_xs: "- set (x # xs) \<inter> above ao - {y} = - set (x # xs) \<inter> above (Some y)"
                 by(auto simp add: above_eq)
             have eq_ys: "set ys \<inter> above ao - {y} = set ys \<inter> above (Some y)"
               using y_Min above_eq by auto
 
             from \<open>\<not> x < y\<close> \<open>y < x\<close> xxs xs_above ys ys_above
             have "proper_interval_Compl_set_aux (Some y) (x # xs) ys \<longleftrightarrow>
                  (\<exists>A. - set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y) \<and>
                       A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y))"
               by(rule "1.IH")
             also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof
               assume ?lhs'
               then obtain A where less_A: "- set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y)"
                 and A_less: "A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y)" by blast
               let ?A = "insert y A"
 
               have Min_A: "Min (?A \<inter> above ao) = y"
                 using above_eq by(auto intro!: Min_eqI)
               moreover have A_eq: "A \<inter> above ao - {y} = A \<inter> above (Some y)"
                 using above_eq by auto
               ultimately have less_A': "- set (x # xs) \<inter> above ao \<sqsubset>' ?A \<inter> above ao"
                 using nempty yys_above less_A Min_x eq_xs by(subst set_less_aux_rec) simp_all
 
               have A'_less: "?A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao"
                 using yys_above nempty Min_A A_eq A_less Min_y eq_ys
                 by(subst set_less_aux_rec) simp_all
               
               with less_A' show ?rhs by blast
             next
               assume ?rhs
               then obtain A where less_A: "- set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
                 and A_less: "A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao" by blast
 
               from less_A have nempty': "A \<inter> above ao \<noteq> {}" by auto
               moreover have A_eq: "A \<inter> above ao - {y} = A \<inter> above (Some y)"
                 using above_eq by auto
               moreover have y_in_xxs: "y \<in> - set (x # xs) \<inter> above ao"
                 using \<open>y < x\<close> x_Min yys_above by auto
               moreover have "y \<in> A"
               proof(rule ccontr)
                 assume "y \<notin> A"
                 hence "A \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
                   using \<open>y < x\<close> x_Min y_in_xxs
                   by(auto simp add: set_less_aux_def above_eq intro: bexI[where x=y])
                 with less_A show False by(rule set_less_aux_antisym)
               qed
               hence Min_A: "Min (A \<inter> above ao) = y" using above_eq y_Min by(auto intro!: Min_eqI)
               ultimately have less_A': "- set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y)"
                 using nempty less_A Min_x eq_xs
                 by(subst (asm) set_less_aux_rec)(auto dest: bspec[where x=y])
               
               have A'_less: "A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y)"
                 using A_less nempty' yys_above Min_A Min_y A_eq eq_ys
                 by(subst (asm) set_less_aux_rec) simp_all
               with less_A' show ?lhs' by blast
             qed
             finally show ?thesis using \<open>\<not> x < y\<close> \<open>y < x\<close> False by simp
           qed
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by auto
           thus ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some x)")
             case True
             then obtain z where z: "z < x" "z \<in> above ao"
               by(auto simp add: proper_interval_Some2)
             hence nempty: "above ao \<noteq> {}" by auto
             with z have "Min (above ao) \<le> z" by auto
             hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
             hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
               using y_Min x_Min z \<open>x = y\<close>
               by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
             thus ?thesis using True \<open>x = y\<close> by(auto dest: set_less_aux_trans set_less_aux_antisym)
           next
             case False
             hence above_eq: "above ao = insert x (above (Some x))"
               using xxs_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
 
             have "(ys = [] \<longrightarrow> xs \<noteq> []) \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof(intro iffI strip notI)
               assume ?lhs'
               show ?rhs
               proof(cases ys)
                 case Nil
                 with \<open>?lhs'\<close> obtain x' xs' where xs_eq: "xs = x' # xs'"
                   by(auto simp add: neq_Nil_conv)
                 with xs have x'_Min: "\<forall>x'' \<in> set xs'. x' < x''"
                   by(auto simp add: less_le)
                 let ?A = "- set (x # xs')"
                 have "- set (x # xs) \<inter> above ao \<subseteq> ?A \<inter> above ao"
                   using xs_eq by auto
                 moreover have "x' \<notin> - set (x # xs) \<inter> above ao" "x' \<in> ?A \<inter> above ao"
                   using xs_eq xxs_above x'_Min x_Min by auto
                 ultimately have "- set (x # xs) \<inter> above ao \<subset> ?A \<inter> above ao"
                   by blast
                 hence "- set (x # xs) \<inter> above ao \<sqsubset>' \<dots> "
                   by(fastforce intro: psubset_finite_imp_set_less_aux)
                 moreover have "\<dots> \<sqsubset>' set (y # ys) \<inter> above ao" 
                   using Nil \<open>x = y\<close> by(auto simp add: set_less_aux_def above_eq)
                 ultimately show ?thesis by blast
               next
                 case (Cons y' ys')
                 let ?A = "{y}"
                 have "- set (x # xs) \<inter> above ao \<sqsubset>' ?A \<inter> above ao"
                   using \<open>x = y\<close> x_Min by(auto simp add: set_less_aux_def above_eq)
                 moreover have "\<dots> \<subset> set (y # ys) \<inter> above ao"
                   using yys_above yys Cons by auto
                 hence "?A \<inter> above ao \<sqsubset>' \<dots>" by(fastforce intro: psubset_finite_imp_set_less_aux)
                 ultimately show ?thesis by blast
               qed
             next
               assume Nil: "ys = []" "xs = []" and ?rhs
               then obtain A where less_A: "- {x} \<inter> above ao \<sqsubset>' A \<inter> above ao" 
                 and A_less: "A \<inter> above ao \<sqsubset>' {x}" using \<open>x = y\<close> above_eq by auto
               have "x \<notin> A" using A_less by(auto simp add: set_less_aux_def above_eq)
               hence "A \<inter> above ao \<subseteq> - {x} \<inter> above ao" by auto
               hence "A \<inter> above ao \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
               with less_A have "\<dots> \<sqsubset>' \<dots>" by(rule set_less_trans_set_less_eq)
               thus False by simp
             qed
             with \<open>x = y\<close> False show ?thesis by simp
           qed
         qed
       qed
     qed }
   from this[of None] show ?thesis by simp
 qed
 
 end
 
 subsection \<open>Proper intervals for HOL types\<close>
 
 instantiation unit :: proper_interval begin
 fun proper_interval_unit :: "unit proper_interval" where
   "proper_interval_unit None None = True"
 | "proper_interval_unit _ _ = False"
 instance by intro_classes auto
 end
 
 instantiation bool :: proper_interval begin
 fun proper_interval_bool :: "bool proper_interval" where
   "proper_interval_bool (Some x) (Some y) \<longleftrightarrow> False"
 | "proper_interval_bool (Some x) None \<longleftrightarrow> \<not> x"
 | "proper_interval_bool None (Some y) \<longleftrightarrow> y"
 | "proper_interval_bool None None = True"
 instance by intro_classes auto
 end
 
 instantiation nat :: proper_interval begin
 fun proper_interval_nat :: "nat proper_interval" where
   "proper_interval_nat no None = True"
 | "proper_interval_nat None (Some x) \<longleftrightarrow> x > 0"
 | "proper_interval_nat (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 instance by intro_classes auto
 end
 
 instantiation int :: proper_interval begin
 fun proper_interval_int :: "int proper_interval" where
   "proper_interval_int (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 | "proper_interval_int _ _ = True"
 instance by intro_classes (auto intro: less_add_one, metis less_add_one minus_less_iff)
 end
 
 instantiation integer :: proper_interval begin
 context includes integer.lifting begin
 lift_definition proper_interval_integer :: "integer proper_interval" is "proper_interval" .
 instance by(intro_classes)(transfer, simp only: proper_interval_simps)+
 end
 end
 lemma proper_interval_integer_simps [code]:
   includes integer.lifting fixes x y :: integer and xo yo :: "integer option" shows
   "proper_interval (Some x) (Some y) = (1 < y - x)"
   "proper_interval None yo = True"
   "proper_interval xo None = True"
 by(transfer, simp)+
 
 instantiation natural :: proper_interval begin
 context includes natural.lifting begin
 lift_definition proper_interval_natural :: "natural proper_interval" is "proper_interval" .
 instance by(intro_classes)(transfer, simp only: proper_interval_simps)+
 end
 end
 lemma proper_interval_natural_simps [code]:
   includes natural.lifting fixes x y :: natural and xo :: "natural option" shows
   "proper_interval xo None = True"
   "proper_interval None (Some y) \<longleftrightarrow> y > 0"
   "proper_interval (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 by(transfer, simp)+
 
 lemma char_less_iff_nat_of_char: "x < y \<longleftrightarrow> of_char x < (of_char y :: nat)"
   by (fact less_char_def)
 
 lemma nat_of_char_inject [simp]: "of_char x = (of_char y :: nat) \<longleftrightarrow> x = y"
   by (fact of_char_eq_iff)
 
 lemma char_le_iff_nat_of_char: "x \<le> y \<longleftrightarrow> of_char x \<le> (of_char y :: nat)"
   by (fact less_eq_char_def)
 
 instantiation char :: proper_interval
 begin
 
 fun proper_interval_char :: "char proper_interval" where
   "proper_interval_char None None \<longleftrightarrow> True"
 | "proper_interval_char None (Some x) \<longleftrightarrow> x \<noteq> CHR 0x00"
 | "proper_interval_char (Some x) None \<longleftrightarrow> x \<noteq> CHR 0xFF"
 | "proper_interval_char (Some x) (Some y) \<longleftrightarrow> of_char y - of_char x > (1 :: nat)"
 
 instance proof
   fix y :: char
   { assume "y \<noteq> CHR 0x00"
     have "CHR 0x00 < y" 
     proof (rule ccontr)
       assume "\<not> CHR 0x00 < y"
       then have "of_char y = (of_char CHR 0x00 :: nat)"
         by (simp add: not_less char_le_iff_nat_of_char)
       then have "y = CHR 0x00"
         using nat_of_char_inject [of y "CHR 0x00"] by simp
       with \<open>y \<noteq> CHR 0x00\<close> show False
         by simp
     qed }
   moreover
   { fix z :: char
     assume "z < CHR 0x00"
     hence False
       by (simp add: char_less_iff_nat_of_char of_char_eq_iff [symmetric]) }
   ultimately show "proper_interval None (Some y) = (\<exists>z. z < y)"
     by auto
 
   fix x :: char
   { assume "x \<noteq> CHR 0xFF"
     then have "x < CHR 0xFF"
       by (auto simp add: neq_iff char_less_iff_nat_of_char)
         (insert nat_of_char_less_256 [of x], simp)
     hence "\<exists>z. x < z" .. }
   moreover
   { fix z :: char
     assume "CHR 0xFF < z"
     hence "False"
       by (simp add: char_less_iff_nat_of_char)
         (insert nat_of_char_less_256 [of z], simp) }
   ultimately show "proper_interval (Some x) None = (\<exists>z. x < z)" by auto
 
   { assume gt: "of_char y - of_char x > (1 :: nat)"
     let ?z = "char_of (of_char x + (1 :: nat))"
     from gt nat_of_char_less_256 [of y]
     have 255: "of_char x < (255 :: nat)" by arith
     with gt have "x < ?z" "?z < y"
       by (simp_all add: char_less_iff_nat_of_char)
     hence "\<exists>z. x < z \<and> z < y" by blast }
   moreover
   { fix z
     assume "x < z" "z < y"
     hence "(1 :: nat) < of_char y - of_char x"
       by (simp add: char_less_iff_nat_of_char) }
   ultimately show "proper_interval (Some x) (Some y) = (\<exists>z>x. z < y)"
     by auto
 qed simp
 
 end
 
 instantiation Enum.finite_1 :: proper_interval begin
 definition proper_interval_finite_1 :: "Enum.finite_1 proper_interval" 
 where "proper_interval_finite_1 x y \<longleftrightarrow> x = None \<and> y = None"
 instance by intro_classes (simp_all add: proper_interval_finite_1_def less_finite_1_def)
 end
 
 instantiation Enum.finite_2 :: proper_interval begin
 fun proper_interval_finite_2 :: "Enum.finite_2 proper_interval" where 
   "proper_interval_finite_2 None None \<longleftrightarrow> True"
 | "proper_interval_finite_2 None (Some x) \<longleftrightarrow> x = finite_2.a\<^sub>2"
 | "proper_interval_finite_2 (Some x) None \<longleftrightarrow> x = finite_2.a\<^sub>1"
 | "proper_interval_finite_2 (Some x) (Some y) \<longleftrightarrow> False"
 instance by intro_classes (auto simp add: less_finite_2_def)
 end
 
 instantiation Enum.finite_3 :: proper_interval begin
 fun proper_interval_finite_3 :: "Enum.finite_3 proper_interval" where
   "proper_interval_finite_3 None None \<longleftrightarrow> True"
 | "proper_interval_finite_3 None (Some x) \<longleftrightarrow> x \<noteq> finite_3.a\<^sub>1"
 | "proper_interval_finite_3 (Some x) None \<longleftrightarrow> x \<noteq> finite_3.a\<^sub>3"
 | "proper_interval_finite_3 (Some x) (Some y) \<longleftrightarrow> x = finite_3.a\<^sub>1 \<and> y = finite_3.a\<^sub>3"
 instance
 proof
   fix x y :: Enum.finite_3
   show "proper_interval None (Some y) = (\<exists>z. z < y)"
     by(cases y)(auto simp add: less_finite_3_def split: finite_3.split)
   show "proper_interval (Some x) None = (\<exists>z. x < z)"
     by(cases x)(auto simp add: less_finite_3_def)
   show "proper_interval (Some x) (Some y) = (\<exists>z>x. z < y)"
     by(auto simp add: less_finite_3_def split: finite_3.split_asm)
 qed simp
 end
 
 subsection \<open>List fusion for the order and proper intervals on @{typ "'a set"}\<close>
 
 definition length_last_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> nat \<times> 'a"
 where "length_last_fusion g s = length_last (list.unfoldr g s)"
 
 lemma length_last_fusion_code [code]:
   "length_last_fusion g s =
   (if list.has_next g s then
      let (x, s') = list.next g s
      in fold_fusion g (\<lambda>x (n, _). (n + 1, x)) s' (1, x)
    else (0, undefined))"
 unfolding length_last_fusion_def
 by(subst list.unfoldr.simps)(simp add: length_last_Nil length_last_Cons_code fold_fusion_def split_beta)
 
 declare length_last_fusion_def [symmetric, code_unfold]
 
 context proper_intrvl begin
 
 definition set_less_eq_aux_Compl_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "set_less_eq_aux_Compl_fusion g1 g2 ao s1 s2 = 
    set_less_eq_aux_Compl ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition Compl_set_less_eq_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "Compl_set_less_eq_aux_fusion g1 g2 ao s1 s2 = 
    Compl_set_less_eq_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition set_less_aux_Compl_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "set_less_aux_Compl_fusion g1 g2 ao s1 s2 =
    set_less_aux_Compl ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition Compl_set_less_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "Compl_set_less_aux_fusion g1 g2 ao s1 s2 =
    Compl_set_less_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition exhaustive_above_fusion :: "('a, 's) generator \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
 where "exhaustive_above_fusion g a s = exhaustive_above a (list.unfoldr g s)"
 
 definition exhaustive_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> bool"
 where "exhaustive_fusion g s = exhaustive (list.unfoldr g s)"
 
 definition proper_interval_set_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_set_aux_fusion g1 g2 s1 s2 =
    proper_interval_set_aux (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition proper_interval_set_Compl_aux_fusion :: 
   "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> nat \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_set_Compl_aux_fusion g1 g2 ao n s1 s2 =
    proper_interval_set_Compl_aux ao n (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition proper_interval_Compl_set_aux_fusion ::
   "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_Compl_set_aux_fusion g1 g2 ao s1 s2 =
    proper_interval_Compl_set_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 lemma set_less_eq_aux_Compl_fusion_code:
   "set_less_eq_aux_Compl_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    (list.has_next g1 s1 \<longrightarrow> list.has_next g2 s2 \<longrightarrow>
     (let (x, s1') = list.next g1 s1;
          (y, s2') = list.next g2 s2
      in if x < y then proper_interval ao (Some x) \<or> set_less_eq_aux_Compl_fusion g1 g2 (Some x) s1' s2
         else if y < x then proper_interval ao (Some y) \<or> set_less_eq_aux_Compl_fusion g1 g2 (Some y) s1 s2'
         else proper_interval ao (Some y)))"
 unfolding set_less_eq_aux_Compl_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(simp add: split_beta)
 
 lemma Compl_set_less_eq_aux_fusion_code:
   "Compl_set_less_eq_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some x) s1' s2
              else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some y) s1 s2'
              else \<not> proper_interval ao (Some y)
         else \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some x) s1' s2
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2
      in \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some y) s1 s2'
    else \<not> proper_interval ao None)"
 unfolding Compl_set_less_eq_aux_fusion_def
 by(subst (1 2 4 5 8 9) list.unfoldr.simps)(simp add: split_beta)
 
 lemma set_less_aux_Compl_fusion_code:
   "set_less_aux_Compl_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then proper_interval ao (Some x) \<or> set_less_aux_Compl_fusion g1 g2 (Some x) s1' s2
              else if y < x then proper_interval ao (Some y) \<or> set_less_aux_Compl_fusion g1 g2 (Some y) s1 s2'
              else proper_interval ao (Some y)
         else proper_interval ao (Some x) \<or> set_less_aux_Compl_fusion g1 g2 (Some x) s1' s2
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2
      in proper_interval ao (Some y) \<or> set_less_aux_Compl_fusion g1 g2 (Some y) s1 s2'
    else proper_interval ao None)"
 unfolding set_less_aux_Compl_fusion_def
 by(subst (1 2 4 5 8 9) list.unfoldr.simps)(simp add: split_beta)
 
 lemma Compl_set_less_aux_fusion_code:
   "Compl_set_less_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    list.has_next g1 s1 \<and> list.has_next g2 s2 \<and>
   (let (x, s1') = list.next g1 s1;
        (y, s2') = list.next g2 s2
    in if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_aux_fusion g1 g2 (Some x) s1' s2
       else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_aux_fusion g1 g2 (Some y) s1 s2'
       else \<not> proper_interval ao (Some y))"
 unfolding Compl_set_less_aux_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(simp add: split_beta)
 
 lemma exhaustive_above_fusion_code:
   "exhaustive_above_fusion g y s \<longleftrightarrow>
   (if list.has_next g s then
      let (x, s') = list.next g s
      in \<not> proper_interval (Some y) (Some x) \<and> exhaustive_above_fusion g x s'
    else \<not> proper_interval (Some y) None)"
 unfolding exhaustive_above_fusion_def
 by(subst list.unfoldr.simps)(simp add: split_beta)
 
 lemma exhaustive_fusion_code:
   "exhaustive_fusion g s =
   (list.has_next g s \<and> 
    (let (x, s') = list.next g s
     in \<not> proper_interval None (Some x) \<and> exhaustive_above_fusion g x s'))"
 unfolding exhaustive_fusion_def exhaustive_above_fusion_def
 by(subst (1) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_set_aux_fusion_code:
   "proper_interval_set_aux_fusion g1 g2 s1 s2 \<longleftrightarrow>
    list.has_next g2 s2 \<and>
   (let (y, s2') = list.next g2 s2
    in if list.has_next g1 s1 then
         let (x, s1') = list.next g1 s1
         in if x < y then False
            else if y < x then proper_interval (Some y) (Some x) \<or> list.has_next g2 s2' \<or> \<not> exhaustive_above_fusion g1 x s1'
            else proper_interval_set_aux_fusion g1 g2 s1' s2'
       else list.has_next g2 s2' \<or> proper_interval (Some y) None)"
 unfolding proper_interval_set_aux_fusion_def exhaustive_above_fusion_def
 by(subst (1 2) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_set_Compl_aux_fusion_code:
   "proper_interval_set_Compl_aux_fusion g1 g2 ao n s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then 
                proper_interval ao (Some x) \<or> 
                proper_interval_set_Compl_aux_fusion g1 g2 (Some x) (n + 1) s1' s2
              else if y < x then 
                proper_interval ao (Some y) \<or> 
                proper_interval_set_Compl_aux_fusion g1 g2 (Some y) (n + 1) s1 s2'
              else
                proper_interval ao (Some x) \<and>
                (let m = CARD('a) - n 
                 in m - length_fusion g2 s2' \<noteq> 2 \<or> m - length_fusion g1 s1' \<noteq> 2)
         else 
           let m = CARD('a) - n; (len_x, x') = length_last_fusion g1 s1
           in m \<noteq> len_x \<and> (m = len_x + 1 \<longrightarrow> \<not> proper_interval (Some x') None)
 
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2;
          m = CARD('a) - n;
          (len_y, y') = length_last_fusion g2 s2
      in m \<noteq> len_y \<and> (m = len_y + 1 \<longrightarrow> \<not> proper_interval (Some y') None)
    else CARD('a) > n + 1)"
 unfolding proper_interval_set_Compl_aux_fusion_def length_last_fusion_def length_fusion_def
 by(subst (1 2 4 5 9 10) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_Compl_set_aux_fusion_code:
   "proper_interval_Compl_set_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    list.has_next g1 s1 \<and> list.has_next g2 s2 \<and>
    (let (x, s1') = list.next g1 s1;
         (y, s2') = list.next g2 s2
     in if x < y then
          \<not> proper_interval ao (Some x) \<and> proper_interval_Compl_set_aux_fusion g1 g2 (Some x) s1' s2
        else if y < x then
          \<not> proper_interval ao (Some y) \<and> proper_interval_Compl_set_aux_fusion g1 g2 (Some y) s1 s2'
        else \<not> proper_interval ao (Some x) \<and> (list.has_next g2 s2' \<or> list.has_next g1 s1'))"
 unfolding proper_interval_Compl_set_aux_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(auto simp add: split_beta)
 
 end
 
 lemmas [code] =
   set_less_eq_aux_Compl_fusion_code proper_intrvl.set_less_eq_aux_Compl_fusion_code
   Compl_set_less_eq_aux_fusion_code proper_intrvl.Compl_set_less_eq_aux_fusion_code
   set_less_aux_Compl_fusion_code proper_intrvl.set_less_aux_Compl_fusion_code
   Compl_set_less_aux_fusion_code proper_intrvl.Compl_set_less_aux_fusion_code
   exhaustive_above_fusion_code proper_intrvl.exhaustive_above_fusion_code
   exhaustive_fusion_code proper_intrvl.exhaustive_fusion_code
   proper_interval_set_aux_fusion_code proper_intrvl.proper_interval_set_aux_fusion_code
   proper_interval_set_Compl_aux_fusion_code proper_intrvl.proper_interval_set_Compl_aux_fusion_code
   proper_interval_Compl_set_aux_fusion_code proper_intrvl.proper_interval_Compl_set_aux_fusion_code
 
 lemmas [symmetric, code_unfold] =
   set_less_eq_aux_Compl_fusion_def proper_intrvl.set_less_eq_aux_Compl_fusion_def
   Compl_set_less_eq_aux_fusion_def proper_intrvl.Compl_set_less_eq_aux_fusion_def
   set_less_aux_Compl_fusion_def proper_intrvl.set_less_aux_Compl_fusion_def
   Compl_set_less_aux_fusion_def proper_intrvl.Compl_set_less_aux_fusion_def
   exhaustive_above_fusion_def proper_intrvl.exhaustive_above_fusion_def
   exhaustive_fusion_def proper_intrvl.exhaustive_fusion_def
   proper_interval_set_aux_fusion_def proper_intrvl.proper_interval_set_aux_fusion_def
   proper_interval_set_Compl_aux_fusion_def proper_intrvl.proper_interval_set_Compl_aux_fusion_def
   proper_interval_Compl_set_aux_fusion_def proper_intrvl.proper_interval_Compl_set_aux_fusion_def
 
 subsection \<open>Drop notation\<close>
 
 context ord begin
 
 no_notation set_less_aux (infix "\<sqsubset>''" 50)
   and set_less_eq_aux (infix "\<sqsubseteq>''" 50)
   and set_less_eq_aux' (infix "\<sqsubseteq>''''" 50)
   and set_less_eq_aux'' (infix "\<sqsubseteq>''''''" 50)
   and set_less_eq (infix "\<sqsubseteq>" 50)
   and set_less (infix "\<sqsubset>" 50)
 
 end
 
 end
diff --git a/thys/Extended_Finite_State_Machine_Inference/code-targets/Code_Target_FSet.thy b/thys/Extended_Finite_State_Machine_Inference/code-targets/Code_Target_FSet.thy
--- a/thys/Extended_Finite_State_Machine_Inference/code-targets/Code_Target_FSet.thy
+++ b/thys/Extended_Finite_State_Machine_Inference/code-targets/Code_Target_FSet.thy
@@ -1,164 +1,164 @@
 section\<open>Finite Sets\<close>
 text\<open>Here we define the operations on the \texttt{fset} datatype in terms of lists rather than sets.
 This allows the Scala implementation to skip a case match each time, which makes for cleaner and
 slightly faster code.\<close>
 
 theory Code_Target_FSet
   imports "Extended_Finite_State_Machines.FSet_Utils"
 begin
 
 code_datatype fset_of_list
 
 declare FSet.fset_of_list.rep_eq [code]
 
 lemma fprod_code [code]:
   "fprod (fset_of_list xs) (fset_of_list ys) = fset_of_list (remdups [(x, y). x \<leftarrow> xs, y \<leftarrow> ys])"
   apply (simp add: fprod_def fset_of_list_def fset_both_sides Abs_fset_inverse)
   by auto
 
 lemma fminus_fset_filter [code]:
   "fset_of_list A -  xs = fset_of_list (remdups (filter (\<lambda>x. x |\<notin>| xs) A))"
   by auto
 
 lemma sup_fset_fold [code]:
   "(fset_of_list f1) |\<union>| (fset_of_list f2) = fset_of_list (remdups (f1@f2))"
   by simp
 
 lemma bot_fset [code]: "{||} = fset_of_list []"
   by simp
 
 lemma finsert [code]:
   "finsert a (fset_of_list as) = fset_of_list (List.insert a as)"
   by (simp add: List.insert_def finsert_absorb fset_of_list_elem)
 
 lemma ffilter_filter [code]:
   "ffilter f (fset_of_list as) = fset_of_list (List.filter f (remdups as))"
   by simp
 
 lemma fimage_map [code]:
   "fimage f (fset_of_list as) = fset_of_list (List.map f (remdups as))"
   by simp
 
 lemma ffUnion_fold [code]:
   "ffUnion (fset_of_list as) = fold (|\<union>|) as {||}"
   by (simp add: fold_union_ffUnion)
 
 lemma fmember [code]: "a |\<in>| (fset_of_list as) = List.member as a"
   by (simp add: fset_of_list_elem member_def)
 
 lemma fthe_elem [code]: "fthe_elem (fset_of_list [x]) = x"
   by simp
 
 lemma size [code]: "size (fset_of_list as) = length (remdups as)"
 proof(induct as)
   case Nil
   then show ?case
     by simp
 next
   case (Cons a as)
   then show ?case
     by (simp add: fset_of_list.rep_eq insert_absorb)
 qed
 
 lemma fMax_fold [code]: "fMax (fset_of_list (a#as)) = fold max as a"
   by (metis Max.set_eq_fold fMax.F.rep_eq fset_of_list.rep_eq)
 
 lemma fMin_fold [code]: "fMin (fset_of_list (h#t)) = fold min t h"
   apply (simp add: fset_of_list_def)
   by (metis Min.set_eq_fold fMin_Min fset_of_list.abs_eq list.simps(15))
 
 lemma fremove_code [code]:
   "fremove a (fset_of_list A) = fset_of_list (filter (\<lambda>x. x \<noteq> a) A)"
   apply (simp add: fremove_def minus_fset_def ffilter_def fset_both_sides Abs_fset_inverse fset_of_list.rep_eq)
   by auto
 
 lemma fsubseteq [code]:
   "(fset_of_list l) |\<subseteq>| A = List.list_all (\<lambda>x. x |\<in>| A) l"
   by (induct l, auto)
 
 lemma fsum_fold [code]: "fSum (fset_of_list l) = fold (+) (remdups l) 0"
 proof(induct l)
 case Nil
 then show ?case
   by (simp add: fsum.F.rep_eq fSum_def)
 next
   case (Cons a l)
   then show ?case
     apply simp
     apply standard
      apply (simp add: finsert_absorb fset_of_list_elem)
     by (simp add: add.commute fold_plus_sum_list_rev fset_of_list.rep_eq fsum.F.rep_eq fSum_def)
 qed
 
 lemma code_fset_eq [code]:
   "HOL.equal X (fset_of_list Y) \<longleftrightarrow> size X = length (remdups Y) \<and> (\<forall>x |\<in>| X. List.member Y x)"
   apply (simp only: HOL.equal_class.equal_eq fset_eq_alt)
   apply (simp only: size)
   using fmember by fastforce
 
 lemma code_fsubset [code]:
   "s |\<subset>| s' = (s |\<subseteq>| s' \<and> size s < size s')"
   apply standard
    apply (simp only: size_fsubset)
   by auto
 
 lemma code_fset [code]: "fset (fset_of_list l) = fold insert l {}"
   using fset_of_list.rep_eq union_set_fold by fastforce
 
 lemma code_fBall [code]: "fBall (fset_of_list l) f = list_all f l"
   by (simp add: Ball_set fBall.rep_eq fset_of_list.rep_eq)
 
 lemma code_fBex [code]: "fBex (fset_of_list l) f = list_ex f l"
   by (meson Bex_set fBexE fset_of_list_elem rev_fBexI)
 
 definition "nativeSort = sort"
 code_printing constant nativeSort \<rightharpoonup> (Scala) "_.sortWith((Orderings.less))"
 
 lemma [code]: "sorted_list_of_fset (fset_of_list l) = nativeSort (remdups l)"
   by (simp add: nativeSort_def sorted_list_of_fset_sort)
 
 lemma [code]: "sorted_list_of_set (set l) = nativeSort (remdups l)"
   by (simp add: nativeSort_def sorted_list_of_set_sort_remdups)
 
 lemma [code]: "fMin (fset_of_list (h#t)) = hd (nativeSort (h#t))"
   by (metis fMin_Min hd_sort_Min list.distinct(1) nativeSort_def)
 
 lemma sorted_Max_Cons:
   "l \<noteq> [] \<Longrightarrow>
    sorted (a#l) \<Longrightarrow>
    Max (set (a#l)) = Max (set l)"
   using eq_iff by fastforce
 
 lemma sorted_Max:
   "l \<noteq> [] \<Longrightarrow>
    sorted l \<Longrightarrow>
    Max (set l) = hd (rev l)"
 proof(induct l)
   case Nil
   then show ?case by simp
 next
   case (Cons a l)
   then show ?case
-    by (metis sorted_Max_Cons Max_singleton hd_rev last.simps list.set(1) list.simps(15) sorted.simps(2))
+    by (metis sorted_Max_Cons Max_singleton hd_rev last.simps list.set(1) list.simps(15) sorted_simps(2))
 qed
 
 lemma [code]: "fMax (fset_of_list (h#t)) = last (nativeSort (h#t))"
   by (metis Max.set_eq_fold fMax_fold hd_rev list.simps(3) nativeSort_def set_empty2 set_sort sorted_Max sorted_sort)
 
 definition "list_max l = fold max l"
 code_printing constant list_max \<rightharpoonup> (Scala) "_.par.fold((_))(Orderings.max)"
 
 lemma [code]: "fMax (fset_of_list (h#t)) = list_max t h"
   by (metis fMax_fold list_max_def)
 
 definition "list_min l = fold min l"
 code_printing constant list_min \<rightharpoonup> (Scala) "_.par.fold((_))(Orderings.min)"
 
 lemma [code]: "fMin (fset_of_list (h#t)) = list_min t h"
   by (metis fMin_fold list_min_def)
 
 lemma fis_singleton_code [code]: "fis_singleton s = (size s = 1)"
   apply (simp add: fis_singleton_def is_singleton_def)
   by (simp add: card_Suc_eq)
 
 end
diff --git a/thys/Extended_Finite_State_Machines/FSet_Utils.thy b/thys/Extended_Finite_State_Machines/FSet_Utils.thy
--- a/thys/Extended_Finite_State_Machines/FSet_Utils.thy
+++ b/thys/Extended_Finite_State_Machines/FSet_Utils.thy
@@ -1,341 +1,341 @@
 section\<open>FSet Utilities\<close>
 text\<open>This theory provides various additional lemmas, definitions, and syntax over the fset data type.\<close>
 theory FSet_Utils
   imports "HOL-Library.FSet"
 begin
 
 notation (latex output)
   "FSet.fempty" ("\<emptyset>") and
   "FSet.fmember" ("\<in>")
 
 syntax (ASCII)
   "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3ALL (_/:_)./ _)" [0, 0, 10] 10)
   "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX (_/:_)./ _)" [0, 0, 10] 10)
   "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX! (_/:_)./ _)" [0, 0, 10] 10)
 
 syntax (input)
   "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3! (_/:_)./ _)" [0, 0, 10] 10)
   "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3? (_/:_)./ _)" [0, 0, 10] 10)
   "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3?! (_/:_)./ _)" [0, 0, 10] 10)
 
 syntax
   "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
   "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
   "_fBnex"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<nexists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
   "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>!(_/|\<in>|_)./ _)" [0, 0, 10] 10)
 
 translations
   "\<forall>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. P)"
   "\<exists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBex  A (\<lambda>x. P)"
   "\<nexists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. \<not>P)"
   "\<exists>!x|\<in>|A. P" \<rightharpoonup> "\<exists>!x. x |\<in>| A \<and> P"
 
 lemma fset_of_list_remdups [simp]: "fset_of_list (remdups l) = fset_of_list l"
   apply (induct l)
    apply simp
   by (simp add: finsert_absorb fset_of_list_elem)
 
 definition "fSum \<equiv> fsum (\<lambda>x. x)"
 
 lemma fset_both_sides: "(Abs_fset s = f) = (fset (Abs_fset s) = fset f)"
   by (simp add: fset_inject)
 
 lemma Abs_ffilter: "(ffilter f s = s') = ({e \<in> (fset s). f e} = (fset s'))"
   by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)
 
 lemma size_ffilter_card: "size (ffilter f s) = card ({e \<in> (fset s). f e})"
   by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)
 
 lemma ffilter_empty [simp]: "ffilter f {||} = {||}"
   by auto
 
 lemma ffilter_finsert:
   "ffilter f (finsert a s) = (if f a then finsert a (ffilter f s) else (ffilter f s))"
   apply simp
   apply standard
    apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
    apply auto[1]
   apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
   by auto
 
 lemma fset_equiv: "(f1 = f2) = (fset f1 = fset f2)"
   by (simp add: fset_inject)
 
 lemma finsert_equiv: "(finsert e f = f') = (insert e (fset f) = (fset f'))"
   by (simp add: finsert_def fset_both_sides Abs_fset_inverse)
 
 lemma filter_elements:
   "x |\<in>| Abs_fset (Set.filter f (fset s)) = (x \<in> (Set.filter f (fset s)))"
   by (metis ffilter.rep_eq fset_inverse notin_fset)
 
 lemma sorted_list_of_fempty [simp]: "sorted_list_of_fset {||} = []"
   by (simp add: sorted_list_of_fset_def)
 
 lemma fmember_implies_member: "e |\<in>| f \<Longrightarrow> e \<in> fset f"
   by (simp add: fmember_def)
 
 lemma fold_union_ffUnion: "fold (|\<union>|) l {||} = ffUnion (fset_of_list l)"
 by(induct l rule: rev_induct, auto)
 
 lemma filter_filter:
   "ffilter P (ffilter Q xs) = ffilter (\<lambda>x. Q x \<and> P x) xs"
   by auto
 
 lemma fsubset_strict:
   "x2 |\<subset>| x1 \<Longrightarrow> \<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
   by auto
 
 lemma fsubset:
   "x2 |\<subset>| x1 \<Longrightarrow> \<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
   by auto
 
 lemma size_fsubset_elem:
   assumes "\<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
       and "\<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
     shows "size x2 < size x1"
   using assms
   apply (simp add: fmember_def)
   by (metis card_seteq finite_fset linorder_not_le subsetI)
 
 lemma size_fsubset: "x2 |\<subset>| x1 \<Longrightarrow> size x2 < size x1"
   by (metis fsubset fsubset_strict size_fsubset_elem)
 
 definition fremove :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
   where [code_abbrev]: "fremove x A = A - {|x|}"
 
 lemma arg_cong_ffilter:
   "\<forall>e |\<in>| f. p e = p' e \<Longrightarrow> ffilter p f = ffilter p' f"
   by auto
 
 lemma ffilter_singleton: "f e \<Longrightarrow> ffilter f {|e|} = {|e|}"
   apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
   by auto
 
 lemma fset_eq_alt: "(x = y) = (x |\<subseteq>| y \<and> size x = size y)"
   by (metis exists_least_iff le_less size_fsubset)
 
 lemma ffold_empty [simp]: "ffold f b {||} = b"
   by (simp add: ffold_def)
 
 lemma sorted_list_of_fset_sort:
   "sorted_list_of_fset (fset_of_list l) = sort (remdups l)"
   by (simp add: fset_of_list.rep_eq sorted_list_of_fset.rep_eq sorted_list_of_set_sort_remdups)
 
 lemma fMin_Min: "fMin (fset_of_list l) = Min (set l)"
   by (simp add: fMin.F.rep_eq fset_of_list.rep_eq)
 
 lemma sorted_hd_Min:
   "sorted l \<Longrightarrow>
    l \<noteq> [] \<Longrightarrow>
    hd l = Min (set l)"
-  by (metis List.finite_set Min_eqI eq_iff hd_Cons_tl insertE list.set_sel(1) list.simps(15) sorted.simps(2))
+  by (metis List.finite_set Min_eqI eq_iff hd_Cons_tl insertE list.set_sel(1) list.simps(15) sorted_simps(2))
 
 lemma hd_sort_Min: "l \<noteq> [] \<Longrightarrow> hd (sort l) = Min (set l)"
   by (metis sorted_hd_Min set_empty set_sort sorted_sort)
 
 lemma hd_sort_remdups: "hd (sort (remdups l)) = hd (sort l)"
   by (metis hd_sort_Min remdups_eq_nil_iff set_remdups)
 
 lemma exists_fset_of_list: "\<exists>l. f = fset_of_list l"
   using exists_fset_of_list by fastforce
 
 lemma hd_sorted_list_of_fset:
   "s \<noteq> {||} \<Longrightarrow> hd (sorted_list_of_fset s) = (fMin s)"
   apply (insert exists_fset_of_list[of s])
   apply (erule exE)
   apply simp
   apply (simp add: sorted_list_of_fset_sort fMin_Min hd_sort_remdups)
   by (metis fset_of_list_simps(1) hd_sort_Min)
 
 lemma fminus_filter_singleton:
   "fset_of_list l |-| {|x|} = fset_of_list (filter (\<lambda>e. e \<noteq> x) l)"
   by auto
 
 lemma card_minus_fMin:
   "s \<noteq> {||} \<Longrightarrow> card (fset s - {fMin s}) < card (fset s)"
   by (metis Min_in bot_fset.rep_eq card_Diff1_less fMin.F.rep_eq finite_fset fset_equiv)
 
 (* Provides a deterministic way to fold fsets similar to List.fold that works with the code generator *)
 function ffold_ord :: "(('a::linorder) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b \<Rightarrow> 'b" where
   "ffold_ord f s b = (
     if s = {||} then
       b
     else
       let
         h = fMin s;
         t = s - {|h|}
       in
         ffold_ord f t (f h b)
   )"
   by auto
 termination
   apply (relation "measures [\<lambda>(a, s, ab). size s]")
    apply simp
   by (simp add: card_minus_fMin)
 
 lemma sorted_list_of_fset_Cons:
   "\<exists>h t. (sorted_list_of_fset (finsert s ss)) = h#t"
   apply (simp add: sorted_list_of_fset_def)
   by (cases "insort s (sorted_list_of_set (fset ss - {s}))", auto)
 
 lemma list_eq_hd_tl:
   "l \<noteq> [] \<Longrightarrow>
    hd l = h \<Longrightarrow>
    tl l = t \<Longrightarrow>
    l = (h#t)"
   by auto
 
 lemma fset_of_list_sort: "fset_of_list l = fset_of_list (sort l)"
   by (simp add: fset_of_list.abs_eq)
 
 lemma exists_sorted_distinct_fset_of_list:
   "\<exists>l. sorted l \<and> distinct l \<and> f = fset_of_list l"
   by (metis distinct_sorted_list_of_set sorted_list_of_fset.rep_eq sorted_list_of_fset_simps(2) sorted_sorted_list_of_set)
 
 lemma fset_of_list_empty [simp]: "(fset_of_list l = {||}) = (l = [])"
   by (metis fset_of_list.rep_eq fset_of_list_simps(1) set_empty)
 
 lemma ffold_ord_cons: assumes sorted: "sorted (h#t)"
     and distinct: "distinct (h#t)"
   shows "ffold_ord f (fset_of_list (h#t)) b = ffold_ord f (fset_of_list t) (f h b)"
 proof-
   have h_is_min: "h = fMin (fset_of_list (h#t))"
     by (metis sorted fMin_Min list.sel(1) list.simps(3) sorted_hd_Min)
   have remove_min: "fset_of_list t = (fset_of_list (h#t)) - {|h|}"
     using distinct fset_of_list_elem by force
   show ?thesis
     apply (simp only: ffold_ord.simps[of f "fset_of_list (h#t)"])
     by (metis h_is_min remove_min fset_of_list_empty list.distinct(1))
 qed
 
 lemma sorted_distinct_ffold_ord: assumes "sorted l"
       and "distinct l"
     shows "ffold_ord f (fset_of_list l) b = fold f l b"
   using assms
   apply (induct l arbitrary: b)
    apply simp
-  by (metis distinct.simps(2) ffold_ord_cons fold_simps(2) sorted.simps(2))
+  by (metis distinct.simps(2) ffold_ord_cons fold_simps(2) sorted_simps(2))
 
 lemma ffold_ord_fold_sorted: "ffold_ord f s b = fold f (sorted_list_of_fset s) b"
   by (metis exists_sorted_distinct_fset_of_list sorted_distinct_ffold_ord distinct_remdups_id sorted_list_of_fset_sort sorted_sort_id)
 
 context includes fset.lifting begin
   lift_definition fprod  :: "'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) fset " (infixr "|\<times>|" 80) is "\<lambda>a b. fset a \<times> fset b"
     by simp
 
   lift_definition fis_singleton :: "'a fset \<Rightarrow> bool" is "\<lambda>A. is_singleton (fset A)".
 end
 
 lemma fprod_empty_l: "{||} |\<times>| a = {||}"
   using bot_fset_def fprod.abs_eq by force
 
 lemma fprod_empty_r: "a |\<times>| {||} = {||}"
   by (simp add: fprod_def bot_fset_def Abs_fset_inverse)
 
 lemmas fprod_empty = fprod_empty_l fprod_empty_r
 
 lemma fprod_finsert: "(finsert a as) |\<times>| (finsert b bs) =
    finsert (a, b) (fimage (\<lambda>b. (a, b)) bs |\<union>| fimage (\<lambda>a. (a, b)) as |\<union>| (as |\<times>| bs))"
   apply (simp add: fprod_def fset_both_sides Abs_fset_inverse)
   by auto
 
 lemma fprod_member:
   "x |\<in>| xs \<Longrightarrow>
    y |\<in>| ys \<Longrightarrow>
    (x, y) |\<in>| xs |\<times>| ys"
   by (simp add: fmember_def fprod_def Abs_fset_inverse)
 
 lemma fprod_subseteq:
   "x |\<subseteq>| x' \<and> y |\<subseteq>| y' \<Longrightarrow> x |\<times>| y |\<subseteq>| x' |\<times>| y'"
   apply (simp add: fprod_def less_eq_fset_def Abs_fset_inverse)
   by auto
 
 lemma fimage_fprod:
   "(a, b) |\<in>| A |\<times>| B \<Longrightarrow> f a b |\<in>| (\<lambda>(x, y). f x y) |`| (A |\<times>| B)"
   by force
 
 lemma fprod_singletons: "{|a|} |\<times>| {|b|} = {|(a, b)|}"
   apply (simp add: fprod_def)
   by (metis fset_inverse fset_simps(1) fset_simps(2))
 
 lemma fprod_equiv:
   "(fset (f |\<times>| f') = s) = (((fset f) \<times> (fset f')) = s)"
   by (simp add: fprod_def Abs_fset_inverse)
 
 lemma fis_singleton_alt: "fis_singleton f = (\<exists>e. f = {|e|})"
   by (metis fis_singleton.rep_eq fset_inverse fset_simps(1) fset_simps(2) is_singleton_def)
 
 lemma singleton_singleton [simp]: "fis_singleton {|a|}"
   by (simp add: fis_singleton_def)
 
 lemma not_singleton_empty [simp]: "\<not> fis_singleton {||}"
   apply (simp add: fis_singleton_def)
   by (simp add: is_singleton_altdef)
 
 lemma fis_singleton_fthe_elem:
   "fis_singleton A \<longleftrightarrow> A = {|fthe_elem A|}"
   by (metis fis_singleton_alt fthe_felem_eq)
 
 lemma fBall_ffilter:
   "\<forall>x |\<in>| X. f x \<Longrightarrow> ffilter f X = X"
   by auto
 
 lemma fBall_ffilter2:
   "X = Y \<Longrightarrow>
    \<forall>x |\<in>| X. f x \<Longrightarrow>
    ffilter f X = Y"
   by auto
 
 lemma size_fset_of_list: "size (fset_of_list l) = length (remdups l)"
   apply (induct l)
    apply simp
   by (simp add: fset_of_list.rep_eq insert_absorb)
 
 lemma size_fsingleton: "(size f = 1) = (\<exists>e. f = {|e|})"
   apply (insert exists_fset_of_list[of f])
   apply clarify
   apply (simp only: size_fset_of_list)
   apply (simp add: fset_of_list_def fset_both_sides Abs_fset_inverse)
   by (metis List.card_set One_nat_def card.insert card_1_singletonE card.empty empty_iff finite.intros(1))
 
 lemma ffilter_mono: "(ffilter X xs = f) \<Longrightarrow> \<forall>x |\<in>| xs. X x = Y x \<Longrightarrow> (ffilter Y xs = f)"
   by auto
 
 lemma size_fimage: "size (fimage f s) \<le> size s"
   apply (induct s)
    apply simp
   by (simp add: card_insert_if)
 
 lemma size_ffilter: "size (ffilter P f) \<le> size f"
   apply (induct f)
    apply simp
   apply (simp only: ffilter_finsert)
   apply (case_tac "P x")
    apply (simp add: fmember.rep_eq)
   by (simp add: card_insert_if)
 
 lemma fimage_size_le: "\<And>f s. size s \<le> n \<Longrightarrow> size (fimage f s) \<le> n"
   using le_trans size_fimage by blast
 
 lemma ffilter_size_le: "\<And>f s. size s \<le> n \<Longrightarrow> size (ffilter f s) \<le> n"
   using dual_order.trans size_ffilter by blast
 
 lemma set_membership_eq: "A = B \<longleftrightarrow> (\<lambda>x. Set.member x A) = (\<lambda>x. Set.member x B)"
   apply standard
    apply simp
   by (meson equalityI subsetI)
 
 lemmas ffilter_eq_iff = Abs_ffilter set_membership_eq fun_eq_iff
 
 lemma size_le_1: "size f \<le> 1 = (f = {||} \<or> (\<exists>e. f = {|e|}))"
   apply standard
    apply (metis bot.not_eq_extremum gr_implies_not0 le_neq_implies_less less_one size_fsingleton size_fsubset)
   by auto
 
 lemma size_gt_1: "1 < size f \<Longrightarrow> \<exists>e1 e2 f'. e1 \<noteq> e2 \<and> f = finsert e1 (finsert e2 f')"
   apply (induct f)
    apply simp
   apply (rule_tac x=x in exI)
   by (metis finsertCI leD not_le_imp_less size_le_1)
 
 end
diff --git a/thys/Imperative_Insertion_Sort/Imperative_Insertion_Sort.thy b/thys/Imperative_Insertion_Sort/Imperative_Insertion_Sort.thy
--- a/thys/Imperative_Insertion_Sort/Imperative_Insertion_Sort.thy
+++ b/thys/Imperative_Insertion_Sort/Imperative_Insertion_Sort.thy
@@ -1,473 +1,473 @@
 (*  Title:      Imperative_Insertion_Sort
     Author:     Christian Sternagel
 *)
 
 section \<open>Insertion Sort\<close>
 
 theory Imperative_Insertion_Sort
 imports
   Imperative_Loops
   "HOL-Library.Multiset"
 begin
 
 subsection \<open>The Algorithm\<close>
 
 abbreviation
   array_update :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array Heap" ("(_.'(_') \<leftarrow>/ _)" [1000, 0, 13] 14)
 where
   "a.(i) \<leftarrow> x \<equiv> Array.upd i x a"
 
 abbreviation array_nth :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a Heap" ("_.'(_')" [1000, 0] 14)
 where
   "a.(i) \<equiv> Array.nth a i"
 
 text \<open>
   A definition of insertion sort as given by Cormen et al.\ in \emph{Introduction to Algorithms}.
   Compared to the informal textbook version the variant below is a bit unwieldy due to explicit
   dereferencing of variables on the heap.
 
   To avoid ambiguities with existing syntax we use OCaml's notation for accessing (@{term "a.(i)"})
   and updating (@{term "a.(i) \<leftarrow> x"}) an array @{term a} at position @{term i}.
 \<close>
 definition
   "insertion_sort a = do {
     l \<leftarrow> Array.len a;
     for [1 ..< l] (\<lambda>j. do {
       \<comment> \<open>Insert \<open>a[j]\<close> into the sorted subarray \<open>a[1 .. j - 1].\<close>\<close>
       key \<leftarrow> a.(j);
       i \<leftarrow> ref j;
       while (do {
         i' \<leftarrow> ! i;
         if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)}
         else return False})
       (do {
         i' \<leftarrow> ! i;
         x \<leftarrow> a.(i' - 1);
         a.(i') \<leftarrow> x;
         i := i' - 1
       });
       i' \<leftarrow> ! i;
       a.(i') \<leftarrow> key
     })
   }"
 
 text \<open>
   The following definitions decompose the nested loops of the algorithm into more manageable chunks.
 \<close>
 definition "shiftr_p a (key::'a::{heap, linorder}) i =
   (do {i' \<leftarrow> ! i; if i' > 0 then do {x \<leftarrow> a.(i' - 1); return (x > key)} else return False})"
 
 definition "shiftr_f a i = do {
   i' \<leftarrow> ! i;
   x \<leftarrow> a.(i' - 1);
   a.(i') \<leftarrow> x;
   i := i' - 1
 }"
 
 definition "shiftr a key i = while (shiftr_p a key i) (shiftr_f a i)"
 
 definition "insert_elt a = (\<lambda>j. do {
   key \<leftarrow> a.(j);
   i \<leftarrow> ref j;
   shiftr a key i;
   i' \<leftarrow> ! i;
   a.(i') \<leftarrow> key
 })"
 
 definition "sort_upto a = (\<lambda>l. for [1 ..< l] (insert_elt a))"
 
 lemma insertion_sort_alt_def:
   "insertion_sort a = (Array.len a \<bind> sort_upto a)"
   by (simp add: insertion_sort_def sort_upto_def shiftr_def shiftr_p_def shiftr_f_def insert_elt_def)
 
 
 subsection \<open>Partial Correctness\<close>
 
 lemma effect_shiftr_f:
   assumes "effect (shiftr_f a i) h h' u"
   shows "Ref.get h' i = Ref.get h i - 1 \<and>
     Array.get h' a = list_update (Array.get h a) (Ref.get h i) (Array.get h a ! (Ref.get h i - 1))"
   using assms by (auto simp: shiftr_f_def elim!: effect_elims)
 
 lemma success_shiftr_p:
   "Ref.get h i < Array.length h a \<Longrightarrow> success (shiftr_p a key i) h"
   by (auto simp: success_def shiftr_p_def execute_simps)
 
 interpretation ro_shiftr_p: ro_cond "shiftr_p a key i" for a key i
   by (unfold_locales)
      (auto simp: shiftr_p_def success_def execute_simps execute_bind_case split: option.split, metis effectI effect_nthE)
 
 (*[0 .. j - 1]*)
 definition [simp]: "ini h a j = take j (Array.get h a)"
 (*[0 .. i - 1]*)
 definition [simp]: "left h a i = take (Ref.get h i) (Array.get h a)"
 (*[i+1 .. j]*)
 definition [simp]: "right h a j i = take (j - Ref.get h i) (drop (Ref.get h i + 1) (Array.get h a))"
 (*[0 .. i - 1, i + 1 .. j]*)
 definition [simp]: "both h a j i = left h a i @ right h a j i"
 
 lemma effect_shiftr:
   assumes "Ref.get h i = j" (is "?i h = _")
     and "j < Array.length h a"
     and "sorted (take j (Array.get h a))"
     and "effect (while (shiftr_p a key i) (shiftr_f a i)) h h' u"
   shows "Array.length h a = Array.length h' a \<and>
     ?i h' \<le> j \<and>
     mset (list_update (Array.get h a) j key) =
       mset (list_update (Array.get h' a) (?i h') key) \<and>
     ini h a j = both h' a j i \<and>
     sorted (both h' a j i) \<and>
     (\<forall>x \<in> set (right h' a j i). x > key)"
 using assms(4, 2)
 proof (induction rule: ro_shiftr_p.effect_while_induct)
   case base
   show ?case using assms by auto
 next
   case (step h' h'' u)
   from \<open>success (shiftr_p a key i) h'\<close> and \<open>cond (shiftr_p a key i) h'\<close>
     have "?i h' > 0" and
     key: "Array.get h' a ! (?i h' - 1) > key"
     by (auto dest!: ro_shiftr_p.success_cond_effect)
        (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
   from effect_shiftr_f [OF \<open>effect (shiftr_f a i) h' h'' u\<close>]
     have [simp]: "?i h'' = ?i h' - 1"
     "Array.get h'' a = list_update (Array.get h' a) (?i h') (Array.get h' a ! (?i h' - 1))"
     by auto
   from step have *: "?i h' < length (Array.get h' a)"
     and **: "?i h' - (Suc 0) \<le> ?i h'" "?i h' \<le> length (Array.get h' a)"
     and "?i h' \<le> j"
     and "?i h' < Suc j"
     and IH: "ini h a j = both h' a j i"
     by (auto simp add: Array.length_def)
   have "Array.length h a = Array.length h'' a" using step by (simp add: Array.length_def)
   moreover
   have "?i h'' \<le> j" using step by auto
   moreover
   have "mset (list_update (Array.get h a) j key) =
     mset (list_update (Array.get h'' a) (?i h'') key)"
   proof -
     have "?i h' < length (Array.get h' a)"
       and "?i h' - 1 < length (Array.get h' a)" using * by auto
     then show ?thesis
       using step by (simp add: mset_update ac_simps nth_list_update)
   qed
   moreover
   have "ini h a j = both h'' a j i"
     using \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and ** and IH
     by (auto simp: upd_conv_take_nth_drop Suc_diff_le min_absorb1)
        (metis Suc_lessD Suc_pred take_Suc_conv_app_nth)
 
   moreover
   have "sorted (both h'' a j i)"
     using step and \<open>0 < ?i h'\<close> and \<open>?i h' \<le> j\<close> and \<open>?i h' < length (Array.get h' a)\<close> and **
     by (auto simp: IH upd_conv_take_nth_drop Suc_diff_le min_absorb1)
        (metis Suc_lessD Suc_pred append.simps append_assoc take_Suc_conv_app_nth)
   moreover
   have "\<forall>x \<in> set (right h'' a j i). x > key"
     using step and \<open>0 < ?i h'\<close> and \<open>?i h' < length (Array.get h' a)\<close> and key
     by (auto simp: upd_conv_take_nth_drop Suc_diff_le)
   ultimately show ?case by blast
 qed
 
 lemma sorted_take_nth:
   assumes "0 < i" and "i < length xs" and "xs ! (i - 1) \<le> y"
     and "sorted (take i xs)"
   shows "\<forall>x \<in> set (take i xs). x \<le> y"
 proof -
   have "take i xs = take (i - 1) xs @ [xs ! (i - 1)]"
     using \<open>0 < i\<close> and \<open>i < length xs\<close>
     by (metis Suc_diff_1 less_imp_diff_less take_Suc_conv_app_nth)
   then show ?thesis
     using \<open>sorted (take i xs)\<close> and \<open>xs ! (i - 1) \<le>y\<close>
     by (auto simp: sorted_append)
 qed
 
 lemma effect_for_insert_elt:
   assumes "l \<le> Array.length h a"
     and "1 \<le> l"
     and "effect (for [1 ..< l] (insert_elt a)) h h' u"
   shows "Array.length h a = Array.length h' a \<and>
     sorted (take l (Array.get h' a)) \<and>
     mset (Array.get h a) = mset (Array.get h' a)"
 using assms(2-)
 proof (induction l h' rule: effect_for_induct)
   case base
   show ?case by (cases "Array.get h a") simp_all
 next
   case (step j h' h'' u)
   with assms(1) have "j < Array.length h' a" by auto
   from step have sorted: "sorted (take j (Array.get h' a))" by blast
   from step(3) [unfolded insert_elt_def]
     obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
     where key: "key = Array.get h' a ! j"
       and "effect (ref j) h' h\<^sub>1 i"
       and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
       and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
       and [simp]: "Ref.get h\<^sub>2 i = i'"
       and [simp]: "h'' = Array.update a i' key h\<^sub>2"
       and "i' < Array.length h\<^sub>2 a"
       by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
          (auto intro: effect_intros, metis effect_refE)
 
   from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
     by (metis array_get_alloc effectE execute_ref option.sel)
 
   have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)
 
   from step and assms(1)
     have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
   note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
   have "i' \<le> j" using shiftr by simp
 
   have "i' < length (Array.get h\<^sub>2 a)"
     by (metis \<open>i' < Array.length h\<^sub>2 a\<close> length_def)
   have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
   have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
     using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
   have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
     take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
     unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
     by (auto) (metis Suc_diff_le \<open>i' \<le> j\<close> take_Suc_Cons)
 
   have "Array.length h a = Array.length h'' a"
     using shiftr by (auto) (metis step.IH)
   moreover
   have "mset (Array.get h a) = mset (Array.get h'' a)"
     using shiftr and step by (simp add: key)
   moreover
   have "sorted (take (Suc j) (Array.get h'' a))"
   proof -
     from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
       have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
       by (auto dest!: ro_shiftr_p.success_not_cond_effect)
          (auto elim!: effect_elims simp: shiftr_p_def)
     then show ?thesis
     proof
       assume [simp]: "i' = 0"
       have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
         key # take j (drop 1 (Array.get h\<^sub>2 a))"
         by (simp) (metis \<open>i' = 0\<close> append_Nil take_Suc_j diff_zero take_0)
       from sorted and shiftr
         have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
         and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
       then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
-        by (metis less_imp_le sorted.simps(2))
+        by (metis less_imp_le sorted_simps(2))
       then show ?thesis by (simp add: *)
     next
       assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
       moreover
       have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
         and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
         using shiftr by auto
       ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
         using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
         by (simp add: sorted_append)
       then show ?thesis
         using shiftr by (auto simp: take_Suc_j sorted_append less_imp_le)
     qed
   qed
   ultimately
   show ?case by blast
 qed
 
 lemma effect_insertion_sort:
   assumes "effect (insertion_sort a) h h' u"
   shows "mset (Array.get h a) = mset (Array.get h' a) \<and> sorted (Array.get h' a)"
   using assms
   apply (cases "Array.length h a")
   apply (auto elim!: effect_elims simp: insertion_sort_def Array.length_def)[1]
   unfolding insertion_sort_def
   unfolding shiftr_p_def [symmetric] shiftr_f_def [symmetric]
   unfolding shiftr_def [symmetric] insert_elt_def [symmetric]
   apply (elim effect_elims)
   apply (simp only:)
   apply (subgoal_tac "Suc nat \<le> Array.length h a")
   apply (drule effect_for_insert_elt)
   apply (auto simp: Array.length_def)
 done
 
 
 subsection \<open>Total Correctness\<close>
 
 lemma success_shiftr_f:
   assumes "Ref.get h i < Array.length h a"
   shows "success (shiftr_f a i) h"
   using assms by (auto simp: success_def shiftr_f_def execute_simps)
 
 lemma success_shiftr:
   assumes "Ref.get h i < Array.length h a"
   shows "success (while (shiftr_p a key i) (shiftr_f a i)) h"
 proof -
   have "wf (measure (\<lambda>h. Ref.get h i))" by (metis wf_measure)
   then show ?thesis
   proof (induct taking: "\<lambda>h. Ref.get h i < Array.length h a" rule: ro_shiftr_p.success_while_induct)
     case (success_cond h)
     then show ?case by (metis success_shiftr_p)
   next
     case (success_body h)
     then show ?case by (blast intro: success_shiftr_f)
   next
     case (step h h' r)
     then show ?case
       by (auto dest!: effect_shiftr_f ro_shiftr_p.success_cond_effect simp: length_def)
          (auto simp: shiftr_p_def elim!: effect_elims effect_ifE)
   qed fact
 qed
 
 lemma effect_shiftr_index:
   assumes "effect (shiftr a key i) h h' u"
   shows "Ref.get h' i \<le> Ref.get h i"
   using assms unfolding shiftr_def
   by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto dest: effect_shiftr_f)
 
 lemma effect_shiftr_length:
   assumes "effect (shiftr a key i) h h' u"
   shows "Array.length h' a = Array.length h a"
   using assms unfolding shiftr_def
   by (induct h' rule: ro_shiftr_p.effect_while_induct) (auto simp: length_def dest: effect_shiftr_f)
 
 lemma success_insert_elt:
   assumes "k < Array.length h a"
   shows "success (insert_elt a k) h"
 proof -
   obtain key where "effect (a.(k)) h h key"
     using assms by (auto intro: effect_intros)
   moreover
   obtain i and h\<^sub>1 where "effect (ref k) h h\<^sub>1 i"
     and [simp]: "Ref.get h\<^sub>1 i = k"
     and [simp]: "Array.length h\<^sub>1 a = Array.length h a"
     by (auto simp: ref_def length_def) (metis Ref.get_alloc array_get_alloc effect_heapI)
   moreover
   obtain h\<^sub>2 where *: "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
     using success_shiftr [of h\<^sub>1 i a key] and assms
     by (auto simp: success_def effect_def shiftr_def)
   moreover
   have "effect (! i) h\<^sub>2 h\<^sub>2 (Ref.get h\<^sub>2 i)"
     and "Ref.get h\<^sub>2 i \<le> Ref.get h\<^sub>1 i"
     and "Ref.get h\<^sub>2 i < Array.length h\<^sub>2 a"
     using effect_shiftr_index [OF *] and effect_shiftr_length [OF *] and assms
     by (auto intro!: effect_intros)
   moreover
   then obtain h\<^sub>3 and r where "effect (a.(Ref.get h\<^sub>2 i) \<leftarrow> key) h\<^sub>2 h\<^sub>3 r"
     using assms by (auto simp: effect_def execute_simps)
   ultimately
   have "effect (insert_elt a k) h h\<^sub>3 r"
     by (auto simp: insert_elt_def intro: effect_intros)
   then show ?thesis by (metis effectE)
 qed
 
 lemma for_insert_elt_correct:
   assumes "l \<le> Array.length h a"
     and "1 \<le> l"
   shows "\<exists>h'. effect (for [1 ..< l] (insert_elt a)) h h' () \<and>
     Array.length h a = Array.length h' a \<and>
     sorted (take l (Array.get h' a)) \<and>
     mset (Array.get h a) = mset (Array.get h' a)"
 using assms(2)
 proof (induction rule: for_induct)
   case (succeed k h)
   then show ?case using assms and success_insert_elt [of k h a] by auto
 next
   case base
   show ?case by (cases "Array.get h a") simp_all
 next
   case (step j h' h'' u)
   with assms(1) have "j < Array.length h' a" by auto
   from step have sorted: "sorted (take j (Array.get h' a))" by blast
   from step(4) [unfolded insert_elt_def]
     obtain key and h\<^sub>1 and i and h\<^sub>2 and i'
     where key: "key = Array.get h' a ! j"
       and "effect (ref j) h' h\<^sub>1 i"
       and ref\<^sub>1: "Ref.get h\<^sub>1 i = j"
       and shiftr': "effect (shiftr a key i) h\<^sub>1 h\<^sub>2 ()"
       and [simp]: "Ref.get h\<^sub>2 i = i'"
       and [simp]: "h'' = Array.update a i' key h\<^sub>2"
       and "i' < Array.length h\<^sub>2 a"
       by (elim effect_bindE effect_nthE effect_lookupE effect_updE)
          (auto intro: effect_intros, metis effect_refE)
 
   from \<open>effect (ref j) h' h\<^sub>1 i\<close> have [simp]: "Array.get h\<^sub>1 a = Array.get h' a"
     by (metis array_get_alloc effectE execute_ref option.sel)
 
   have [simp]: "Array.length h\<^sub>1 a = Array.length h' a" by (simp add: Array.length_def)
 
   from step and assms(1)
     have "j < Array.length h\<^sub>1 a" "sorted (take j (Array.get h\<^sub>1 a))" by auto
   note shiftr = effect_shiftr [OF ref\<^sub>1 this shiftr' [unfolded shiftr_def], simplified]
   have "i' \<le> j" using shiftr by simp
 
   have "i' < length (Array.get h\<^sub>2 a)"
     by (metis \<open>i' < Array.length h\<^sub>2 a\<close> length_def)
   have [simp]: "min (Suc j) i' = i'" using \<open>i' \<le> j\<close> by simp
   have [simp]: "min (length (Array.get h\<^sub>2 a)) i' = i'"
     using \<open>i' < length (Array.get h\<^sub>2 a)\<close> by (simp)
   have take_Suc_j: "take (Suc j) (list_update (Array.get h\<^sub>2 a) i' key) =
     take i' (Array.get h\<^sub>2 a) @ key # take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))"
     unfolding upd_conv_take_nth_drop [OF \<open>i' < length (Array.get h\<^sub>2 a)\<close>]
     by (auto) (metis Suc_diff_le \<open>i' \<le> j\<close> take_Suc_Cons)
 
   have "Array.length h a = Array.length h'' a"
     using shiftr by (auto) (metis step.hyps(1))
   moreover
   have "mset (Array.get h a) = mset (Array.get h'' a)"
     using shiftr and step by (simp add: key)
   moreover
   have "sorted (take (Suc j) (Array.get h'' a))"
   proof -
     from ro_shiftr_p.effect_while_post [OF shiftr' [unfolded shiftr_def]]
       have "i' = 0 \<or> (0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1))"
       by (auto dest!: ro_shiftr_p.success_not_cond_effect)
          (auto elim!: effect_elims simp: shiftr_p_def)
     then show ?thesis
     proof
       assume [simp]: "i' = 0"
       have *: "take (Suc j) (list_update (Array.get h\<^sub>2 a) 0 key) =
         key # take j (drop 1 (Array.get h\<^sub>2 a))"
         by (simp) (metis \<open>i' = 0\<close> append_Nil take_Suc_j diff_zero take_0)
       from sorted and shiftr
         have "sorted (take j (drop 1 (Array.get h\<^sub>2 a)))"
         and "\<forall>x \<in> set (take j (drop 1 (Array.get h\<^sub>2 a))). key < x" by simp_all
       then have "sorted (key # take j (drop 1 (Array.get h\<^sub>2 a)))"
-        by (metis less_imp_le sorted.simps(2))
+        by (metis less_imp_le sorted_simps(2))
       then show ?thesis by (simp add: *)
     next
       assume "0 < i' \<and> key \<ge> Array.get h\<^sub>2 a ! (i' - 1)"
       moreover
       have "sorted (take i' (Array.get h\<^sub>2 a) @ take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a)))"
         and "\<forall>x \<in> set (take (j - i') (drop (Suc i') (Array.get h\<^sub>2 a))). key < x"
         using shiftr by auto
       ultimately have "\<forall>x \<in> set (take i' (Array.get h\<^sub>2 a)). x \<le> key"
         using sorted_take_nth [OF _ \<open>i' < length (Array.get h\<^sub>2 a)\<close>, of key]
         by (simp add: sorted_append)
       then show ?thesis
         using shiftr by (auto simp: take_Suc_j sorted_append less_imp_le)
     qed
   qed
   ultimately
   show ?case by blast
 qed
 
 lemma insertion_sort_correct:
   "\<exists>h'. effect (insertion_sort a) h h' u \<and>
     mset (Array.get h a) = mset (Array.get h' a) \<and>
     sorted (Array.get h' a)"
 proof (cases "Array.length h a = 0")
   assume "Array.length h a = 0"
   then have "effect (insertion_sort a) h h ()"
     and "mset (Array.get h a) = mset (Array.get h a)"
     and "sorted (Array.get h a)"
     by (auto simp: insertion_sort_def length_def intro!: effect_intros)
   then show ?thesis by auto
 next
   assume "Array.length h a \<noteq> 0"
   then have "1 \<le> Array.length h a" by auto
   from for_insert_elt_correct [OF le_refl this]
     show ?thesis
     by (auto simp: insertion_sort_alt_def sort_upto_def)
        (metis One_nat_def effect_bindI effect_insertion_sort effect_lengthI insertion_sort_alt_def sort_upto_def)
 qed
 
 export_code insertion_sort in Haskell
 
 end
 
diff --git a/thys/Iptables_Semantics/Common/Word_Upto.thy b/thys/Iptables_Semantics/Common/Word_Upto.thy
--- a/thys/Iptables_Semantics/Common/Word_Upto.thy
+++ b/thys/Iptables_Semantics/Common/Word_Upto.thy
@@ -1,206 +1,206 @@
 section\<open>Word Upto\<close>
 theory Word_Upto
 imports Main
   IP_Addresses.Hs_Compat
   Word_Lib.Word_Lemmas
 begin
 
 
 text\<open>Enumerate a range of machine words.\<close>
 
 text\<open>enumerate from the back (inefficient)\<close>
 function word_upto :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len) word list" where
 "word_upto a b = (if a = b then [a] else word_upto a (b - 1) @ [b])"
 by pat_completeness auto
 
 (*by the way: does not terminate practically if b < a; will terminate after it
   reaches the word wrap-around!*)
 
 termination word_upto
 apply(relation "measure (unat \<circ> uncurry (-) \<circ> prod.swap)")
  apply(rule wf_measure; fail)
 apply(simp)
 apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
  apply(simp add: diff_right_commute; fail)
 apply(rule measure_unat)
 apply auto
 done
 
 declare word_upto.simps[simp del]
  
 
 text\<open>enumerate from the front (more inefficient)\<close>
 function word_upto' :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len) word list" where
 "word_upto' a b = (if a = b then [a] else a # word_upto' (a + 1) b)"
 by pat_completeness auto
 
 termination word_upto'
 apply(relation "measure (\<lambda> (a, b). unat (b - a))")
  apply(rule wf_measure; fail)
 apply(simp)
 apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
  apply (simp add: diff_diff_add; fail)
 apply(rule measure_unat)
 apply auto
 done
 
 declare word_upto'.simps[simp del]
 
 lemma word_upto_cons_front[code]:
  "word_upto a b = word_upto' a b"
  proof(induction a b rule:word_upto'.induct)
  case (1 a b)
    have hlp1: "a \<noteq> b \<Longrightarrow> a # word_upto (a + 1) b = word_upto a b"
    apply(induction a b rule:word_upto.induct)
    apply simp
    apply(subst(1) word_upto.simps)
    apply(simp)
    apply safe
     apply(subst(1) word_upto.simps)
     apply (simp)
     apply(subst(1) word_upto.simps)
     apply (simp; fail)
    apply(case_tac "a \<noteq> b - 1")
     apply(simp)
     apply (metis Cons_eq_appendI word_upto.simps)
    apply(simp)
    done
 
    from 1[symmetric] show ?case
      apply(cases "a = b")
       subgoal
       apply(subst word_upto.simps)
       apply(subst word_upto'.simps)
       by(simp)
      apply(subst word_upto'.simps)
      by(simp add: hlp1)
  qed
 
 
 (* Most of the lemmas I show about word_upto hold without a \<le> b,
    but I don't need that right now and it's giving me a headache *)
 
 
 lemma word_upto_set_eq: "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<longleftrightarrow> a \<le> x \<and> x \<le> b"
 proof
   show "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<Longrightarrow> a \<le> x \<and> x \<le> b"
     apply(induction a b rule: word_upto.induct)
     apply(case_tac "a = b")
      apply(subst(asm) word_upto.simps)
      apply(simp; fail)
     apply(subst(asm) word_upto.simps)
     apply(simp)
     apply(erule disjE)
      apply(simp; fail)
     proof(goal_cases)
      case (1 a b)
      from 1(2-3) have "b \<noteq> 0" by force
      from 1(2,3) have "a \<le> b - 1"
        by (simp add: word_le_minus_one_leq)
      from 1(1)[OF this 1(4)] show ?case by (metis dual_order.trans 1(2,3) less_imp_le measure_unat word_le_0_iff word_le_nat_alt)
     qed
 next
   show "a \<le> x \<and> x \<le> b \<Longrightarrow> x \<in> set (word_upto a b)"
     apply(induction a b rule: word_upto.induct)
     apply(case_tac "a = b")
      apply(subst word_upto.simps)
      apply(simp; force)
     apply(subst word_upto.simps)
     apply(simp)
     apply(case_tac "x = b")
      apply(simp;fail)
     proof(goal_cases)
        case (1 a b)
        from 1(2-4) have "b \<noteq> 0" by force
        from 1(2,4) have "x \<le> b - 1"
          using le_step_down_word by auto
        from 1(1) this show ?case by simp
     qed
 qed
 
 lemma word_upto_distinct_hlp: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> b \<notin> set (word_upto a (b - 1))"
    apply(rule ccontr, unfold not_not)
    apply(subgoal_tac "a \<le> b - 1")
     apply(drule iffD1[OF word_upto_set_eq[of a "b -1" b]])
      apply(simp add: word_upto.simps)
     apply(subgoal_tac "b \<noteq> 0")
      apply(meson leD measure_unat word_le_nat_alt)
    apply(blast intro: iffD1[OF word_le_0_iff])
   using le_step_down_word apply blast
 done
 
 lemma distinct_word_upto: "a \<le> b \<Longrightarrow> distinct (word_upto a b)"
 apply(induction a b rule: word_upto.induct)
 apply(case_tac "a = b")
  apply(subst word_upto.simps)
  apply(simp; force)
 apply(subst word_upto.simps)
 apply(case_tac "a \<le> b - 1")
  apply(simp)
  apply(rule word_upto_distinct_hlp; simp)
 apply(simp)
   apply(rule ccontr)
   apply (simp add: not_le antisym word_minus_one_le_leq)
 done
 
 
 lemma word_upto_eq_upto: "s \<le> e \<Longrightarrow> e \<le> unat (max_word :: 'l word) \<Longrightarrow>
        word_upto ((of_nat :: nat \<Rightarrow> ('l :: len) word) s) (of_nat e) = map of_nat (upt s (Suc e))"
 proof(induction e)
   let ?mwon = "of_nat :: nat \<Rightarrow> 'l word"
   let ?mmw = "max_word :: 'l word"
   case (Suc e)
   show ?case
   proof(cases "?mwon s = ?mwon (Suc e)")
     case True
     have "s = Suc e" using le_unat_uoi Suc.prems True by metis
     with True show ?thesis by(subst word_upto.simps) (simp)
   next
     case False
     hence le: "s \<le> e" using le_SucE Suc.prems by blast
     have lm: "e \<le> unat ?mmw" using Suc.prems by simp
     have sucm: "(of_nat :: nat \<Rightarrow> ('l :: len) word) (Suc e) - 1 = of_nat e" using Suc.prems(2) by simp
     note mIH = Suc.IH[OF le lm]
     show ?thesis by(subst word_upto.simps) (simp add: False[simplified] Suc.prems mIH sucm)
   qed
 qed(simp add: word_upto.simps)
 
 lemma word_upto_alt: "(a :: ('l :: len) word) \<le> b \<Longrightarrow>
   word_upto a b = map of_nat (upt (unat a) (Suc (unat b)))"
 proof -
    let ?mmw = "max_word :: 'l word"
    assume le: "a \<le> b"
    hence nle: "unat a \<le> unat b" by(unat_arith)
    have lem: "unat b \<le> unat ?mmw" by (simp add: word_unat_less_le) 
    note word_upto_eq_upto[OF nle lem, unfolded word_unat.Rep_inverse]
    thus "word_upto a b = map of_nat [unat a..<Suc (unat b)]" .
 qed
 
 lemma word_upto_upt:
   "word_upto a b = (if a \<le> b then map of_nat (upt (unat a) (Suc (unat b))) else word_upto a b)"
   using word_upto_alt by metis
 
 lemma sorted_word_upto:
   fixes a b :: "('l :: len) word"
   assumes "a \<le> b"
   shows "sorted (word_upto a b)"
 proof -
   define m and n where \<open>m = unat a\<close> and \<open>n = Suc (unat b)\<close>
   moreover have \<open>sorted (map of_nat [m..<n] :: 'l word list)\<close>
     apply (simp add: sorted_map)
     apply (rule sorted_wrt_mono_rel [of _ \<open>(\<le>)\<close>])
-     apply (simp_all flip: sorted_sorted_wrt)
+     apply simp_all
     apply (simp add: le_unat_uoi less_Suc_eq_le n_def word_of_nat_le)
     apply transfer
     apply simp
     apply (subst take_bit_int_eq_self)
       apply (simp_all add: le_less_trans)
     apply (metis le_unat_uoi of_int_of_nat_eq of_nat_mono uint_word_of_int_eq unat_eq_nat_uint unsigned_of_int)
     done
   ultimately have \<open>sorted (map of_nat [unat a..<Suc (unat b)] :: 'l word list)\<close>
     by simp
   with assms show ?thesis
     by (simp only: word_upto_alt)
 qed
 
 end
diff --git a/thys/KBPs/ODList.thy b/thys/KBPs/ODList.thy
--- a/thys/KBPs/ODList.thy
+++ b/thys/KBPs/ODList.thy
@@ -1,657 +1,653 @@
 (*<*)
 (*
  * Knowledge-based programs.
  * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
  * License: BSD
  *
  * Based on Florian Haftmann's DList.thy and Tobias Nipkow's msort proofs.
  *)
 
 theory ODList
 imports
   "HOL-Library.Multiset"
   List_local
 begin
 (*>*)
 
 text\<open>
 
 Define a type of ordered distinct lists, intended to represent sets.
 
 The advantage of this representation is that it is isomorphic to the
 set of finite sets. Conversely it requires the carrier type to be a
 linear order.  Note that this representation does not arise from a
 quotient on lists: all the unsorted lists are junk.
 
 \<close>
 
 context linorder
 begin
 
 text\<open>
 
 "Absorbing" msort, a variant of Tobias Nipkow's proofs from 1992.
 
 \<close>
 
 fun
   merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "merge [] ys = ys"
 | "merge xs [] = xs"
 | "merge (x#xs) (y#ys) =
     (if x = y then merge xs (y#ys)
              else if x < y then x # merge xs (y#ys)
                            else y # merge (x#xs) ys)"
 
 (*<*)
 lemma set_merge[simp]:
   "set (merge xs ys) = set (xs @ ys)"
   by (induct xs ys rule: merge.induct) auto
 
 lemma distinct_sorted_merge[simp]:
   "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
      \<Longrightarrow> distinct (merge xs ys) \<and> sorted (merge xs ys)"
   by (induct xs ys rule: merge.induct) (auto)
 
 lemma mset_merge [simp]:
   "\<lbrakk> distinct (xs @ ys) \<rbrakk> \<Longrightarrow> mset (merge xs ys) = mset xs + mset ys"
   by (induct xs ys rule: merge.induct) (simp_all add: ac_simps)
 (*>*)
 
 text\<open>The "absorbing" sort itself.\<close>
 
 fun msort :: "'a list \<Rightarrow> 'a list"
 where
   "msort [] = []"
 | "msort [x] = [x]"
 | "msort xs = merge (msort (take (size xs div 2) xs))
                     (msort (drop (size xs div 2) xs))"
 
 (*<*)
 lemma msort_distinct_sorted[simp]:
   "distinct (msort xs) \<and> sorted (msort xs)"
   by (induct xs rule: msort.induct) simp_all
 
 lemma msort_set[simp]:
   "set (msort xs) = set xs"
   by (induct xs rule: msort.induct)
      (simp_all, metis List.set_simps(2) append_take_drop_id set_append) (* thankyou sledgehammer! *)
 
 lemma msort_remdups[simp]:
   "remdups (msort xs) = msort xs"
   by simp
 
 lemma msort_idle[simp]:
   "\<lbrakk> distinct xs; sorted xs \<rbrakk> \<Longrightarrow> msort xs = xs"
   by (rule map_sorted_distinct_set_unique[where f=id]) (auto simp: map.id)
 
 lemma mset_msort[simp]:
   "distinct xs \<Longrightarrow> mset (msort xs) = mset xs"
   by (rule iffD1[OF set_eq_iff_mset_eq_distinct]) simp_all
 
 lemma msort_sort[simp]:
   "distinct xs \<Longrightarrow> sort xs = msort xs"
   by (simp add: properties_for_sort)
 (*>*)
 
 end (* context linorder *)
 
 
 section \<open>The @{term "odlist"} type\<close>
 
 typedef (overloaded) ('a :: linorder) odlist = "{ x::'a list . sorted x \<and> distinct x }"
-  morphisms toList odlist_Abs by (auto iff: sorted.simps(1))
+  morphisms toList odlist_Abs by (auto iff: sorted_simps(1))
 
 lemma distinct_toList[simp]: "distinct (toList xs)"
   using toList by auto
 
 lemma sorted_toList[simp]: "sorted (toList xs)"
   using toList by auto
 
 text\<open>
 
 Code generator voodoo: this is the constructor for the abstract type.
 
 \<close>
 
 definition
   ODList :: "('a :: linorder) list \<Rightarrow> 'a odlist"
 where
   "ODList \<equiv> odlist_Abs \<circ> msort"
 
 lemma toList_ODList:
   "toList (ODList xs) = msort xs"
   unfolding ODList_def
   by (simp add: odlist_Abs_inverse)
 
 lemma ODList_toList[simp, code abstype]:
   "ODList (toList xs) = xs"
   unfolding ODList_def
   by (cases xs) (simp add: odlist_Abs_inverse)
 
 text\<open>
 
 Runtime cast from @{typ "'a list"} into @{typ "'a odlist"}. This is
 just a renaming of @{term "ODList"} -- names are significant to the
 code generator's abstract type machinery.
 
 \<close>
 
 definition
   fromList :: "('a :: linorder) list \<Rightarrow> 'a odlist"
 where
   "fromList \<equiv> ODList"
 
 lemma toList_fromList[code abstract]:
   "toList (fromList xs) = msort xs"
   unfolding fromList_def
   by (simp add: toList_ODList)
 
 subsection\<open>Basic properties: equality, finiteness\<close>
 
 (*<*)
 declare toList_inject[iff]
 (*>*)
 
 instantiation odlist :: (linorder) equal
 (*<*)
 begin
 
 definition [code]:
   "HOL.equal A B \<longleftrightarrow> odlist_equal (toList A) (toList B)"
 
 instance
   by standard (simp add: equal_odlist_def)
 
 end
 (*>*)
 
 instance odlist :: ("{finite, linorder}") finite
 (*<*)
 proof
   let ?ol = "UNIV :: 'a odlist set"
   let ?s = "UNIV :: 'a set set"
   have "finite ?s" by simp
   moreover
   have "?ol \<subseteq> range (odlist_Abs \<circ> sorted_list_of_set)"
   proof
     fix x show "x \<in> range (odlist_Abs \<circ> sorted_list_of_set)"
       apply (cases x)
       apply (rule range_eqI[where x="set (toList x)"])
       apply (clarsimp simp: odlist_Abs_inject sorted_list_of_set_sort_remdups odlist_Abs_inverse distinct_remdups_id)
       done
   qed
   ultimately show "finite ?ol" by (blast intro: finite_surj)
 qed
 (*>*)
 
 subsection\<open>Constants\<close>
 
 definition
   empty :: "('a :: linorder) odlist"
 where
   "empty \<equiv> ODList []"
 
 lemma toList_empty[simp, code abstract]:
   "toList empty = []"
   unfolding empty_def by (simp add: toList_ODList)
 
 subsection\<open>Operations\<close>
 
 subsubsection\<open>toSet\<close>
 
 definition
   toSet :: "('a :: linorder) odlist \<Rightarrow> 'a set"
 where
   "toSet X = set (toList X)"
 
 lemma toSet_empty[simp]:
   "toSet empty = {}"
   unfolding toSet_def empty_def by (simp add: toList_ODList)
 
 lemma toSet_ODList[simp]:
   "\<lbrakk> distinct xs; sorted xs \<rbrakk> \<Longrightarrow> toSet (ODList xs) = set xs"
   unfolding toSet_def by (simp add: toList_ODList)
 
 lemma toSet_fromList_set[simp]:
   "toSet (fromList xs) = set xs"
   unfolding toSet_def fromList_def
   by (simp add: toList_ODList)
 
 lemma toSet_inj[intro, simp]: "inj toSet"
   apply (rule injI)
   unfolding toSet_def
   apply (case_tac x)
   apply (case_tac y)
   apply (auto iff: odlist_Abs_inject odlist_Abs_inverse sorted_distinct_set_unique)
   done
 
 lemma toSet_eq_iff:
   "X = Y \<longleftrightarrow> toSet X = toSet Y"
   by (blast dest: injD[OF toSet_inj])
 
 subsubsection\<open>head\<close>
 
 definition
   hd :: "('a :: linorder) odlist \<Rightarrow> 'a"
 where
   [code]: "hd \<equiv> List.hd \<circ> toList"
 
 lemma hd_toList: "toList xs = y # ys \<Longrightarrow> ODList.hd xs = y"
   unfolding hd_def by simp
 
 subsubsection\<open>member\<close>
 
 definition
   member :: "('a :: linorder) odlist \<Rightarrow> 'a \<Rightarrow> bool"
 where
   [code]: "member xs x \<equiv> List.member (toList xs) x"
 
 lemma member_toSet[iff]:
   "member xs x \<longleftrightarrow>x \<in> toSet xs"
   unfolding member_def toSet_def by (simp add: in_set_member)
 
 subsubsection\<open>Filter\<close>
 
 definition
   filter :: "(('a :: linorder) \<Rightarrow> bool) \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
 where
   "filter P xs \<equiv> ODList (List.filter P (toList xs))"
 
 lemma toList_filter[simp, code abstract]:
   "toList (filter P xs) = List.filter P (toList xs)"
   unfolding filter_def by (simp add: toList_ODList)
 
 lemma toSet_filter[simp]:
   "toSet (filter P xs) = { x \<in> toSet xs . P x }"
   unfolding filter_def
   apply simp
   apply (simp add: toSet_def)
   done
 
 subsubsection\<open>All\<close>
 
 definition
   odlist_all :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> 'a odlist \<Rightarrow> bool"
 where
   [code]: "odlist_all P xs \<equiv> list_all P (toList xs)"
 
 lemma odlist_all_iff:
   "odlist_all P xs \<longleftrightarrow> (\<forall>x \<in> toSet xs. P x)"
   unfolding odlist_all_def toSet_def by (simp only: list_all_iff)
 
 lemma odlist_all_cong [fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> toSet ys \<Longrightarrow> f x = g x) \<Longrightarrow> odlist_all f xs = odlist_all g ys"
   by (simp add: odlist_all_iff)
 
 subsubsection\<open>Difference\<close>
 
 definition
   difference :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
 where
   "difference xs ys = ODList (List_local.difference (toList xs) (toList ys))"
 
 lemma toList_difference[simp, code abstract]:
   "toList (difference xs ys) = List_local.difference (toList xs) (toList ys)"
   unfolding difference_def by (simp add: toList_ODList)
 
 lemma toSet_difference[simp]:
   "toSet (difference xs ys) = toSet xs - toSet ys"
   unfolding difference_def
   apply simp
   apply (simp add: toSet_def)
   done
 
 subsubsection\<open>Intersection\<close>
 
 definition
   intersect :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
 where
   "intersect xs ys = ODList (List_local.intersection (toList xs) (toList ys))"
 
 lemma toList_intersect[simp, code abstract]:
   "toList (intersect xs ys) = List_local.intersection (toList xs) (toList ys)"
   unfolding intersect_def by (simp add: toList_ODList)
 
 lemma toSet_intersect[simp]:
   "toSet (intersect xs ys) = toSet xs \<inter> toSet ys"
   unfolding intersect_def
   apply simp
   apply (simp add: toSet_def)
   done
 
 subsubsection\<open>Union\<close>
 
 definition
   union :: "('a :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'a odlist"
 where
   "union xs ys = ODList (merge (toList xs) (toList ys))"
 
 lemma toList_union[simp, code abstract]:
   "toList (union xs ys) = merge (toList xs) (toList ys)"
   unfolding union_def by (simp add: toList_ODList)
 
 lemma toSet_union[simp]:
   "toSet (union xs ys) = toSet xs \<union> toSet ys"
   unfolding union_def
   apply simp
   apply (simp add: toSet_def)
   done
 
 definition
   big_union :: "('b \<Rightarrow> ('a :: linorder) odlist) \<Rightarrow> 'b list \<Rightarrow> 'a odlist"
 where
   [code]: "big_union f X \<equiv> foldr (\<lambda>a A. ODList.union (f a) A) X ODList.empty"
 
 lemma toSet_big_union[simp]:
   "toSet (big_union f X) = (\<Union>x \<in> set X. toSet (f x))"
 proof -
   { fix X Y
     have "toSet (foldr (\<lambda>x A. ODList.union (f x) A) X Y) = toSet Y \<union> (\<Union>x \<in> set X. toSet (f x))"
       by (induct X arbitrary: Y) auto }
    thus ?thesis
      unfolding big_union_def by simp
 qed
 
 subsubsection\<open>Case distinctions\<close>
 
 text\<open>
 
 We construct ODLists out of lists, so talk in terms of those, not a
 one-step constructor we don't use.
 
 \<close>
 
 lemma distinct_sorted_induct [consumes 2, case_names Nil insert]:
   assumes "distinct xs"
   assumes "sorted xs"
   assumes base: "P []"
   assumes step: "\<And>x xs. \<lbrakk> distinct (x # xs); sorted (x # xs); P xs \<rbrakk> \<Longrightarrow> P (x # xs)"
   shows "P xs"
 using \<open>distinct xs\<close> \<open>sorted xs\<close> proof (induct xs)
   case Nil from \<open>P []\<close> show ?case .
 next
   case (Cons x xs)
   then have "distinct (x # xs)" and "sorted (x # xs)" and "P xs" by (simp_all)
   with step show "P (x # xs)" .
 qed
 
 lemma odlist_induct [case_names empty insert, cases type: odlist]:
   assumes empty: "\<And>dxs. dxs = empty \<Longrightarrow> P dxs"
   assumes insrt: "\<And>dxs x xs. \<lbrakk> dxs = fromList (x # xs); distinct (x # xs); sorted (x # xs); P (fromList xs) \<rbrakk>
                             \<Longrightarrow> P dxs"
   shows "P dxs"
 proof (cases dxs)
   case (odlist_Abs xs)
   then have dxs: "dxs = ODList xs" and distinct: "distinct xs" and sorted: "sorted xs"
     by (simp_all add: ODList_def)
   from \<open>distinct xs\<close> and \<open>sorted xs\<close> have "P (ODList xs)"
   proof (induct xs rule: distinct_sorted_induct)
     case Nil from empty show ?case by (simp add: empty_def)
   next
     case (insert x xs) thus ?case
       apply -
       apply (rule insrt)
       apply (auto simp: fromList_def)
       done
   qed
   with dxs show "P dxs" by simp
 qed
 
 lemma odlist_cases [case_names empty insert, cases type: odlist]:
   assumes empty: "dxs = empty \<Longrightarrow> P"
   assumes insert: "\<And>x xs. \<lbrakk> dxs = fromList (x # xs); distinct (x # xs); sorted (x # xs) \<rbrakk>
                             \<Longrightarrow> P"
   shows P
 proof (cases dxs)
   case (odlist_Abs xs)
   then have dxs: "dxs = ODList xs" and distinct: "distinct xs" and sorted: "sorted xs"
     by (simp_all add: ODList_def)
   show P proof (cases xs)
     case Nil with dxs have "dxs = empty" by (simp add: empty_def)
     with empty show P .
   next
     case (Cons y ys)
     with dxs distinct sorted insert
     show P by (simp add: fromList_def)
   qed
 qed
 
 subsubsection\<open>Relations\<close>
 
 text\<open>
 
 Relations, represented as a list of pairs.
 
 \<close>
 
 type_synonym 'a odrelation = "('a \<times> 'a) odlist"
 
 subsubsection\<open>Image\<close>
 
 text\<open>
 
 The output of @{term "List_local.image"} is not guaranteed to be
 ordered or distinct. Also the relation need not be monomorphic.
 
 \<close>
 
 definition
   image :: "('a :: linorder \<times> 'b :: linorder) odlist \<Rightarrow> 'a odlist \<Rightarrow> 'b odlist"
 where
   "image R xs = ODList (List_local.image (toList R) (toList xs))"
 
 lemma toList_image[simp, code abstract]:
   "toList (image R xs) = msort (List_local.image (toList R) (toList xs))"
   unfolding image_def by (simp add: toList_ODList)
 
 lemma toSet_image[simp]:
   "toSet (image R xs) = toSet R `` toSet xs"
   unfolding image_def by (simp add: toSet_def toList_ODList)
 
 subsubsection\<open>Linear order\<close>
 
 text\<open>
 
 Lexicographic ordering on lists. Executable, unlike in List.thy.
 
 \<close>
 
 instantiation odlist :: (linorder) linorder
 begin
 print_context
 fun
   less_eq_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "less_eq_list [] ys = True"
 | "less_eq_list xs [] = False"
 | "less_eq_list (x # xs) (y # ys) = (x < y \<or> (x = y \<and> less_eq_list xs ys))"
 
 lemma less_eq_list_nil_inv:
   fixes xs :: "'a list"
   shows "less_eq_list xs [] \<Longrightarrow> xs = []"
   by (cases xs) simp_all
 
 lemma less_eq_list_cons_inv:
   fixes x :: 'a
   shows "less_eq_list (x # xs) yys \<Longrightarrow> \<exists>y ys. yys = y # ys \<and> (x < y \<or> (x = y \<and> less_eq_list xs ys))"
   by (cases yys) auto
 
 lemma less_eq_list_refl:
   fixes xs :: "'a list"
   shows "less_eq_list xs xs"
   by (induct xs) simp_all
 
 lemma less_eq_list_trans:
   fixes xs ys zs :: "'a list"
   shows "\<lbrakk> less_eq_list xs ys; less_eq_list ys zs \<rbrakk> \<Longrightarrow> less_eq_list xs zs"
   apply (induct xs ys arbitrary: zs rule: less_eq_list.induct)
     apply simp
    apply simp
   apply clarsimp
   apply (erule disjE)
    apply (drule less_eq_list_cons_inv)
    apply clarsimp
    apply (erule disjE)
     apply auto[1]
    apply auto[1]
   apply (auto dest: less_eq_list_cons_inv)
   done
 
 lemma less_eq_list_antisym:
   fixes xs ys :: "'a list"
   shows "\<lbrakk> less_eq_list xs ys; less_eq_list ys xs \<rbrakk> \<Longrightarrow> xs = ys"
   by (induct xs ys rule: less_eq_list.induct) (auto dest: less_eq_list_nil_inv)
 
 lemma less_eq_list_linear:
   fixes xs ys :: "'a list"
   shows "less_eq_list xs ys \<or> less_eq_list ys xs"
   by (induct xs ys rule: less_eq_list.induct) auto
 
 definition
   less_eq_odlist :: "'a odlist \<Rightarrow> 'a odlist \<Rightarrow> bool"
 where
   "xs \<le> ys \<equiv> less_eq_list (toList xs) (toList ys)"
 
 fun
   less_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "less_list [] [] = False"
 | "less_list [] ys = True"
 | "less_list xs [] = False"
 | "less_list (x # xs) (y # ys) = (x < y \<or> (x = y \<and> less_list xs ys))"
 
 definition
   less_odlist :: "'a odlist \<Rightarrow> 'a odlist \<Rightarrow> bool"
 where
   "xs < ys \<equiv> less_list (toList xs) (toList ys)"
 
 lemma less_eq_list_not_le:
   fixes xs ys :: "'a list"
   shows "(less_list xs ys) = (less_eq_list xs ys \<and> \<not> less_eq_list ys xs)"
   by (induct xs ys rule: less_list.induct) auto
 
 instance
   apply intro_classes
   unfolding less_eq_odlist_def less_odlist_def
   using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
   apply blast
   using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
   apply blast
   using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
   apply blast
   using less_eq_list_not_le less_eq_list_refl less_eq_list_trans less_eq_list_antisym
   apply blast
   apply (rule less_eq_list_linear)
   done
 
 end
 
 subsubsection\<open>Finite maps\<close>
 
 text\<open>
 
 A few operations on finite maps.
 
 Unlike the AssocList theory, ODLists give us canonical
 representations, so we can order them. Our tabulate has the wrong type
 (we want to take an odlist, not a list) so we can't use that
 part of the framework.
 
 \<close>
 
 definition
   lookup :: "('a :: linorder \<times> 'b :: linorder) odlist \<Rightarrow> ('a \<rightharpoonup> 'b)"
 where
   [code]: "lookup = map_of \<circ> toList"
 
 text\<open>Specific to ODLists.\<close>
 
 definition
   tabulate :: "('a :: linorder) odlist \<Rightarrow> ('a \<Rightarrow> 'b :: linorder) \<Rightarrow> ('a \<times> 'b) odlist"
 where
   "tabulate ks f = ODList (List.map (\<lambda>k. (k, f k)) (toList ks))"
 
 definition (in order) mono_on :: "('a \<Rightarrow> 'b::order) \<Rightarrow> 'a set \<Rightarrow> bool" where
   "mono_on f X \<longleftrightarrow> (\<forall>x\<in>X. \<forall>y\<in>X. x \<le> y \<longrightarrow> f x \<le> f y)"
 
 lemma (in order) mono_onI [intro?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "(\<And>x y. x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono_on f X"
   unfolding mono_on_def by simp
 
 lemma (in order) mono_onD [dest?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "mono_on f X \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
   unfolding mono_on_def by simp
 
 lemma (in order) mono_on_subset:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "mono_on f X \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> mono_on f Y"
   unfolding mono_on_def by auto
 
 lemma sorted_mono_map:
   "\<lbrakk> sorted xs; mono_on f (set xs) \<rbrakk> \<Longrightarrow> sorted (List.map f xs)"
   apply (induct xs)
    apply simp
   apply (simp)
   apply (cut_tac X="insert a (set xs)" and Y="set xs" in mono_on_subset)
   apply (auto dest: mono_onD)
   done
 
 lemma msort_map:
   "\<lbrakk> distinct xs; sorted xs; inj_on f (set xs); mono_on f (set xs) \<rbrakk> \<Longrightarrow> msort (List.map f xs) = List.map f xs"
   apply (rule msort_idle)
    apply (simp add: distinct_map)
   apply (simp add: sorted_mono_map)
   done
 
 lemma tabulate_toList[simp, code abstract]:
   "toList (tabulate ks f) = List.map (\<lambda>k. (k, f k)) (toList ks)"
   unfolding tabulate_def
   apply (simp add: toList_ODList)
   apply (subst msort_map)
   apply simp_all
    apply (rule inj_onI)
    apply simp
   apply (rule mono_onI)
   apply (simp add: less_eq_prod_def less_le)
   done
 
 lemma lookup_tabulate[simp]:
   "lookup (tabulate ks f) = (Some o f) |` toSet ks"
 proof(induct ks rule: odlist_induct)
   case (empty dxs) thus ?case unfolding tabulate_def lookup_def by (simp add: toList_ODList)
 next
   case (insert dxs x xs)
   from insert have "map_of (List.map (\<lambda>k. (k, f k)) xs) = map_of (msort (List.map (\<lambda>k. (k, f k)) xs))"
     apply (subst msort_map)
     apply (auto intro: inj_onI)
     apply (rule mono_onI)
     apply (simp add: less_eq_prod_def less_le)
     done
   also from insert have "... = lookup (tabulate (fromList xs) f)"
     unfolding tabulate_def lookup_def
     by (simp add: toList_ODList toList_fromList)
   also from insert have "... = (Some \<circ> f) |` toSet (fromList xs)"
     by (simp only: toSet_fromList_set)
   finally have IH: "map_of (List.map (\<lambda>k. (k, f k)) xs) = (Some \<circ> f) |` toSet (fromList xs)" .
   from insert have "lookup (tabulate dxs f) = map_of (toList (ODList (List.map (\<lambda>k. (k, f k)) (x # xs))))"
     unfolding tabulate_def lookup_def by (simp add: toList_fromList)
   also have "... = map_of (msort (List.map (\<lambda>k. (k, f k)) (x # xs)))"
     by (simp only: toList_ODList)
   also from insert have "... = map_of (List.map (\<lambda>k. (k, f k)) (x # xs))"
-    apply (subst msort_map)
-    apply (auto intro: inj_onI)
-    apply (rule mono_onI)
-    apply (simp add: less_eq_prod_def less_le)
-    done
+    by (metis msort_idle tabulate_def tabulate_toList toList_ODList)
   also with insert IH have "... = (Some \<circ> f) |` toSet dxs"
     by (auto simp add: restrict_map_def fun_eq_iff)
   finally show ?case .
 qed
 
 (*<*)
 end
 (*>*)
diff --git a/thys/List-Index/List_Index.thy b/thys/List-Index/List_Index.thy
--- a/thys/List-Index/List_Index.thy
+++ b/thys/List-Index/List_Index.thy
@@ -1,561 +1,561 @@
 (* Author: Tobias Nipkow, with contributions from Dmitriy Traytel, Lukas Bulwahn, and Peter Lammich *)
 
 section \<open>Index-based manipulation of lists\<close>
 
 theory List_Index imports Main begin
 
 text \<open>\noindent
 This theory collects functions for index-based manipulation of lists.
 \<close>
 
 subsection \<open>Finding an index\<close>
 
 text \<open>
 This subsection defines three functions for finding the index of items in a list:
 \begin{description}
 \item[\<open>find_index P xs\<close>] finds the index of the first element in
  \<open>xs\<close> that satisfies \<open>P\<close>.
 \item[\<open>index xs x\<close>] finds the index of the first occurrence of
  \<open>x\<close> in \<open>xs\<close>.
 \item[\<open>last_index xs x\<close>] finds the index of the last occurrence of
  \<open>x\<close> in \<open>xs\<close>.
 \end{description}
 All functions return @{term "length xs"} if \<open>xs\<close> does not contain a
 suitable element.
 
 The argument order of \<open>find_index\<close> follows the function of the same
 name in the Haskell standard library. For \<open>index\<close> (and \<open>last_index\<close>) the order is intentionally reversed: \<open>index\<close> maps
 lists to a mapping from elements to their indices, almost the inverse of
 function \<open>nth\<close>.\<close>
 
 primrec find_index :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
 "find_index _ [] = 0" |
 "find_index P (x#xs) = (if P x then 0 else find_index P xs + 1)"
 
 definition index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
 "index xs = (\<lambda>a. find_index (\<lambda>x. x=a) xs)"
 
 definition last_index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
 "last_index xs x =
  (let i = index (rev xs) x; n = size xs
   in if i = n then i else n - (i+1))"
 
 lemma find_index_append: "find_index P (xs @ ys) =
   (if \<exists>x\<in>set xs. P x then find_index P xs else size xs + find_index P ys)"
   by (induct xs) simp_all
   
 lemma find_index_le_size: "find_index P xs <= size xs"
 by(induct xs) simp_all
 
 lemma index_le_size: "index xs x <= size xs"
 by(simp add: index_def find_index_le_size)
 
 lemma last_index_le_size: "last_index xs x <= size xs"
 by(simp add: last_index_def Let_def index_le_size)
 
 lemma index_Nil[simp]: "index [] a = 0"
 by(simp add: index_def)
 
 lemma index_Cons[simp]: "index (x#xs) a = (if x=a then 0 else index xs a + 1)"
 by(simp add: index_def)
 
 lemma index_append: "index (xs @ ys) x =
   (if x : set xs then index xs x else size xs + index ys x)"
 by (induct xs) simp_all
 
 lemma index_conv_size_if_notin[simp]: "x \<notin> set xs \<Longrightarrow> index xs x = size xs"
 by (induct xs) auto
 
 lemma find_index_eq_size_conv:
   "size xs = n \<Longrightarrow> (find_index P xs = n) = (\<forall>x \<in> set xs. ~ P x)"
 by(induct xs arbitrary: n) auto
 
 lemma size_eq_find_index_conv:
   "size xs = n \<Longrightarrow> (n = find_index P xs) = (\<forall>x \<in> set xs. ~ P x)"
 by(metis find_index_eq_size_conv)
 
 lemma index_size_conv: "size xs = n \<Longrightarrow> (index xs x = n) = (x \<notin> set xs)"
 by(auto simp: index_def find_index_eq_size_conv)
 
 lemma size_index_conv: "size xs = n \<Longrightarrow> (n = index xs x) = (x \<notin> set xs)"
 by (metis index_size_conv)
 
 lemma last_index_size_conv:
   "size xs = n \<Longrightarrow> (last_index xs x = n) = (x \<notin> set xs)"
 apply(auto simp: last_index_def index_size_conv)
 apply(drule length_pos_if_in_set)
 apply arith
 done
 
 lemma size_last_index_conv:
   "size xs = n \<Longrightarrow> (n = last_index xs x) = (x \<notin> set xs)"
 by (metis last_index_size_conv)
 
 lemma find_index_less_size_conv:
   "(find_index P xs < size xs) = (\<exists>x \<in> set xs. P x)"
 by (induct xs) auto
 
 lemma index_less_size_conv:
   "(index xs x < size xs) = (x \<in> set xs)"
 by(auto simp: index_def find_index_less_size_conv)
 
 lemma last_index_less_size_conv:
   "(last_index xs x < size xs) = (x : set xs)"
 by(simp add: last_index_def Let_def index_size_conv length_pos_if_in_set
         del:length_greater_0_conv)
 
 lemma index_less[simp]:
   "x : set xs \<Longrightarrow> size xs <= n \<Longrightarrow> index xs x < n"
 apply(induct xs) apply auto
 apply (metis index_less_size_conv less_eq_Suc_le less_trans_Suc)
 done
 
 lemma last_index_less[simp]:
   "x : set xs \<Longrightarrow> size xs <= n \<Longrightarrow> last_index xs x < n"
 by(simp add: last_index_less_size_conv[symmetric])
 
 lemma last_index_Cons: "last_index (x#xs) y =
   (if x=y then
       if x \<in> set xs then last_index xs y + 1 else 0
    else last_index xs y + 1)"
 using index_le_size[of "rev xs" y]
 apply(auto simp add: last_index_def index_append Let_def)
 apply(simp add: index_size_conv)
 done
 
 lemma last_index_append: "last_index (xs @ ys) x =
   (if x : set ys then size xs + last_index ys x
    else if x : set xs then last_index xs x else size xs + size ys)"
 by (induct xs) (simp_all add: last_index_Cons last_index_size_conv)
 
 lemma last_index_Snoc[simp]:
   "last_index (xs @ [x]) y =
   (if x=y then size xs
    else if y : set xs then last_index xs y else size xs + 1)"
 by(simp add: last_index_append last_index_Cons)
 
 lemma nth_find_index: "find_index P xs < size xs \<Longrightarrow> P(xs ! find_index P xs)"
 by (induct xs) auto
 
 lemma nth_index[simp]: "x \<in> set xs \<Longrightarrow> xs ! index xs x = x"
 by (induct xs) auto
 
 lemma nth_last_index[simp]: "x \<in> set xs \<Longrightarrow> xs ! last_index xs x = x"
 by(simp add:last_index_def index_size_conv Let_def rev_nth[symmetric])
 
 lemma index_rev: "\<lbrakk> distinct xs; x \<in> set xs \<rbrakk> \<Longrightarrow>
   index (rev xs) x = length xs - index xs x - 1"
 by (induct xs) (auto simp: index_append)
 
 lemma index_nth_id:
   "\<lbrakk> distinct xs;  n < length xs \<rbrakk> \<Longrightarrow> index xs (xs ! n) = n"
 by (metis in_set_conv_nth index_less_size_conv nth_eq_iff_index_eq nth_index)
 
 lemma index_upt[simp]: "m \<le> i \<Longrightarrow> i < n \<Longrightarrow> index [m..<n] i = i-m"
 by (induction n) (auto simp add: index_append)
 
 lemma index_eq_index_conv[simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow>
   (index xs x = index xs y) = (x = y)"
 by (induct xs) auto
 
 lemma last_index_eq_index_conv[simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow>
   (last_index xs x = last_index xs y) = (x = y)"
 by (induct xs) (auto simp:last_index_Cons)
 
 lemma inj_on_index: "inj_on (index xs) (set xs)"
 by (simp add:inj_on_def)
 
 lemma inj_on_index2: "I \<subseteq> set xs \<Longrightarrow> inj_on (index xs) I"
 by (rule inj_onI) auto
 
 lemma inj_on_last_index: "inj_on (last_index xs) (set xs)"
 by (simp add:inj_on_def)
 
 lemma find_index_conv_takeWhile: 
   "find_index P xs = size(takeWhile (Not o P) xs)"
 by(induct xs) auto
 
 lemma index_conv_takeWhile: "index xs x = size(takeWhile (\<lambda>y. x\<noteq>y) xs)"
 by(induct xs) auto
 
 lemma find_index_first: "i < find_index P xs \<Longrightarrow> \<not>P (xs!i)"
 unfolding find_index_conv_takeWhile
 by (metis comp_apply nth_mem set_takeWhileD takeWhile_nth)
 
 lemma index_first: "i<index xs x \<Longrightarrow> x\<noteq>xs!i"
 using find_index_first unfolding index_def by blast
 
 lemma find_index_eqI:
   assumes "i\<le>length xs"  
   assumes "\<forall>j<i. \<not>P (xs!j)"
   assumes "i<length xs \<Longrightarrow> P (xs!i)"
   shows "find_index P xs = i"
 by (metis (mono_tags, lifting) antisym_conv2 assms find_index_eq_size_conv 
   find_index_first find_index_less_size_conv linorder_neqE_nat nth_find_index)
   
 lemma find_index_eq_iff:
   "find_index P xs = i 
   \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. \<not>P (xs!j)) \<and> (i<length xs \<longrightarrow> P (xs!i)))"  
 by (auto intro: find_index_eqI 
          simp: nth_find_index find_index_le_size find_index_first)
   
 lemma index_eqI:
   assumes "i\<le>length xs"  
   assumes "\<forall>j<i. xs!j \<noteq> x"
   assumes "i<length xs \<Longrightarrow> xs!i = x"
   shows "index xs x = i"
 unfolding index_def by (simp add: find_index_eqI assms)
   
 lemma index_eq_iff:
   "index xs x = i 
   \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. xs!j \<noteq> x) \<and> (i<length xs \<longrightarrow> xs!i = x))"  
 by (auto intro: index_eqI 
          simp: index_le_size index_less_size_conv 
          dest: index_first)
 
 lemma index_take: "index xs x >= i \<Longrightarrow> x \<notin> set(take i xs)"
 apply(subst (asm) index_conv_takeWhile)
 apply(subgoal_tac "set(take i xs) <= set(takeWhile ((\<noteq>) x) xs)")
  apply(blast dest: set_takeWhileD)
 apply(metis set_take_subset_set_take takeWhile_eq_take)
 done
 
 lemma last_index_drop:
   "last_index xs x < i \<Longrightarrow> x \<notin> set(drop i xs)"
 apply(subgoal_tac "set(drop i xs) = set(take (size xs - i) (rev xs))")
  apply(simp add: last_index_def index_take Let_def split:if_split_asm)
 apply (metis rev_drop set_rev)
 done
 
 lemma set_take_if_index: assumes "index xs x < i" and "i \<le> length xs"
 shows "x \<in> set (take i xs)"
 proof -
   have "index (take i xs @ drop i xs) x < i"
     using append_take_drop_id[of i xs] assms(1) by simp
   thus ?thesis using assms(2)
     by(simp add:index_append del:append_take_drop_id split: if_splits)
 qed
 
 lemma index_take_if_index:
 assumes "index xs x \<le> n" shows "index (take n xs) x = index xs x"
 proof cases
   assume "x : set(take n xs)" with assms show ?thesis
     by (metis append_take_drop_id index_append)
 next
   assume "x \<notin> set(take n xs)" with assms show ?thesis
    by (metis order_le_less set_take_if_index le_cases length_take min_def size_index_conv take_all)
 qed
 
 lemma index_take_if_set:
   "x : set(take n xs) \<Longrightarrow> index (take n xs) x = index xs x"
 by (metis index_take index_take_if_index linear)
 
 lemma index_last[simp]:
   "xs \<noteq> [] \<Longrightarrow> distinct xs \<Longrightarrow> index xs (last xs) = length xs - 1"
 by (induction xs) auto
 
 lemma index_update_if_diff2:
   "n < length xs \<Longrightarrow> x \<noteq> xs!n \<Longrightarrow> x \<noteq> y \<Longrightarrow> index (xs[n := y]) x = index xs x"
 by(subst (2) id_take_nth_drop[of n xs])
   (auto simp: upd_conv_take_nth_drop index_append min_def)
 
 lemma set_drop_if_index: "distinct xs \<Longrightarrow> index xs x < i \<Longrightarrow> x \<notin> set(drop i xs)"
 by (metis in_set_dropD index_nth_id last_index_drop last_index_less_size_conv nth_last_index)
 
 lemma index_swap_if_distinct: assumes "distinct xs" "i < size xs" "j < size xs"
 shows "index (xs[i := xs!j, j := xs!i]) x =
   (if x = xs!i then j else if x = xs!j then i else index xs x)"
 proof-
   have "distinct(xs[i := xs!j, j := xs!i])" using assms by simp
   with assms show ?thesis
     apply (auto simp: simp del: distinct_swap)
     apply (metis index_nth_id list_update_same_conv)
     apply (metis (erased, hide_lams) index_nth_id length_list_update list_update_swap nth_list_update_eq)
     apply (metis index_nth_id length_list_update nth_list_update_eq)
     by (metis index_update_if_diff2 length_list_update nth_list_update)
 qed
 
 lemma bij_betw_index:
   "distinct xs \<Longrightarrow> X = set xs \<Longrightarrow> l = size xs \<Longrightarrow> bij_betw (index xs) X {0..<l}"
 apply simp
 apply(rule bij_betw_imageI[OF inj_on_index])
 by (auto simp: image_def) (metis index_nth_id nth_mem)
 
 lemma index_image: "distinct xs \<Longrightarrow> set xs = X \<Longrightarrow> index xs ` X = {0..<size xs}"
 by (simp add: bij_betw_imp_surj_on bij_betw_index)
 
 lemma index_map_inj_on:
   "\<lbrakk> inj_on f S; y \<in> S; set xs \<subseteq> S \<rbrakk> \<Longrightarrow> index (map f xs) (f y) = index xs y"
 by (induct xs) (auto simp: inj_on_eq_iff)
 
 lemma index_map_inj: "inj f \<Longrightarrow> index (map f xs) (f y) = index xs y"
 by (simp add: index_map_inj_on[where S=UNIV])
 
 subsection \<open>Map with index\<close>
 
 primrec map_index' :: "nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
   "map_index' n f [] = []"
 | "map_index' n f (x#xs) = f n x # map_index' (Suc n) f xs"
 
 lemma length_map_index'[simp]: "length (map_index' n f xs) = length xs"
   by (induct xs arbitrary: n) auto
 
 lemma map_index'_map_zip: "map_index' n f xs = map (case_prod f) (zip [n ..< n + length xs] xs)"
 proof (induct xs arbitrary: n)
   case (Cons x xs)
   hence "map_index' n f (x#xs) = f n x # map (case_prod f) (zip [Suc n ..< n + length (x # xs)] xs)" by simp
   also have "\<dots> =  map (case_prod f) (zip (n # [Suc n ..< n + length (x # xs)]) (x # xs))" by simp
   also have "(n # [Suc n ..< n + length (x # xs)]) = [n ..< n + length (x # xs)]" by (induct xs) auto
   finally show ?case by simp
 qed simp
 
 abbreviation "map_index \<equiv> map_index' 0"
 
 lemmas map_index = map_index'_map_zip[of 0, simplified]
 
 lemma take_map_index: "take p (map_index f xs) = map_index f (take p xs)"
   unfolding map_index by (auto simp: min_def take_map take_zip)
 
 lemma drop_map_index: "drop p (map_index f xs) = map_index' p f (drop p xs)"
   unfolding map_index'_map_zip by (cases "p < length xs") (auto simp: drop_map drop_zip)
 
 lemma map_map_index[simp]: "map g (map_index f xs) = map_index (\<lambda>n x. g (f n x)) xs"
   unfolding map_index by auto
 
 lemma map_index_map[simp]: "map_index f (map g xs) = map_index (\<lambda>n x. f n (g x)) xs"
   unfolding map_index by (auto simp: map_zip_map2)
 
 lemma set_map_index[simp]: "x \<in> set (map_index f xs) = (\<exists>i < length xs. f i (xs ! i) = x)"
   unfolding map_index by (auto simp: set_zip intro!: image_eqI[of _ "case_prod f"])
 
 lemma set_map_index'[simp]: "x\<in>set (map_index' n f xs)
   \<longleftrightarrow> (\<exists>i<length xs. f (n+i) (xs!i) = x) "
   unfolding map_index'_map_zip
   by (auto simp: set_zip intro!: image_eqI[of _ "case_prod f"])
 
 lemma nth_map_index[simp]: "p < length xs \<Longrightarrow> map_index f xs ! p = f p (xs ! p)"
   unfolding map_index by auto
 
 lemma map_index_cong:
   "\<forall>p < length xs. f p (xs ! p) = g p (xs ! p) \<Longrightarrow> map_index f xs = map_index g xs"
   unfolding map_index by (auto simp: set_zip)
 
 lemma map_index_id: "map_index (curry snd) xs = xs"
   unfolding map_index by auto
 
 lemma map_index_no_index[simp]: "map_index (\<lambda>n x. f x) xs = map f xs"
   unfolding map_index by (induct xs rule: rev_induct) auto
 
 lemma map_index_congL:
   "\<forall>p < length xs. f p (xs ! p) = xs ! p \<Longrightarrow> map_index f xs = xs"
   by (rule trans[OF map_index_cong map_index_id]) auto
 
 lemma map_index'_is_NilD: "map_index' n f xs = [] \<Longrightarrow> xs = []"
   by (induct xs) auto
 
 declare map_index'_is_NilD[of 0, dest!]
 
 lemma map_index'_is_ConsD:
   "map_index' n f xs = y # ys \<Longrightarrow> \<exists>z zs. xs = z # zs \<and> f n z = y \<and> map_index' (n + 1) f zs = ys"
   by (induct xs arbitrary: n) auto
 
 lemma map_index'_eq_imp_length_eq: "map_index' n f xs = map_index' n g ys \<Longrightarrow> length xs = length ys"
 proof (induct ys arbitrary: xs n)
   case (Cons y ys) thus ?case by (cases xs) auto
 qed (auto dest!: map_index'_is_NilD)
 
 lemmas map_index_eq_imp_length_eq = map_index'_eq_imp_length_eq[of 0]
 
 lemma map_index'_comp[simp]: "map_index' n f (map_index' n g xs) = map_index' n (\<lambda>n. f n o g n) xs"
   by (induct xs arbitrary: n) auto
 
 lemma map_index'_append[simp]: "map_index' n f (a @ b)
   = map_index' n f a @ map_index' (n + length a) f b"
   by (induct a arbitrary: n) auto
 
 lemma map_index_append[simp]: "map_index f (a @ b)
   = map_index f a @ map_index' (length a) f b"
   using map_index'_append[where n=0]
   by (simp del: map_index'_append)
 
 
 subsection \<open>Insert at position\<close>
 
 primrec insert_nth :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "insert_nth 0 x xs = x # xs"
 | "insert_nth (Suc n) x xs = (case xs of [] \<Rightarrow> [x] | y # ys \<Rightarrow> y # insert_nth n x ys)"
 
 lemma insert_nth_take_drop[simp]: "insert_nth n x xs = take n xs @ [x] @ drop n xs"
 proof (induct n arbitrary: xs)
   case Suc thus ?case by (cases xs) auto
 qed simp
 
 lemma length_insert_nth: "length (insert_nth n x xs) = Suc (length xs)"
   by (induct xs) auto
 
 lemma set_insert_nth:
   "set (insert_nth i x xs) = insert x (set xs)"
 by (simp add: set_append[symmetric])
 
 lemma distinct_insert_nth:
   assumes "distinct xs"
   assumes "x \<notin> set xs"
   shows "distinct (insert_nth i x xs)"
 using assms proof (induct xs arbitrary: i)
   case Nil
   then show ?case by (cases i) auto
 next
   case (Cons a xs)
   then show ?case
     by (cases i) (auto simp add: set_insert_nth simp del: insert_nth_take_drop)
 qed
 
 lemma nth_insert_nth_front:
   assumes "i < j" "j \<le> length xs"
   shows "insert_nth j x xs ! i = xs ! i"
 using assms by (simp add: nth_append)
 
 lemma nth_insert_nth_index_eq:
   assumes "i \<le> length xs"
   shows "insert_nth i x xs ! i = x"
 using assms by (simp add: nth_append)
 
 lemma nth_insert_nth_back:
   assumes "j < i" "i \<le> length xs"
   shows "insert_nth j x xs ! i = xs ! (i - 1)"
 using assms by (cases i) (auto simp add: nth_append min_def)
 
 lemma nth_insert_nth:
   assumes "i \<le> length xs" "j \<le> length xs"
   shows "insert_nth j x xs ! i = (if i = j then x else if i < j then xs ! i else xs ! (i - 1))"
 using assms by (simp add: nth_insert_nth_front nth_insert_nth_index_eq nth_insert_nth_back del: insert_nth_take_drop)
 
 lemma insert_nth_inverse:
   assumes "j \<le> length xs" "j' \<le> length xs'"
   assumes "x \<notin> set xs" "x \<notin> set xs'"
   assumes "insert_nth j x xs = insert_nth j' x xs'"
   shows "j = j'"
 proof -
   from assms(1,3) have "\<forall>i\<le>length xs. insert_nth j x xs ! i = x \<longleftrightarrow> i = j"
     by (auto simp add: nth_insert_nth simp del: insert_nth_take_drop)
   moreover from assms(2,4) have "\<forall>i\<le>length xs'. insert_nth j' x xs' ! i = x \<longleftrightarrow> i = j'"
     by (auto simp add: nth_insert_nth simp del: insert_nth_take_drop)
   ultimately show "j = j'"
     using assms(1,2,5) by (metis dual_order.trans nat_le_linear)
 qed
 
 text \<open>Insert several elements at given (ascending) positions\<close>
 
 lemma length_fold_insert_nth:
   "length (fold (\<lambda>(p, b). insert_nth p b) pxs xs) = length xs + length pxs"
   by (induct pxs arbitrary: xs) auto
 
 lemma invar_fold_insert_nth:
   "\<lbrakk>\<forall>x\<in>set pxs. p < fst x; p < length xs; xs ! p = b\<rbrakk> \<Longrightarrow>
     fold (\<lambda>(x, y). insert_nth x y) pxs xs ! p = b"
   by (induct pxs arbitrary: xs) (auto simp: nth_append)
 
 lemma nth_fold_insert_nth:
   "\<lbrakk>sorted (map fst pxs); distinct (map fst pxs); \<forall>(p, b) \<in> set pxs. p < length xs + length pxs;
     i < length pxs; pxs ! i = (p, b)\<rbrakk> \<Longrightarrow>
   fold (\<lambda>(p, b). insert_nth p b) pxs xs ! p = b"
 proof (induct pxs arbitrary: xs i p b)
   case (Cons pb pxs)
   show ?case
   proof (cases i)
     case 0
     with Cons.prems have "p < Suc (length xs)"
     proof (induct pxs rule: rev_induct)
       case (snoc pb' pxs)
       then obtain p' b' where "pb' = (p', b')" by auto
       with snoc.prems have "\<forall>p \<in> fst ` set pxs. p < p'" "p' \<le> Suc (length xs + length pxs)"
-        by (auto simp: image_iff sorted_append le_eq_less_or_eq)
+        by (auto simp: image_iff sorted_wrt_append le_eq_less_or_eq)
       with snoc.prems show ?case by (intro snoc(1)) (auto simp: sorted_append)
     qed auto
     with 0 Cons.prems show ?thesis unfolding fold.simps o_apply
     by (intro invar_fold_insert_nth) (auto simp: image_iff le_eq_less_or_eq nth_append)
   next
     case (Suc n) with Cons.prems show ?thesis unfolding fold.simps
       by (auto intro!: Cons(1))
   qed
 qed simp
 
 subsection \<open>Remove at position\<close>
 
 fun remove_nth :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "remove_nth i [] = []"
 | "remove_nth 0 (x # xs) = xs"
 | "remove_nth (Suc i) (x # xs) = x # remove_nth i xs"
 
 lemma remove_nth_take_drop:
   "remove_nth i xs = take i xs @ drop (Suc i) xs"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case by (cases i) auto
 qed
 
 lemma remove_nth_insert_nth:
   assumes "i \<le> length xs"
   shows "remove_nth i (insert_nth i x xs) = xs"
 using assms proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case by (cases i) auto
 qed
 
 lemma insert_nth_remove_nth:
   assumes "i < length xs"
   shows "insert_nth i (xs ! i) (remove_nth i xs) = xs"
 using assms proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case by (cases i) auto
 qed
 
 lemma length_remove_nth:
   assumes "i < length xs"
   shows "length (remove_nth i xs) = length xs - 1"
 using assms unfolding remove_nth_take_drop by simp
 
 lemma set_remove_nth_subset:
   "set (remove_nth j xs) \<subseteq> set xs"
 proof (induct xs arbitrary: j)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case by (cases j) auto
 qed
 
 lemma set_remove_nth:
   assumes "distinct xs" "j < length xs"
   shows "set (remove_nth j xs) = set xs - {xs ! j}"
 using assms proof (induct xs arbitrary: j)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case by (cases j) auto
 qed
 
 lemma distinct_remove_nth:
   assumes "distinct xs"
   shows "distinct (remove_nth i xs)"
 using assms proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case (Cons a xs)
   then show ?case
     by (cases i) (auto simp add: set_remove_nth_subset rev_subsetD)
 qed
 
 end
diff --git a/thys/List_Inversions/List_Inversions.thy b/thys/List_Inversions/List_Inversions.thy
--- a/thys/List_Inversions/List_Inversions.thy
+++ b/thys/List_Inversions/List_Inversions.thy
@@ -1,445 +1,444 @@
 (*
   File:     List_Inversions.thy
   Author:   Manuel Eberl, TU München
 
   A formalisation of inversions of a list and the O(n log n) divide-and-conquer algorithm
   to count them.
 *)
 section \<open>The Inversions of a List\<close>
 theory List_Inversions
 imports
   Main
   "HOL-Combinatorics.Permutations"
 begin
 
 subsection \<open>Definition of inversions\<close>
 
 context preorder
 begin
 
 text \<open>
   We define inversions as pair of indices w.\,r.\,t.\ a preorder.
 \<close>
 inductive_set inversions :: "'a list \<Rightarrow> (nat \<times> nat) set" for xs :: "'a list" where
   "i < j \<Longrightarrow> j < length xs \<Longrightarrow> less (xs ! j) (xs ! i) \<Longrightarrow> (i, j) \<in> inversions xs"
 
 lemma inversions_subset: "inversions xs \<subseteq> Sigma {..<length xs} (\<lambda>i. {i<..<length xs})"
   by (auto simp: inversions.simps)
 
 lemma finite_inversions [intro]: "finite (inversions xs)"
   by (rule finite_subset[OF inversions_subset]) auto
 
 lemma inversions_altdef: "inversions xs = {(i, j). i < j \<and> j < length xs \<and> less (xs ! j) (xs ! i)}"
   by (auto simp: inversions.simps)
 
 lemma inversions_code:
   "inversions xs =
      Sigma {..<length xs} (\<lambda>i. Set.filter (\<lambda>j. less (xs ! j) (xs ! i)) {i<..<length xs})"
   by (auto simp: inversions_altdef)
 
 lemmas (in -) [code] = inversions_code
 
 lemma inversions_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversions xs = {}"
   by (auto simp: inversions_altdef)
 
 lemma inversions_imp_less:
   "z \<in> inversions xs \<Longrightarrow> fst z < snd z"
   "z \<in> inversions xs \<Longrightarrow> snd z < length xs"
   by (auto simp: inversions_altdef)
 
 lemma inversions_Nil [simp]: "inversions [] = {}"
   by (auto simp: inversions_altdef)
 
 lemma inversions_Cons:
   "inversions (x # xs) =
      (\<lambda>j. (0, j + 1)) ` {j\<in>{..<length xs}. less (xs ! j) x} \<union>
      map_prod Suc Suc ` inversions xs" (is "_ = ?rhs")
 proof -
   have "z \<in> inversions (x # xs) \<longleftrightarrow> z \<in> ?rhs" for z
     by (cases z) (auto simp: inversions_altdef map_prod_def nth_Cons split: nat.splits)
   thus ?thesis by blast
 qed
 
 
 text \<open>
   The following function returns the inversions between two lists, i.\,e.\ all pairs of
   an element in the first list with an element in the second list such that the former
   is greater than the latter.
 \<close>
 definition inversions_between :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat \<times> nat) set" where
   "inversions_between xs ys =
      {(i, j) \<in> {..<length xs}\<times>{..<length ys}. less (ys ! j) (xs ! i)}"
 
 lemma finite_inversions_between [intro]: "finite (inversions_between xs ys)"
     by (rule finite_subset[of _ "{..<length xs} \<times> {..<length xs + length ys}"])
        (auto simp: inversions_between_def)
 
 lemma inversions_between_Nil [simp]:
   "inversions_between [] ys = {}"
   "inversions_between xs [] = {}"
   by (simp_all add: inversions_between_def)
 
 text \<open>
   We can now show the following equality for the inversions of the concatenation of two lists:
 \<close>
 proposition inversions_append:
   fixes xs ys
   defines "m \<equiv> length xs" and "n \<equiv> length ys"
   shows "inversions (xs @ ys) =
            inversions xs \<union> map_prod ((+) m) ((+) m) ` inversions ys \<union>
            map_prod id ((+) m) ` inversions_between xs ys"
         (is "_ = ?rhs")
 proof -
   note defs = inversions_altdef inversions_between_def m_def n_def map_prod_def
   have "z \<in> inversions (xs @ ys) \<longleftrightarrow> z \<in> ?rhs" for z
   proof
     assume "z \<in> inversions (xs @ ys)"
     then obtain i j where [simp]: "z = (i, j)"
                       and ij: "i < j" "j < m + n" "less ((xs @ ys) ! j) ((xs @ ys) ! i)"
       by (cases z) (auto simp: inversions_altdef m_def n_def)
     from ij consider "j < m" | "i \<ge> m" | "i < m" "j \<ge> m" by linarith
     thus "z \<in> ?rhs"
     proof cases
       assume "i < m" "j \<ge> m"
       define j' where "j' = j - m"
       have [simp]: "j = m + j'"
         using \<open>j \<ge> m\<close> by (simp add: j'_def)
       from ij and \<open>i < m\<close> show ?thesis
         by (auto simp: inversions_altdef map_prod_def inversions_between_def nth_append m_def n_def)
     next
       assume "i \<ge> m"
       define i' j' where "i' = i - m" and "j' = j - m"
       have [simp]: "i = m + i'" "j = m + j'"
         using \<open>i < j\<close> and \<open>i \<ge> m\<close> by (simp_all add: i'_def j'_def)
       from ij show ?thesis
         by (auto simp: inversions_altdef map_prod_def nth_append m_def n_def)
     qed (use ij in \<open>auto simp: nth_append defs\<close>)
   qed (auto simp: nth_append defs)
   thus ?thesis by blast
 qed
 
 
 subsection \<open>Counting inversions\<close>
 
 text \<open>
   We now define versions of @{const inversions} and @{const inversions_between} that
   only return the \<^emph>\<open>number\<close> of inversions.
 \<close>
 definition inversion_number :: "'a list \<Rightarrow> nat" where
   "inversion_number xs = card (inversions xs)"
 
 definition inversion_number_between where
   "inversion_number_between xs ys = card (inversions_between xs ys)"
 
 lemma inversions_between_code:
   "inversions_between xs ys =
      Set.filter (\<lambda>(i,j). less (ys ! j) (xs ! i)) ({..<length xs}\<times>{..<length ys})"
   by (auto simp: inversions_between_def)
 
 lemmas (in -) [code] = inversions_between_code
 
 lemma inversion_number_Nil [simp]: "inversion_number [] = 0"
   by (simp add: inversion_number_def)
 
 lemma inversion_number_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversion_number xs = 0"
   by (auto simp: inversion_number_def)
 
 lemma inversion_number_between_Nil [simp]:
   "inversion_number_between [] ys = 0"
   "inversion_number_between xs [] = 0"
   by (simp_all add: inversion_number_between_def)
 
 text \<open>
   We again get the following nice equation for the number of inversions of a concatenation:
 \<close>
 proposition inversion_number_append:
   "inversion_number (xs @ ys) =
      inversion_number xs + inversion_number ys + inversion_number_between xs ys"
 proof -
   define m n where "m = length xs" and "n = length ys"
   let ?A = "inversions xs"
   let ?B = "map_prod ((+) m) ((+) m) ` inversions ys"
   let ?C = "map_prod id ((+) m) ` inversions_between xs ys"
 
   have "inversion_number (xs @ ys) = card (?A \<union> ?B \<union> ?C)"
     by (simp add: inversion_number_def inversions_append m_def)
   also have "\<dots> = card (?A \<union> ?B) + card ?C"
     by (intro card_Un_disjoint finite_inversions finite_inversions_between finite_UnI finite_imageI)
        (auto simp: inversions_altdef inversions_between_def m_def n_def)
   also have "card (?A \<union> ?B) = inversion_number xs + card ?B" unfolding inversion_number_def
     by (intro card_Un_disjoint finite_inversions finite_UnI finite_imageI)
        (auto simp: inversions_altdef m_def n_def)
   also have "card ?B = inversion_number ys" unfolding inversion_number_def
     by (intro card_image) (auto simp: map_prod_def inj_on_def)
   also have "card ?C = inversion_number_between xs ys"
     unfolding inversion_number_between_def by (intro card_image inj_onI) (auto simp: map_prod_def)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Stability of inversions between lists under permutations\<close>
 
 text \<open>
   A crucial fact for counting list inversions with merge sort is that the number
   of inversions \<^emph>\<open>between\<close> two lists does not change when the lists are permuted. This is
   true because the set of inversions commutes with the act of permuting the list:
 \<close>
 lemma inversions_between_permute1:
   assumes "\<pi> permutes {..<length xs}"
   shows   "inversions_between (permute_list \<pi> xs) ys =
              map_prod (inv \<pi>) id ` inversions_between xs ys"
 proof -
   from assms have [simp]: "\<pi> i < length xs" if "i < length xs" "\<pi> permutes {..<length xs}" for i \<pi>
     using permutes_in_image[OF that(2)] that by auto
   have *: "inv \<pi> permutes {..<length xs}"
     using assms by (rule permutes_inv)
   from assms * show ?thesis unfolding inversions_between_def map_prod_def
     by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
 qed
 
 lemma inversions_between_permute2:
   assumes "\<pi> permutes {..<length ys}"
   shows   "inversions_between xs (permute_list \<pi> ys) =
              map_prod id (inv \<pi>) ` inversions_between xs ys"
 proof -
   from assms have [simp]: "\<pi> i < length ys" if "i < length ys" "\<pi> permutes {..<length ys}" for i \<pi>
     using permutes_in_image[OF that(2)] that by auto
   have *: "inv \<pi> permutes {..<length ys}"
     using assms by (rule permutes_inv)
   from assms * show ?thesis unfolding inversions_between_def map_prod_def
     by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
 qed
 
 proposition inversions_between_permute:
   assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
   shows   "inversions_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
              map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys"
   by (simp add: inversions_between_permute1 inversions_between_permute2 assms
                 map_prod_def image_image case_prod_unfold)
 
 corollary inversion_number_between_permute:
   assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
   shows   "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
              inversion_number_between xs ys"
 proof -
   have "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
           card (map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys)"
     by (simp add: inversion_number_between_def inversions_between_permute assms)
   also have "\<dots> = inversion_number_between xs ys"
     unfolding inversion_number_between_def using assms[THEN permutes_inj_on[OF permutes_inv]]
     by (intro card_image inj_onI) (auto simp: map_prod_def)
   finally show ?thesis .
 qed
 
 text \<open>
   The following form of the above theorem is nicer to apply since it has the form of a 
   congruence rule.
 \<close>
 corollary inversion_number_between_cong_mset:
   assumes "mset xs = mset xs'" and "mset ys = mset ys'"
   shows   "inversion_number_between xs ys = inversion_number_between xs' ys'"
 proof -
   obtain \<pi>1 \<pi>2 where \<pi>12: "\<pi>1 permutes {..<length xs'}" "xs = permute_list \<pi>1 xs'"
                           "\<pi>2 permutes {..<length ys'}" "ys = permute_list \<pi>2 ys'"
     using assms[THEN mset_eq_permutation] by metis
   thus ?thesis by (simp add: inversion_number_between_permute)
 qed
 
 
 subsection \<open>Inversions between sorted lists\<close>
 
 text \<open>
   Another fact that is crucial to the efficient computation of the inversion number is this:
   If we have two sorted lists, we can reduce computing the inversions by inspecting the 
   first elements and deleting one of them.
 \<close>
 lemma inversions_between_Cons_Cons:
   assumes "sorted_wrt less_eq (x # xs)" and "sorted_wrt less_eq (y # ys)"
   shows   "inversions_between (x # xs) (y # ys) =
              (if \<not>less y x then
                 map_prod Suc id ` inversions_between xs (y # ys)
               else
                 {..<length (x#xs)} \<times> {0} \<union>
                 map_prod id Suc ` inversions_between (x # xs) ys)"
   using assms  unfolding inversions_between_def map_prod_def
   by (auto, (auto simp: set_conv_nth nth_Cons less_le_not_le image_iff 
                   intro: order_trans split: nat.splits)?)
   (* A bit fragile, but doing this manually is annoying *)
 
 text \<open>
   This leads to the following analogous equation for counting the inversions between two
   sorted lists. Note that a single step of this only takes constant time (assuming we 
   pre-computed the lengths of the lists) so that the entire function runs in linear time.
 \<close>
 lemma inversion_number_between_Cons_Cons:
   assumes "sorted_wrt less_eq (x # xs)" and "sorted_wrt less_eq (y # ys)"
   shows   "inversion_number_between (x # xs) (y # ys) =
              (if \<not>less y x then
                 inversion_number_between xs (y # ys)
               else
                 inversion_number_between (x # xs) ys + length (x # xs))"
 proof (cases "less y x")
   case False
   hence "inversion_number_between (x # xs) (y # ys) = 
            card (map_prod Suc id ` inversions_between xs (y # ys))"
     by (simp add: inversion_number_between_def inversions_between_Cons_Cons[OF assms])
   also have "\<dots> = inversion_number_between xs (y # ys)"
     unfolding inversion_number_between_def by (intro card_image inj_onI) (auto simp: map_prod_def)
   finally show ?thesis using False by simp
 next
   case True
   hence "inversion_number_between (x # xs) (y # ys) =
            card ({..<length (x # xs)} \<times> {0} \<union> map_prod id Suc ` inversions_between (x # xs) ys)"
     by (simp add: inversion_number_between_def inversions_between_Cons_Cons[OF assms])
   also have "\<dots> = length (x # xs) + card (map_prod id Suc ` inversions_between (x # xs) ys)"
     by (subst card_Un_disjoint) auto
   also have "card (map_prod id Suc ` inversions_between (x # xs) ys) =
                inversion_number_between (x # xs) ys"
     unfolding inversion_number_between_def by (intro card_image inj_onI) (auto simp: map_prod_def)
   finally show ?thesis using True by simp
 qed
 
 text \<open>
   We now define a function to compute the inversion number between two lists that are
   assumed to be sorted using the equalities we just derived.
 \<close>
 fun inversion_number_between_sorted :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
   "inversion_number_between_sorted [] ys = 0"
 | "inversion_number_between_sorted xs [] = 0"
 | "inversion_number_between_sorted (x # xs) (y # ys) =
              (if \<not>less y x then
                 inversion_number_between_sorted xs (y # ys)
               else
                 inversion_number_between_sorted (x # xs) ys + length (x # xs))"
 
 theorem inversion_number_between_sorted_correct:
   "sorted_wrt less_eq xs \<Longrightarrow> sorted_wrt less_eq ys \<Longrightarrow>
      inversion_number_between_sorted xs ys = inversion_number_between xs ys"
   by (induction xs ys rule: inversion_number_between_sorted.induct)
      (simp_all add: inversion_number_between_Cons_Cons)
 
 end
 
 
 subsection \<open>Merge sort\<close>
 
 (* TODO: Could be replaced by mergesort from HOL-Library in Isabelle 2019. *)
 text \<open>
   For convenience, we first define a simple merge sort that does not compute the inversions.
   At this point, we need to start assuming a linear ordering since the merging function
   does not work otherwise.
 \<close>
 
 context linorder
 begin
 
 definition split_list
   where "split_list xs = (let n = length xs div 2 in (take n xs, drop n xs))"
 
 fun merge_lists :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "merge_lists [] ys = ys"
 | "merge_lists xs [] = xs"
 | "merge_lists (x # xs) (y # ys) =
     (if less_eq x y then x # merge_lists xs (y # ys) else y # merge_lists (x # xs) ys)"
 
 lemma set_merge_lists [simp]: "set (merge_lists xs ys) = set xs \<union> set ys"
   by (induction xs ys rule: merge_lists.induct) auto
 
 lemma mset_merge_lists [simp]: "mset (merge_lists xs ys) = mset xs + mset ys"
   by (induction xs ys rule: merge_lists.induct) auto
 
 lemma sorted_merge_lists [simp, intro]:
   "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (merge_lists xs ys)"
   by (induction xs ys rule: merge_lists.induct) auto
 
 
 fun merge_sort :: "'a list \<Rightarrow> 'a list" where
   "merge_sort xs =
     (if length xs \<le> 1 then
        xs 
      else
        merge_lists (merge_sort (take (length xs div 2) xs))
                    (merge_sort (drop (length xs div 2) xs)))"
 
 lemmas [simp del] = merge_sort.simps
 
 lemma merge_sort_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> merge_sort xs = xs"
   by (subst merge_sort.simps) auto
 
 theorem mset_merge_sort [simp]: "mset (merge_sort xs) = mset xs"
   by (induction xs rule: merge_sort.induct)
      (subst merge_sort.simps, auto simp flip: mset_append)
 
 corollary set_merge_sort [simp]: "set (merge_sort xs) = set xs"
   by (rule mset_eq_setD) simp_all
 
 theorem sorted_merge_sort [simp, intro]: "sorted (merge_sort xs)"
   by (induction xs rule: merge_sort.induct)
      (subst merge_sort.simps, use sorted01 in auto)
 
 lemma inversion_number_between_code:
   "inversion_number_between xs ys = inversion_number_between_sorted (sort xs) (sort ys)"
   by (subst inversion_number_between_sorted_correct)
-     (simp_all add: sorted_sorted_wrt [symmetric] cong: inversion_number_between_cong_mset)
+     (simp_all add: cong: inversion_number_between_cong_mset)
 
 lemmas (in -) [code_unfold] = inversion_number_between_code
 
 
 subsection \<open>Merge sort with inversion counting\<close>
 
 text \<open>
   Finally, we can put together all the components and define a variant of merge sort that
   counts the number of inversions in the original list:
 \<close>
 function sort_and_count_inversions :: "'a list \<Rightarrow> 'a list \<times> nat" where
   "sort_and_count_inversions xs =
      (if length xs \<le> 1 then
         (xs, 0)
       else
         let (xs1, xs2) = split_list xs;
             (xs1', m) = sort_and_count_inversions xs1;
             (xs2', n) = sort_and_count_inversions xs2
         in
             (merge_lists xs1' xs2', m + n + inversion_number_between_sorted xs1' xs2'))"
   by auto
 termination by (relation "measure length") (auto simp: split_list_def Let_def)
 
 lemmas [simp del] = sort_and_count_inversions.simps
 
 
 text \<open>
   The projection of this function to the first component is simply the standard merge sort
   algorithm that we defined and proved correct before.
 \<close>
 theorem fst_sort_and_count_inversions [simp]:
   "fst (sort_and_count_inversions xs) = merge_sort xs"
   by (induction xs rule: length_induct)
      (subst sort_and_count_inversions.simps, subst merge_sort.simps,
       simp_all add: split_list_def case_prod_unfold Let_def)
 
 text \<open>
   The projection to the second component is the inversion number.
 \<close>
 theorem snd_sort_and_count_inversions [simp]:
   "snd (sort_and_count_inversions xs) = inversion_number xs"
 proof (induction xs rule: length_induct)
   case (1 xs)
   show ?case
   proof (cases "length xs \<le> 1")
     case False
     have "xs = take (length xs div 2) xs @ drop (length xs div 2) xs" by simp
     also have "inversion_number \<dots> = snd (sort_and_count_inversions xs)"
       by (subst inversion_number_append, subst sort_and_count_inversions.simps)
          (use False 1 in \<open>auto simp: Let_def split_list_def case_prod_unfold 
                                      inversion_number_between_sorted_correct
-                                     sorted_sorted_wrt [symmetric]
                                cong: inversion_number_between_cong_mset\<close>)
     finally show ?thesis ..
   qed (auto simp: sort_and_count_inversions.simps)
 qed
 
 lemmas (in -) [code_unfold] = snd_sort_and_count_inversions [symmetric]
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Polynomial_Factorization/Prime_Factorization.thy b/thys/Polynomial_Factorization/Prime_Factorization.thy
--- a/thys/Polynomial_Factorization/Prime_Factorization.thy
+++ b/thys/Polynomial_Factorization/Prime_Factorization.thy
@@ -1,801 +1,801 @@
 (*  
     Author:      René Thiemann 
                  Akihisa Yamada
     License:     BSD
 *)
 section \<open>Prime Factorization\<close>
 
 text \<open>This theory contains not-completely naive algorithms to test primality
   and to perform prime factorization. More precisely, it corresponds to prime factorization
   algorithm A in Knuth's textbook \cite{Knuth}.\<close>
 
 theory Prime_Factorization
 imports
   "HOL-Computational_Algebra.Primes"
   Missing_List
   Missing_Multiset
 begin
 
 subsection \<open>Definitions\<close>
 
 definition primes_1000 :: "nat list" where
   "primes_1000 = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97, 101,
   103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, 179, 181, 191, 193, 197, 199,
   211, 223, 227, 229, 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, 283, 293, 307, 311, 313, 317,
   331, 337, 347, 349, 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, 419, 421, 431, 433, 439, 443,
   449, 457, 461, 463, 467, 479, 487, 491, 499, 503, 509, 521, 523, 541, 547, 557, 563, 569, 571, 577,
   587, 593, 599, 601, 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, 661, 673, 677, 683, 691, 701,
   709, 719, 727, 733, 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, 811, 821, 823, 827, 829, 839,
   853, 857, 859, 863, 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, 947, 953, 967, 971, 977, 983,
   991, 997]"
 
 lemma primes_1000: "primes_1000 = filter prime [0..<1001]"
   by eval
 
 definition next_candidates :: "nat \<Rightarrow> nat \<times> nat list" where
   "next_candidates n = (if n = 0 then (1001,primes_1000) else (n + 30, 
     [n,n+2,n+6,n+8,n+12,n+18,n+20,n+26]))"
 
 definition "candidate_invariant n = (n = 0 \<or> n mod 30 = (11 :: nat))"
 
 partial_function (tailrec) remove_prime_factor :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<times> nat list " where
   [code]: "remove_prime_factor p n ps = (case Divides.divmod_nat n p of (n',m) \<Rightarrow> 
      if m = 0 then remove_prime_factor p n' (p # ps) else (n,ps))" 
   
 partial_function (tailrec) prime_factorization_nat_main 
   :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
   [code]: "prime_factorization_nat_main n j is ps = (case is of 
      [] \<Rightarrow> 
        (case next_candidates j of (j,is) \<Rightarrow> prime_factorization_nat_main n j is ps)
    | (i # is) \<Rightarrow> (case Divides.divmod_nat n i of (n',m) \<Rightarrow> 
        if m = 0 then case remove_prime_factor i n' (i # ps)
        of (n',ps') \<Rightarrow> if n' = 1 then ps' else 
          prime_factorization_nat_main n' j is ps'
        else if i * i \<le> n then prime_factorization_nat_main n j is ps
        else (n # ps)))"
 
 partial_function (tailrec) prime_nat_main 
   :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool" where
   [code]: "prime_nat_main n j is = (case is of 
     [] \<Rightarrow> (case next_candidates j of (j,is) \<Rightarrow> prime_nat_main n j is)
   | (i # is) \<Rightarrow> (if i dvd n then i \<ge> n else if i * i \<le> n then prime_nat_main n j is
     else True))"
 
 definition prime_nat :: "nat \<Rightarrow> bool" where
   "prime_nat n \<equiv> if n < 2 then False else \<comment> \<open>TODO: integrate precomputed map\<close>
      case next_candidates 0 of (j,is) \<Rightarrow> prime_nat_main n j is"
 
 definition prime_factorization_nat :: "nat \<Rightarrow> nat list" where
   "prime_factorization_nat n \<equiv> rev (if n < 2 then [] else 
     case next_candidates 0 of (j,is) \<Rightarrow> prime_factorization_nat_main n j is [])"
 
 definition divisors_nat :: "nat \<Rightarrow> nat list" where 
   "divisors_nat n \<equiv> if n = 0 then [] else 
      remdups_adj (sort (map prod_list (subseqs (prime_factorization_nat n))))"
 
 definition divisors_int_pos :: "int \<Rightarrow> int list" where
   "divisors_int_pos x \<equiv> map int (divisors_nat (nat (abs x)))"
 
 definition divisors_int :: "int \<Rightarrow> int list" where
   "divisors_int x \<equiv> let xs = divisors_int_pos x in xs @ (map uminus xs)"
 
 subsection \<open>Proofs\<close>
 
 lemma remove_prime_factor: assumes res: "remove_prime_factor i n ps = (m,qs)"
   and i: "i > 1"
   and n: "n \<noteq> 0"
   shows "\<exists> rs. qs = rs @ ps \<and> n = m * prod_list rs \<and> \<not> i dvd m \<and> set rs \<subseteq> {i}"
   using res n
 proof (induct n arbitrary: ps rule: less_induct)
   case (less n ps)
   obtain n' mo where dm: "Divides.divmod_nat n i = (n',mo)" by force
   hence n': "n' = n div i" and mo: "mo = n mod i" by (auto simp: divmod_nat_def)
   from less(2)[unfolded remove_prime_factor.simps[of i n] dm]
   have res: "(if mo = 0 then remove_prime_factor i n' (i # ps) else (n, ps)) = (m, qs)" by auto
   from less(3) have n: "n \<noteq> 0" by auto
   with n' i have "n' < n" by auto
   note IH = less(1)[OF this]
   show ?case
   proof (cases "mo = 0")
     case True
     with mo n' have n: "n = n' * i" by auto
     with \<open>n \<noteq> 0\<close> have n': "n' \<noteq> 0" by auto
     from True res have "remove_prime_factor i n' (i # ps) = (m,qs)" by auto
     from IH[OF this n'] obtain rs where 
       "qs = rs @ i # ps" and "n' = m * prod_list rs \<and> \<not> i dvd m \<and> set rs \<subseteq> {i}" by auto
     thus ?thesis
       by (intro exI[of _ "rs @ [i]"], unfold n, auto)
   next
     case False
     with mo have i_n: "\<not> i dvd n" by auto
     from False res have id: "m = n" "qs = ps" by auto
     show ?thesis unfolding id using i_n by auto
   qed
 qed 
 
 lemma prime_sqrtI: assumes n: "n \<ge> 2" 
   and small: "\<And> j. 2 \<le> j \<Longrightarrow> j < i \<Longrightarrow> \<not> j dvd n"
   and i: "\<not> i * i \<le> n"
   shows "prime (n::nat)" unfolding prime_nat_iff
 proof (intro conjI impI allI)
   show "1 < n" using n by auto
   fix j
   assume jn: "j dvd n" 
   from jn obtain k where njk: "n = j * k" unfolding dvd_def by auto
   with \<open>1 < n\<close> have jn: "j \<le> n" by (metis dvd_imp_le jn neq0_conv not_less0)
   show "j = 1 \<or> j = n"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     with njk n have j1: "j > 1 \<and> j \<noteq> n" by simp
     have "\<exists> j k. 1 < j \<and> j \<le> k \<and> n = j * k"
     proof (cases "j \<le> k")
       case True
       thus ?thesis unfolding njk using j1 by blast
     next
       case False
       show ?thesis by (rule exI[of _ k], rule exI[of _ j], insert \<open>1 < n\<close> j1 njk False, auto)
         (metis Suc_lessI mult_0_right neq0_conv)
     qed
     then obtain j k where j1: "1 < j" and jk: "j \<le> k" and njk: "n = j * k" by auto
     with small[of j] have ji: "j \<ge> i" unfolding dvd_def by force
     from mult_mono[OF ji ji] have "i * i \<le> j * j" by auto
     with i have "j * j > n" by auto
     from this[unfolded njk] have "k < j" by auto
     with jk show False by auto
   qed
 qed
 
 lemma candidate_invariant_0: "candidate_invariant 0"
   unfolding candidate_invariant_def by auto
 
 lemma next_candidates: assumes res: "next_candidates n = (m,ps)"
   and n: "candidate_invariant n"
   shows "candidate_invariant m" "sorted ps" "{i. prime i \<and> n \<le> i \<and> i < m} \<subseteq> set ps" 
     "set ps \<subseteq> {2..} \<inter> {n..<m}" "distinct ps" "ps \<noteq> []" "n < m"
   unfolding candidate_invariant_def
 proof -
   note res = res[unfolded next_candidates_def]
   note n = n[unfolded candidate_invariant_def]
   show "m = 0 \<or> m mod 30 = 11" using res n by (auto split: if_splits)
-  show "sorted ps" using res n by (auto split: if_splits simp: primes_1000_def sorted2_simps simp del: sorted.simps(2))
+  show "sorted ps" using res n by (auto split: if_splits simp: primes_1000_def sorted2_simps simp del: sorted_wrt.simps(2))
   show "set ps \<subseteq> {2..} \<inter> {n..<m}" using res n by (auto split: if_splits simp: primes_1000_def)
   show "distinct ps" using res n by (auto split: if_splits simp: primes_1000_def)
   show "ps \<noteq> []" using res n by (auto split: if_splits simp: primes_1000_def)
   show "n < m" using res by (auto split: if_splits)
   show "{i. prime i \<and> n \<le> i \<and> i < m} \<subseteq> set ps"
   proof (cases "n = 0")
     case True
     hence *: "m = 1001" "ps = primes_1000" using res by auto
     show ?thesis unfolding * True primes_1000 by auto
   next
     case False
     hence n: "n mod 30 = 11" and m: "m = n + 30" and ps: "ps = [n,n+2,n+6,n+8,n+12,n+18,n+20,n+26]" 
       using res n by auto
     {
       fix i
       assume *: "prime i" "n \<le> i" "i < n + 30" "i \<notin> set ps"
       from n * have i11: "i \<ge> 11" by auto
       define j where "j = i - n" 
       have i: "i = n + j" using \<open>n \<le> i\<close> j_def by auto
       have "i mod 30 = (j + n) mod 30" using \<open>n \<le> i\<close> unfolding j_def by simp
       also have "\<dots> = (j mod 30 + n mod 30) mod 30"
         by (simp add: mod_simps)
       also have "\<dots> = (j mod 30 + 11) mod 30" unfolding n by simp
       finally have i30: "i mod 30 = (j mod 30 + 11) mod 30" by simp
       have 2: "2 dvd (30 :: nat)" and 112: "11 mod (2 :: nat) = 1" by simp_all
       have "(j + 11) mod 2 = (j + 1) mod 2"
         by (rule mod_add_cong) simp_all
       with arg_cong [OF i30, of "\<lambda>j. j mod 2"]
       have 2: "i mod 2 = (j mod 2 + 1) mod 2"
         by (simp add: mod_simps mod_mod_cancel [OF 2])
       have 3: "3 dvd (30 :: nat)" and 113: "11 mod (3 :: nat) = 2" by simp_all
       have "(j + 11) mod 3 = (j + 2) mod 3"
         by (rule mod_add_cong) simp_all
       with arg_cong [OF i30, of "\<lambda> j. j mod 3"] have 3: "i mod 3 = (j mod 3 + 2) mod 3"
         by (simp add: mod_simps mod_mod_cancel [OF 3])
       have 5: "5 dvd (30 :: nat)" and 115: "11 mod (5 :: nat) = 1" by simp_all
       have "(j + 11) mod 5 = (j + 1) mod 5"
         by (rule mod_add_cong) simp_all
       with arg_cong [OF i30, of "\<lambda> j. j mod 5"] have 5: "i mod 5 = (j mod 5 + 1) mod 5"
         by (simp add: mod_simps mod_mod_cancel [OF 5])
       
       from n *(2-)[unfolded ps i, simplified] have 
         "j \<in> {1,3,5,7,9,11,13,15,17,19,21,23,25,27,29} \<or> j \<in> {4,10,16,22,28} \<or> j \<in> {14,24}"
         (is "j \<in> ?j2 \<or> j \<in> ?j3 \<or> j \<in> ?j5")
         by simp presburger
       moreover
       {
         assume "j \<in> ?j2"
         hence "j mod 2 = 1" by auto
         with 2 have "i mod 2 = 0" by auto
         with i11 have "2 dvd i" "i \<noteq> 2" by auto 
         with *(1) have False unfolding prime_nat_iff by auto
       }
       moreover
       {
         assume "j \<in> ?j3"
         hence "j mod 3 = 1" by auto
         with 3 have "i mod 3 = 0" by auto
         with i11 have "3 dvd i" "i \<noteq> 3" by auto 
         with *(1) have False unfolding prime_nat_iff by auto
       }
       moreover
       {
         assume "j \<in> ?j5"
         hence "j mod 5 = 4" by auto
         with 5 have "i mod 5 = 0" by auto
         with i11 have "5 dvd i" "i \<noteq> 5" by auto 
         with *(1) have False unfolding prime_nat_iff by auto
       }
       ultimately have False by blast
     }
     thus ?thesis unfolding m ps by auto
   qed
 qed
 
 
 lemma prime_test_iterate2: assumes small: "\<And> j. 2 \<le> j \<Longrightarrow> j < (i :: nat) \<Longrightarrow> \<not> j dvd n"
   and odd: "odd n"
   and n: "n \<ge> 3"
   and i: "i \<ge> 3" "odd i"
   and mod: "\<not> i dvd n"
   and j: "2 \<le> j" "j < i + 2"
   shows "\<not> j dvd n"
 proof 
   assume dvd: "j dvd n"
   with small[OF j(1)] have "j \<ge> i" by linarith
   with dvd mod have "j > i" by (cases "i = j", auto)
   with j have "j = Suc i" by simp
   with i have "even j" by auto
   with dvd j(1) have "2 dvd n" by (metis dvd_trans)
   with odd show False by auto
 qed
 
 lemma prime_divisor: assumes "j \<ge> 2" and "j dvd n" shows
   "\<exists> p :: nat. prime p \<and> p dvd j \<and> p dvd n"
 proof -
   let ?pf = "prime_factors j"
   from assms have "j > 0" by auto
   from prime_factorization_nat[OF this]
   have "j = (\<Prod>p\<in>?pf. p ^ multiplicity p j)" by auto
   with \<open>j \<ge> 2\<close> have "?pf \<noteq> {}" by auto
   then obtain p where p: "p \<in> ?pf" by auto  
   hence pr: "prime p" by auto
   define rem where "rem = (\<Prod>p\<in>?pf - {p}. p ^ multiplicity p j)"
   from p have mult: "multiplicity p j \<noteq> 0"
     by (auto simp: prime_factors_multiplicity)
   have "finite ?pf" by simp
   have "j = (\<Prod>p\<in>?pf. p ^ multiplicity p j)" by fact
   also have "?pf = (insert p (?pf - {p}))" using p by auto
   also have "(\<Prod>p\<in>insert p (?pf - {p}). p ^ multiplicity p j) = 
     p ^ multiplicity p j * rem" unfolding rem_def
     by (subst prod.insert, auto)
   also have "\<dots> = p * (p ^ (multiplicity p j - 1) * rem)" using mult 
     by (cases "multiplicity p j", auto)
   finally have pj: "p dvd j" unfolding dvd_def by blast
   with \<open>j dvd n\<close> have "p dvd n" by (metis dvd_trans)
   with pj pr show ?thesis by blast
 qed
 
 lemma prime_nat_main: "ni = (n,i,is) \<Longrightarrow> i \<ge> 2 \<Longrightarrow> n \<ge> 2 \<Longrightarrow>
   (\<And> j. 2 \<le> j \<Longrightarrow> j < i \<Longrightarrow> \<not> (j dvd n)) \<Longrightarrow>
   (\<And> j. i \<le> j \<Longrightarrow> j < jj \<Longrightarrow> prime j \<Longrightarrow> j \<in> set is) \<Longrightarrow> i \<le> jj \<Longrightarrow>
   sorted is \<Longrightarrow> distinct is \<Longrightarrow> candidate_invariant jj \<Longrightarrow> set is \<subseteq> {i..<jj} \<Longrightarrow> 
   res = prime_nat_main n jj is \<Longrightarrow> 
   res = prime n"
 proof (induct ni arbitrary: n i "is" jj res rule: wf_induct[OF 
     wf_measures[of "[\<lambda> (n,i,is). n - i, \<lambda> (n,i,is). if is = [] then 1 else 0]"]])
   case (1 ni n i "is" jj res)
   note res = 1(12)
   from 1(3-4) have i: "i \<ge> 2" and i2: "Suc i \<ge> 2" and n: "n \<ge> 2" by auto
   from 1(5) have dvd: "\<And> j. 2 \<le> j \<Longrightarrow> j < i \<Longrightarrow> \<not> j dvd n" .
   from 1(7) have ijj: "i \<le> jj" .
   note sort_dist = 1(8-9)
   have "is": "\<And> j. i \<le> j \<Longrightarrow> j < jj \<Longrightarrow> prime j \<Longrightarrow> j \<in> set is" by (rule 1(6))
   note simps = prime_nat_main.simps[of n jj "is"]
   note IH = 1(1)[rule_format, unfolded 1(2), OF _ refl]
   show ?case
   proof (cases "is")
     case Nil
     obtain jjj iis where can: "next_candidates jj = (jjj,iis)" by force
     from res[unfolded simps, unfolded Nil can split] have res: "res = prime_nat_main n jjj iis" by auto
     from next_candidates[OF can 1(10)] have can: 
       "sorted iis" "distinct iis" "candidate_invariant jjj" 
       "{i. prime i \<and> jj \<le> i \<and> i < jjj} \<subseteq> set iis" "set iis \<subseteq> {2..} \<inter> {jj..<jjj}"
       "iis \<noteq> []" "jj < jjj" by blast+
     from can ijj have "i \<le> jjj" by auto
     note IH = IH[OF _ i n dvd _ this can(1-3) _ res]
     show ?thesis
     proof (rule IH, force simp: Nil can(6))
       fix x
       assume ix: "i \<le> x" and xj: "x < jjj" and px: "prime x"
       from "is"[OF ix _ px] Nil have jx: "jj \<le> x" by force
       with can(4) xj px show "x \<in> set iis" by auto
     qed (insert can(5) ijj, auto)
   next
     case (Cons i' iis)
     with res[unfolded simps]
     have res: "res = (if i' dvd n then n \<le> i' else if i' * i' \<le> n then prime_nat_main n jj iis else True)" 
       by simp
     from 1(11) Cons have iis: "set iis \<subseteq> {i..<jj}" and i': "i \<le> i'" "i' < jj" "Suc i' \<le> jj" by auto
     from sort_dist have sd_iis: "sorted iis" "distinct iis" and "i' \<notin> set iis" by(auto simp: Cons)
     from sort_dist(1) have "set iis \<subseteq> {i'..}" by(auto simp: Cons)
     with iis have "set iis \<subseteq> {i'..<jj}" by force
     with \<open>i' \<notin> set iis\<close>  have iis: "set iis \<subseteq> {Suc i'..<jj}"
       by (auto, case_tac "x = i'", auto)
     {
       fix j
       assume j: "2 \<le> j" "j < i'"
       have "\<not> j dvd n"
       proof
         assume "j dvd n"
         from prime_divisor[OF j(1) this] obtain p where 
           p: "prime p" "p dvd j" "p dvd n" by auto
         have pj: "p \<le> j"
           by (rule dvd_imp_le[OF p(2)], insert j, auto)
         have p2: "2 \<le> p" using p(1) by (rule prime_ge_2_nat)
         from dvd[OF p2] p(3) have pi: "p \<ge> i" by force
         from pj j(2) i' "is"[OF pi _ p(1)] have "p \<in> set is" by auto
         with \<open>sorted is\<close> have "i' \<le> p" by(auto simp: Cons)
         with pj j(2) show False by arith
       qed
     } note dvd = this
     from i' i have i'2: "2 \<le> Suc i'" by auto
     note IH = IH[OF _ i'2 n _ _ i'(3) sd_iis 1(10) iis]
     show ?thesis
     proof (cases "i' dvd n")
       case False note dvdi = this
       {
         fix j
         assume j: "2 \<le> j" "j < Suc i'"
         have "\<not> j dvd n"
         proof (cases "j = i'")
           case False
           with j have "j < i'" by auto
           from dvd[OF j(1) this] show ?thesis .
         qed (insert False, auto)
       } note dvds = this
       show ?thesis
       proof (cases "i' * i' \<le> n")
         case True note iin = this
         with res False have res: "res = prime_nat_main n jj iis" by auto
         from iin have i_n: "i' < n"
           using dvd dvdi n nat_neq_iff dvd_refl by blast
         {
           fix x
           assume "Suc i' \<le> x" "x < jj" "prime x"
           hence "i \<le> x" "x < jj" "prime x" using i' by auto
           from "is"[OF this] have "x \<in> set is" . 
           with \<open>Suc i' \<le> x\<close> have "x \<in> set iis" unfolding Cons by auto
         } note iis = this
         show ?thesis 
           by (rule IH[OF _ dvds iis res], insert i_n i', auto)
       next
         case False
         with res dvdi have res: "res = True" by auto
         have n: "prime n" 
           by (rule prime_sqrtI[OF n dvd False])
         thus ?thesis unfolding res by auto
       qed
     next
       case True
       have "i' \<ge> 2" using i i' by auto
       from \<open>i' dvd n\<close> obtain k where "n = i' * k" ..
       with n have "k \<noteq> 0" by (cases "k = 0", auto)
       with \<open>n = i' * k\<close> have *: "i' < n \<or> i' = n"
         by auto
       with True res have "res \<longleftrightarrow> i' = n"
         by auto
       also have "\<dots> = prime n"
       using * proof
         assume "i' < n"
         with \<open>i' \<ge> 2\<close> \<open>i' dvd n\<close> have "\<not> prime n"
           by (auto simp add: prime_nat_iff)
         with \<open>i' < n\<close> show ?thesis
           by auto
       next
         assume "i' = n"
         with dvd n have "prime n"
           by (simp add: prime_nat_iff')
         with \<open>i' = n\<close> show ?thesis 
           by auto
       qed
       finally show ?thesis .
     qed
   qed
 qed
 
 lemma prime_factorization_nat_main: "ni = (n,i,is) \<Longrightarrow> i \<ge> 2 \<Longrightarrow> n \<ge> 2 \<Longrightarrow>
   (\<And> j. 2 \<le> j \<Longrightarrow> j < i \<Longrightarrow> \<not> (j dvd n)) \<Longrightarrow> 
   (\<And> j. i \<le> j \<Longrightarrow> j < jj \<Longrightarrow> prime j \<Longrightarrow> j \<in> set is) \<Longrightarrow> i \<le> jj \<Longrightarrow>
   sorted is \<Longrightarrow> distinct is \<Longrightarrow> candidate_invariant jj \<Longrightarrow> set is \<subseteq> {i..<jj} \<Longrightarrow> 
   res = prime_factorization_nat_main n jj is ps \<Longrightarrow> 
   \<exists> qs. res = qs @ ps \<and> Ball (set qs) prime \<and> n = prod_list qs"
 proof (induct ni arbitrary: n i "is" jj res ps rule: wf_induct[OF 
   wf_measures[of "[\<lambda> (n,i,is). n - i, \<lambda> (n,i,is). if is = [] then 1 else 0]"]])
   case (1 ni n i "is" jj res ps)
   note res = 1(12)
   from 1(3-4) have i: "i \<ge> 2" and i2: "Suc i \<ge> 2" and n: "n \<ge> 2" by auto
   from 1(5) have dvd: "\<And> j. 2 \<le> j \<Longrightarrow> j < i \<Longrightarrow> \<not> j dvd n" .
   from 1(7) have ijj: "i \<le> jj" .
   note sort_dist = 1(8-9)
   have "is": "\<And> j. i \<le> j \<Longrightarrow> j < jj \<Longrightarrow> prime j \<Longrightarrow> j \<in> set is" by (rule 1(6))
   note simps = prime_factorization_nat_main.simps[of n jj "is"]
   note IH = 1(1)[rule_format, unfolded 1(2), OF _ refl]
   show ?case
   proof (cases "is")
     case Nil
     obtain jjj iis where can: "next_candidates jj = (jjj,iis)" by force
     from res[unfolded simps, unfolded Nil can split] have res: "res = prime_factorization_nat_main n jjj iis ps" by auto
     from next_candidates[OF can 1(10)] have can: 
       "sorted iis" "distinct iis" "candidate_invariant jjj" 
       "{i. prime i \<and> jj \<le> i \<and> i < jjj} \<subseteq> set iis" "set iis \<subseteq> {2..} \<inter> {jj..<jjj}"
       "iis \<noteq> []" "jj < jjj" by blast+
     from can ijj have "i \<le> jjj" by auto
     note IH = IH[OF _ i n dvd _ this can(1-3) _ res]
     show ?thesis
     proof (rule IH, force simp: Nil can(6))
       fix x
       assume ix: "i \<le> x" and xj: "x < jjj" and px: "prime x"
       from "is"[OF ix _ px] Nil have jx: "jj \<le> x" by force
       with can(4) xj px show "x \<in> set iis" by auto
     qed (insert can(5) ijj, auto)
   next
     case (Cons i' iis)
     obtain n' m where dm: "Divides.divmod_nat n i' = (n',m)" by force
     hence n': "n' = n div i'" and m: "m = n mod i'" by (auto simp: divmod_nat_def)
     have m: "(m = 0) = (i' dvd n)" unfolding m by auto
     from Cons res[unfolded simps] dm m n'
     have res: "res = (
        if i' dvd n then case remove_prime_factor i' (n div i') (i' # ps) of
             (n', ps') \<Rightarrow> if n' = 1 then ps' else prime_factorization_nat_main n' jj iis ps'
        else if i' * i' \<le> n then prime_factorization_nat_main n jj iis ps else n # ps)" 
       by simp
     from 1(11) i Cons have iis: "set iis \<subseteq> {i..<jj}" and i': "i \<le> i'" "i' < jj" "Suc i' \<le> jj" "i' > 1" by auto
     from sort_dist have sd_iis: "sorted iis" "distinct iis" and "i' \<notin> set iis" by(auto simp: Cons)
     from sort_dist(1) Cons have "set iis \<subseteq> {i'..}" by(auto)
     with iis have "set iis \<subseteq> {i'..<jj}" by force
     with \<open>i' \<notin> set iis\<close>  have iis: "set iis \<subseteq> {Suc i'..<jj}"
       by (auto, case_tac "x = i'", auto)
     {
       fix j
       assume j: "2 \<le> j" "j < i'"
       have "\<not> j dvd n"
       proof
         assume "j dvd n"
         from prime_divisor[OF j(1) this] obtain p where 
           p: "prime p" "p dvd j" "p dvd n" by auto
         have pj: "p \<le> j"
           by (rule dvd_imp_le[OF p(2)], insert j, auto)
         have p2: "2 \<le> p" using p(1) by (rule prime_ge_2_nat)
         from dvd[OF p2] p(3) have pi: "p \<ge> i" by force
         from pj j(2) i' "is"[OF pi _ p(1)] have "p \<in> set is" by auto
         with \<open>sorted is\<close> have "i' \<le> p" by (auto simp: Cons)
         with pj j(2) show False by arith
       qed
     } note dvd = this
     from i' i have i'2: "2 \<le> Suc i'" by auto
     note IH = IH[OF _ i'2 _ _ _ i'(3) sd_iis 1(10) iis]
     {
       fix x
       assume "Suc i' \<le> x" "x < jj" "prime x"
       hence "i \<le> x" "x < jj" "prime x" using i' by auto
       from "is"[OF this] have "x \<in> set is" . 
       with \<open>Suc i' \<le> x\<close> have "x \<in> set iis" unfolding Cons by auto
     } note iis = this
     show ?thesis
     proof (cases "i' dvd n")
       case False note dvdi = this
       {
         fix j
         assume j: "2 \<le> j" "j < Suc i'"
         have "\<not> j dvd n"
         proof (cases "j = i'")
           case False
           with j have "j < i'" by auto
           from dvd[OF j(1) this] show ?thesis .
         qed (insert False, auto)
       } note dvds = this
       show ?thesis
       proof (cases "i' * i' \<le> n")
         case True note iin = this
         with res False have res: "res = prime_factorization_nat_main n jj iis ps" by auto
         from iin have i_n: "i' < n" using dvd dvdi n nat_neq_iff dvd_refl by blast 
         show ?thesis 
           by (rule IH[OF _ n dvds iis res], insert i_n i', auto)
       next
         case False
         with res dvdi have res: "res = n # ps" by auto
         have n: "prime n" 
           by (rule prime_sqrtI[OF n dvd False])
         thus ?thesis unfolding res by auto
       qed    
     next
       case True note i_n = this
       obtain n'' qs where rp: "remove_prime_factor i' (n div i') (i' # ps) = (n'',qs)" by force
       with res True 
       have res: "res = (if n'' = 1 then qs else prime_factorization_nat_main n'' jj iis qs)" by auto
       have pi: "prime i'" unfolding prime_nat_iff
       proof (intro conjI allI impI)
         show "1 < i'" using i' i by auto
         fix j
         assume ji: "j dvd i'"
         with i' i have j0: "j \<noteq> 0" by (cases "j = 0", auto)
         from ji i_n have jn: "j dvd n" by (metis dvd_trans)
         with dvd[of j] have j: "2 > j \<or> j \<ge> i'" by linarith
         from ji \<open>1 < i'\<close> have "j \<le> i'" unfolding dvd_def 
           by (simp add: dvd_imp_le ji)
         with j j0 show "j = 1 \<or> j = i'" by linarith
       qed
       from True n' have id: "n = n' * i'" by auto
       from n id have "n' \<noteq> 0" by (cases "n = 0", auto)
       with id have "i' \<le> n" by auto
       from remove_prime_factor[OF rp[folded n'] \<open>1 < i'\<close> \<open>n' \<noteq> 0\<close>] obtain rs
         where qs: "qs = rs @ i' # ps" and n': "n' = n'' * prod_list rs" and i_n'': "\<not> i' dvd n''" 
         and rs: "set rs \<subseteq> {i'}" by auto
       {
         fix j
         assume "j dvd n''"
         hence "j dvd n" unfolding id n' by auto
       } note dvd' = this
       show ?thesis
       proof (cases "n'' = 1")
         case False
         with res have res: "res = prime_factorization_nat_main n'' jj iis qs" 
           by simp
         from i i' have "i' \<ge> 2" by simp
         from False n' \<open>n' \<noteq> 0\<close> have n2: "n'' \<ge> 2" by (cases "n'' = 0"; auto)
         have lrs: "prod_list rs \<noteq> 0" using n' \<open>n' \<noteq> 0\<close> by (cases "prod_list rs = 0", auto)
         with \<open>i' \<ge> 2\<close> have "prod_list rs * i' \<ge> 2" by (cases "prod_list rs", auto)
         hence nn'': "n > n''" unfolding id n' using n2 by simp
         have "i' \<noteq> n" unfolding id n' using pi False by fastforce
         with \<open>i' \<le> n\<close> i' have "n > i" by auto
         with nn'' i i' have less: "n - i > n'' - Suc i'" by simp
         {
           fix j
           assume 2: "2 \<le> j" and ji: "j < Suc i'" 
           have "\<not> j dvd n''" 
           proof (cases "j = i'")
             case False
             with ji have "j < i'" by auto
             from dvd' dvd[OF 2 this] show ?thesis by blast
           qed (insert i_n'', auto)
         }
         from IH[OF _ n2 this iis res] less obtain ss where 
           res: "res = ss @ qs \<and> Ball (set ss) prime \<and> n'' = prod_list ss" by auto
         thus ?thesis unfolding id n' qs using pi rs by auto
       next
         case True
         with res have res: "res = qs" by auto
         show ?thesis unfolding id n' res qs True using rs \<open>prime i'\<close>
           by (intro exI[of _ "rs @ [i']"], auto)
       qed
     qed
   qed
 qed
 
 lemma prime_nat[simp]: "prime_nat n = prime n"
 proof (cases "n < 2")
   case True
   thus ?thesis unfolding prime_nat_def prime_nat_iff by auto
 next
   case False
   hence n: "n \<ge> 2" by auto
   obtain jj "is" where can: "next_candidates 0 = (jj,is)" by force
   from next_candidates[OF this candidate_invariant_0]
   have cann: "sorted is" "distinct is" "candidate_invariant jj" 
     "{i. prime i \<and> 0 \<le> i \<and> i < jj} \<subseteq> set is"
     "set is \<subseteq> {2..} \<inter> {0..<jj}" "distinct is" "is \<noteq> []" by auto  
   from cann have sub: "set is \<subseteq> {2..<jj}" by force
   with \<open>is \<noteq> []\<close> have jj: "jj \<ge> 2" by (cases "is", auto)
   from n can have res: "prime_nat n = prime_nat_main n jj is"
     unfolding prime_nat_def by auto
   show ?thesis using prime_nat_main[OF refl le_refl n _ _ jj cann(1-3) sub res] cann(4) by auto
 qed
 
 lemma prime_factorization_nat: fixes n :: nat
   defines "pf \<equiv> prime_factorization_nat n"
   shows "Ball (set pf) prime"
   and "n \<noteq> 0 \<Longrightarrow> prod_list pf = n"
   and "n = 0 \<Longrightarrow> pf = []"
 proof -
   note pf = pf_def[unfolded prime_factorization_nat_def]
   have "Ball (set pf) prime \<and> (n \<noteq> 0 \<longrightarrow> prod_list pf = n) \<and> (n = 0 \<longrightarrow> pf = [])"
   proof (cases "n < 2")
     case True
     thus ?thesis using pf by auto
   next
     case False
     hence n: "n \<ge> 2" by auto
     obtain jj "is" where can: "next_candidates 0 = (jj,is)" by force
     from next_candidates[OF this candidate_invariant_0]
     have cann: "sorted is" "distinct is" "candidate_invariant jj" 
       "{i. prime i \<and> 0 \<le> i \<and> i < jj} \<subseteq> set is"
       "set is \<subseteq> {2..} \<inter> {0..<jj}" "distinct is" "is \<noteq> []" by auto  
     from cann have sub: "set is \<subseteq> {2..<jj}" by force
     with \<open>is \<noteq> []\<close> have jj: "jj \<ge> 2" by (cases "is", auto)
     let ?pfm = "prime_factorization_nat_main n jj is []"
     from pf[unfolded can] False
     have res: "pf = rev ?pfm" by simp
     from prime_factorization_nat_main[OF refl le_refl n _ _ jj cann(1-3) sub refl, of Nil] cann(4)
     have "Ball (set ?pfm) prime" "n = prod_list ?pfm" by auto
     thus ?thesis unfolding res using n by auto
   qed
   thus "Ball (set pf) prime" "n \<noteq> 0 \<Longrightarrow> prod_list pf = n" "n = 0 \<Longrightarrow> pf = []" by auto
 qed
 
 lemma prod_mset_multiset_prime_factorization_nat [simp]: 
   "(x::nat) \<noteq> 0 \<Longrightarrow> prod_mset (prime_factorization x) = x"
   by simp
 
 (* TODO Move *)
 lemma prime_factorization_unique'':
   fixes A :: "'a :: {factorial_semiring_multiplicative} multiset"
   assumes "\<And>p. p \<in># A \<Longrightarrow> prime p"
   assumes "prod_mset A = normalize x"
   shows   "prime_factorization x = A"
 proof -
   have "prod_mset A \<noteq> 0" by (auto dest: assms(1))
   with assms(2) have "x \<noteq> 0" by simp
   hence "prod_mset (prime_factorization x) = prod_mset A" 
     by (simp add: assms prod_mset_prime_factorization)
   with assms show ?thesis 
     by (intro prime_factorization_unique') auto
 qed
 
 lemma multiset_prime_factorization_nat_correct:
   "prime_factorization n = mset (prime_factorization_nat n)"
 proof -
   note pf = prime_factorization_nat[of n]
   show ?thesis
   proof (cases "n = 0")
     case True
     thus ?thesis using pf(3) by simp
   next
     case False
     note pf = pf(1) pf(2)[OF False]
     show ?thesis
     proof (rule prime_factorization_unique'')
       show "prime p" if "p \<in># mset (prime_factorization_nat n)" for p
         using pf(1) that by simp
       let ?l = "\<Prod>i\<in>#prime_factorization n. i"
       let ?r = "\<Prod>i\<in>#mset (prime_factorization_nat n). i"
       show "prod_mset (mset (prime_factorization_nat n)) = normalize n"
         by (simp add: pf(2) prod_mset_prod_list)
     qed
   qed
 qed
 
 lemma multiset_prime_factorization_code[code_unfold]: 
   "prime_factorization = (\<lambda>n. mset (prime_factorization_nat n))"
   by (intro ext multiset_prime_factorization_nat_correct)
 
 lemma divisors_nat: 
   "n \<noteq> 0 \<Longrightarrow> set (divisors_nat n) = {p. p dvd n}" "distinct (divisors_nat n)" "divisors_nat 0 = []"
 proof -
   show "distinct (divisors_nat n)" "divisors_nat 0 = []" unfolding divisors_nat_def by auto
   assume n: "n \<noteq> 0"
   from n have "n > 0" by auto
   {
     fix x    
     have "(x dvd n) = (x \<noteq> 0 \<and> (\<forall>p. multiplicity p x \<le> multiplicity p n))"
     proof (cases "x = 0")
       case False
       with \<open>n > 0\<close> show ?thesis by (auto simp: dvd_multiplicity_eq)
     next
       case True
       with n show ?thesis by auto
     qed
   } note dvd = this
   let ?dn = "set (divisors_nat n)"
   let ?mf = "\<lambda> (n :: nat). prime_factorization n"
   have "?dn = prod_list ` set (subseqs (prime_factorization_nat n))" unfolding divisors_nat_def
     using n by auto
   also have "\<dots> = prod_mset ` mset ` set (subseqs (prime_factorization_nat n))"
     by (force simp: prod_mset_prod_list)
   also have "mset ` set (subseqs (prime_factorization_nat n))
     = { ps. ps \<subseteq># mset (prime_factorization_nat n)}" 
     unfolding multiset_of_subseqs by simp
   also have "\<dots> = { ps. ps \<subseteq># ?mf n}"
     thm multiset_prime_factorization_code[symmetric]
     unfolding multiset_prime_factorization_nat_correct[symmetric] by auto
   also have "prod_mset ` \<dots> = {p. p dvd n}" (is "?l = ?r")
   proof -
     {
       fix x
       assume "x dvd n"
       from this[unfolded dvd] have x: "x \<noteq> 0" by auto
       from \<open>x dvd n\<close> \<open>x \<noteq> 0\<close> \<open>n \<noteq> 0\<close> have sub: "?mf x \<subseteq># ?mf n"
         by (subst prime_factorization_subset_iff_dvd) auto
       have "prod_mset (?mf x) = x" using x
         by (simp add: prime_factorization_nat)
       hence "x \<in> ?l" using sub by force
     } 
     moreover
     {
       fix x
       assume "x \<in> ?l"
       then obtain ps where x: "x = prod_mset ps" and sub: "ps \<subseteq># ?mf n" by auto
       have "x dvd n" using prod_mset_subset_imp_dvd[OF sub] n x by simp
     }
     ultimately show ?thesis by blast
   qed
   finally show "set (divisors_nat n) = {p. p dvd n}" .
 qed
 
 lemma divisors_int_pos: "x \<noteq> 0 \<Longrightarrow> set (divisors_int_pos x) = {i. i dvd x \<and> i > 0}" "distinct (divisors_int_pos x)"
   "divisors_int_pos 0 = []"
 proof -
   show "divisors_int_pos 0 = []" by code_simp
   show "distinct (divisors_int_pos x)" 
     unfolding divisors_int_pos_def using divisors_nat(2)[of "nat (abs x)"]
     by (simp add: distinct_map inj_on_def)
   assume x: "x \<noteq> 0"
   let ?x = "nat (abs x)"
   from x have xx: "?x \<noteq> 0" by auto
   from x have 0: "\<And> y. y dvd x \<Longrightarrow> y \<noteq> 0" by auto
   have id: "int ` {p. int p dvd x} = {i. i dvd x \<and> 0 < i}" (is "?l = ?r")
   proof -
     {
       fix y
       assume "y \<in> ?l"
       then obtain p where y: "y = int p" and dvd: "int p dvd x" by auto
       have "y \<in> ?r" unfolding y using dvd 0[OF dvd] by auto
     }
     moreover
     {
       fix y
       assume "y \<in> ?r"
       hence dvd: "y dvd x" and y0: "y > 0" by auto
       define n where "n = nat y"
       from y0 have y: "y = int n" unfolding n_def by auto
       with dvd have "y \<in> ?l" by auto
     }
     ultimately show ?thesis by blast
   qed
   from xx show "set (divisors_int_pos x) = {i. i dvd x \<and> i > 0}"
     by (simp add: divisors_int_pos_def divisors_nat id) 
 qed
 
 lemma divisors_int: "x \<noteq> 0 \<Longrightarrow> set (divisors_int x) = {i. i dvd x}" "distinct (divisors_int x)"
   "divisors_int 0 = []"
 proof -
   show "divisors_int 0 = []" by code_simp
   show "distinct (divisors_int x)"
   proof (cases "x = 0")
     case True 
     show ?thesis unfolding True by code_simp
   next
     case False
     from divisors_int_pos(1)[OF False] divisors_int_pos(2)
     show ?thesis unfolding divisors_int_def Let_def distinct_append distinct_map inj_on_def by auto
   qed
   assume x: "x \<noteq> 0"
   show "set (divisors_int x) = {i. i dvd x}"
   unfolding divisors_int_def Let_def set_append set_map divisors_int_pos(1)[OF x] using x
   by auto (metis (no_types, lifting) dvd_mult_div_cancel image_eqI linorder_neqE_linordered_idom 
   mem_Collect_eq minus_dvd_iff minus_minus mult_zero_left neg_less_0_iff_less)
 qed
 
 definition divisors_fun :: "('a \<Rightarrow> ('a :: {comm_monoid_mult,zero}) list) \<Rightarrow> bool" where
   "divisors_fun df \<equiv> (\<forall> x. x \<noteq> 0 \<longrightarrow> set (df x) = { d. d dvd x }) \<and> (\<forall> x. distinct (df x))"
 
 lemma divisors_funD: "divisors_fun df \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> d dvd x \<Longrightarrow> d \<in> set (df x)" 
   unfolding divisors_fun_def by auto
 
 definition divisors_pos_fun :: "('a \<Rightarrow> ('a :: {comm_monoid_mult,zero,ord}) list) \<Rightarrow> bool" where
   "divisors_pos_fun df \<equiv> (\<forall> x. x \<noteq> 0 \<longrightarrow> set (df x) = { d. d dvd x \<and> d > 0}) \<and> (\<forall> x. distinct (df x))"
 
 lemma divisors_pos_funD: "divisors_pos_fun df \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> d dvd x \<Longrightarrow> d > 0 \<Longrightarrow> d \<in> set (df x)" 
   unfolding divisors_pos_fun_def by auto
 
 lemma divisors_fun_nat: "divisors_fun divisors_nat"
   unfolding divisors_fun_def using divisors_nat by auto
 
 lemma divisors_fun_int: "divisors_fun divisors_int"
   unfolding divisors_fun_def using divisors_int by auto
 
 lemma divisors_pos_fun_int: "divisors_pos_fun divisors_int_pos"
   unfolding divisors_pos_fun_def using divisors_int_pos by auto
 
 end
diff --git a/thys/Polynomials/MPoly_Type_Class_Ordered.thy b/thys/Polynomials/MPoly_Type_Class_Ordered.thy
--- a/thys/Polynomials/MPoly_Type_Class_Ordered.thy
+++ b/thys/Polynomials/MPoly_Type_Class_Ordered.thy
@@ -1,3676 +1,3676 @@
 (* Author: Fabian Immler, Alexander Maletzky *)
 
 section \<open>Type-Class-Multivariate Polynomials in Ordered Terms\<close>
 
 theory MPoly_Type_Class_Ordered
   imports MPoly_Type_Class
 begin
 
 class the_min = linorder +
   fixes the_min::'a
   assumes the_min_min: "the_min \<le> x"
 
 text \<open>Type class @{class the_min} guarantees that a least element exists. Instances of @{class the_min}
   should provide @{emph \<open>computable\<close>} definitions of that element.\<close>
 
 instantiation nat :: the_min
 begin
   definition "the_min_nat = (0::nat)"
   instance by (standard, simp add: the_min_nat_def)
 end
 
 instantiation unit :: the_min
 begin
   definition "the_min_unit = ()"
   instance by (standard, simp add: the_min_unit_def)
 end
 
 locale ordered_term =
     term_powerprod pair_of_term term_of_pair +
     ordered_powerprod ord ord_strict +
     ord_term_lin: linorder ord_term ord_term_strict
       for pair_of_term::"'t \<Rightarrow> ('a::comm_powerprod \<times> 'k::{the_min,wellorder})"
       and term_of_pair::"('a \<times> 'k) \<Rightarrow> 't"
       and ord::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<preceq>" 50)
       and ord_strict (infixl "\<prec>" 50)
       and ord_term::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<preceq>\<^sub>t" 50)
       and ord_term_strict::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<prec>\<^sub>t" 50) +
 		assumes splus_mono: "v \<preceq>\<^sub>t w \<Longrightarrow> t \<oplus> v \<preceq>\<^sub>t t \<oplus> w"
     assumes ord_termI: "pp_of_term v \<preceq> pp_of_term w \<Longrightarrow> component_of_term v \<le> component_of_term w \<Longrightarrow> v \<preceq>\<^sub>t w"
 begin
 
 abbreviation ord_term_conv (infixl "\<succeq>\<^sub>t" 50) where "ord_term_conv \<equiv> (\<preceq>\<^sub>t)\<inverse>\<inverse>"
 abbreviation ord_term_strict_conv (infixl "\<succ>\<^sub>t" 50) where "ord_term_strict_conv \<equiv> (\<prec>\<^sub>t)\<inverse>\<inverse>"
 
 text \<open>The definition of @{locale ordered_term} only covers TOP and POT orderings. 
   These two types of orderings are the only interesting ones.\<close>
 
 definition "min_term \<equiv> term_of_pair (0, the_min)"
 
 lemma min_term_min: "min_term \<preceq>\<^sub>t v"
 proof (rule ord_termI)
   show "pp_of_term min_term \<preceq> pp_of_term v" by (simp add: min_term_def zero_min term_simps)
 next
   show "component_of_term min_term \<le> component_of_term v" by (simp add: min_term_def the_min_min term_simps)
 qed
 
 lemma splus_mono_strict:
   assumes "v \<prec>\<^sub>t w"
   shows "t \<oplus> v \<prec>\<^sub>t t \<oplus> w"
 proof -
   from assms have "v \<preceq>\<^sub>t w" and "v \<noteq> w" by simp_all
   from this(1) have "t \<oplus> v \<preceq>\<^sub>t t \<oplus> w" by (rule splus_mono)
   moreover from \<open>v \<noteq> w\<close> have "t \<oplus> v \<noteq> t \<oplus> w" by (simp add: term_simps)
   ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
 qed
 
 lemma splus_mono_left:
   assumes "s \<preceq> t"
   shows "s \<oplus> v \<preceq>\<^sub>t t \<oplus> v"
 proof (rule ord_termI, simp_all add: term_simps)
   from assms show "s + pp_of_term v \<preceq> t + pp_of_term v" by (rule plus_monotone)
 qed
 
 lemma splus_mono_strict_left:
   assumes "s \<prec> t"
   shows "s \<oplus> v \<prec>\<^sub>t t \<oplus> v"
 proof -
   from assms have "s \<preceq> t" and "s \<noteq> t" by simp_all
   from this(1) have "s \<oplus> v \<preceq>\<^sub>t t \<oplus> v" by (rule splus_mono_left)
   moreover from \<open>s \<noteq> t\<close> have "s \<oplus> v \<noteq> t \<oplus> v" by (simp add: term_simps)
   ultimately show ?thesis using ord_term_lin.antisym_conv1 by blast
 qed
 
 lemma ord_term_canc:
   assumes "t \<oplus> v \<preceq>\<^sub>t t \<oplus> w"
   shows "v \<preceq>\<^sub>t w"
 proof (rule ccontr)
   assume "\<not> v \<preceq>\<^sub>t w"
   hence "w \<prec>\<^sub>t v" by simp
   hence "t \<oplus> w \<prec>\<^sub>t t \<oplus> v" by (rule splus_mono_strict)
   with assms show False by simp
 qed
 
 lemma ord_term_strict_canc:
   assumes "t \<oplus> v \<prec>\<^sub>t t \<oplus> w"
   shows "v \<prec>\<^sub>t w"
 proof (rule ccontr)
   assume "\<not> v \<prec>\<^sub>t w"
   hence "w \<preceq>\<^sub>t v" by simp
   hence "t \<oplus> w \<preceq>\<^sub>t t \<oplus> v" by (rule splus_mono)
   with assms show False by simp
 qed
 
 lemma ord_term_canc_left:
   assumes "t \<oplus> v \<preceq>\<^sub>t s \<oplus> v"
   shows "t \<preceq> s"
 proof (rule ccontr)
   assume "\<not> t \<preceq> s"
   hence "s \<prec> t" by simp
   hence "s \<oplus> v \<prec>\<^sub>t t \<oplus> v" by (rule splus_mono_strict_left)
   with assms show False by simp
 qed
 
 lemma ord_term_strict_canc_left:
   assumes "t \<oplus> v \<prec>\<^sub>t s \<oplus> v"
   shows "t \<prec> s"
 proof (rule ccontr)
   assume "\<not> t \<prec> s"
   hence "s \<preceq> t" by simp
   hence "s \<oplus> v \<preceq>\<^sub>t t \<oplus> v" by (rule splus_mono_left)
   with assms show False by simp
 qed
 
 lemma ord_adds_term:
   assumes "u adds\<^sub>t v"
   shows "u \<preceq>\<^sub>t v"
 proof -
   from assms have *: "component_of_term u \<le> component_of_term v" and "pp_of_term u adds pp_of_term v"
     by (simp_all add: adds_term_def)
   from this(2) have "pp_of_term u \<preceq> pp_of_term v" by (rule ord_adds)
   from this * show ?thesis by (rule ord_termI)
 qed
 
 end
 
 subsection \<open>Interpretations\<close>
 
 context ordered_powerprod
 begin
 
 subsubsection \<open>Unit\<close>
 
 sublocale punit: ordered_term to_pair_unit fst "(\<preceq>)" "(\<prec>)" "(\<preceq>)" "(\<prec>)"
   apply standard
   subgoal by (simp, fact plus_monotone_left)
   subgoal by (simp only: punit_pp_of_term punit_component_of_term)
   done
 
 lemma punit_min_term [simp]: "punit.min_term = 0"
   by (simp add: punit.min_term_def)
 
 end
 
 subsection \<open>Definitions\<close>
 
 context ordered_term
 begin
 
 definition higher :: "('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 't \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero)"
   where "higher p t = except p {s. s \<preceq>\<^sub>t t}"
 
 definition lower :: "('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 't \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero)"
   where "lower p t = except p {s. t \<preceq>\<^sub>t s}"
 
 definition lt :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 't"
   where "lt p = (if p = 0 then min_term else ord_term_lin.Max (keys p))"
 
 abbreviation "lp p \<equiv> pp_of_term (lt p)"
 
 definition lc :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'b"
   where "lc p = lookup p (lt p)"
 
 definition tt :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 't"
   where "tt p = (if p = 0 then min_term else ord_term_lin.Min (keys p))"
 
 abbreviation "tp p \<equiv> pp_of_term (tt p)"
 
 definition tc :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'b"
   where "tc p \<equiv> lookup p (tt p)"
 
 definition tail :: "('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero)"
   where "tail p \<equiv> lower p (lt p)"
 
 subsection \<open>Leading Term and Leading Coefficient: @{const lt} and @{const lc}\<close>
 
 lemma lt_zero [simp]: "lt 0 = min_term"
   by (simp add: lt_def)
 
 lemma lc_zero [simp]: "lc 0 = 0"
   by (simp add: lc_def)
 
 lemma lt_uminus [simp]: "lt (- p) = lt p"
   by (simp add: lt_def keys_uminus)
 
 lemma lc_uminus [simp]: "lc (- p) = - lc p"
   by (simp add: lc_def)
 
 lemma lt_alt:
   assumes "p \<noteq> 0"
   shows "lt p = ord_term_lin.Max (keys p)"
   using assms unfolding lt_def by simp
 
 lemma lt_max:
   assumes "lookup p v \<noteq> 0"
   shows "v \<preceq>\<^sub>t lt p"
 proof -
   from assms have t_in: "v \<in> keys p" by (simp add: in_keys_iff)
   hence "keys p \<noteq> {}" by auto
   hence "p \<noteq> 0" using keys_zero by blast
   from lt_alt[OF this] ord_term_lin.Max_ge[OF finite_keys t_in] show ?thesis by simp
 qed
 
 lemma lt_eqI:
   assumes "lookup p v \<noteq> 0" and "\<And>u. lookup p u \<noteq> 0 \<Longrightarrow> u \<preceq>\<^sub>t v"
   shows "lt p = v"
 proof -
   from assms(1) have "v \<in> keys p" by (simp add: in_keys_iff)
   hence "keys p \<noteq> {}" by auto
   hence "p \<noteq> 0"
     using keys_zero by blast
   have "u \<preceq>\<^sub>t v" if "u \<in> keys p" for u
   proof -
     from that have "lookup p u \<noteq> 0" by (simp add: in_keys_iff)
     thus "u \<preceq>\<^sub>t v" by (rule assms(2))
   qed
   from lt_alt[OF \<open>p \<noteq> 0\<close>] ord_term_lin.Max_eqI[OF finite_keys this \<open>v \<in> keys p\<close>] show ?thesis by simp
 qed
 
 lemma lt_less:
   assumes "p \<noteq> 0" and "\<And>u. v \<preceq>\<^sub>t u \<Longrightarrow> lookup p u = 0"
   shows "lt p \<prec>\<^sub>t v"
 proof -
   from \<open>p \<noteq> 0\<close> have "keys p \<noteq> {}"
     by simp
   have "\<forall>u\<in>keys p. u \<prec>\<^sub>t v"
   proof
     fix u::'t
     assume "u \<in> keys p"
     hence "lookup p u \<noteq> 0" by (simp add: in_keys_iff)
     hence "\<not> v \<preceq>\<^sub>t u" using assms(2)[of u] by auto
     thus "u \<prec>\<^sub>t v" by simp
   qed
   with lt_alt[OF assms(1)] ord_term_lin.Max_less_iff[OF finite_keys \<open>keys p \<noteq> {}\<close>] show ?thesis by simp
 qed
 
 lemma lt_le:
   assumes "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = 0"
   shows "lt p \<preceq>\<^sub>t v"
 proof (cases "p = 0")
   case True
   show ?thesis by (simp add: True min_term_min)
 next
   case False
   hence "keys p \<noteq> {}" by simp
   have "\<forall>u\<in>keys p. u \<preceq>\<^sub>t v"
   proof
     fix u::'t
     assume "u \<in> keys p"
     hence "lookup p u \<noteq> 0" unfolding keys_def by simp
     hence "\<not> v \<prec>\<^sub>t u" using assms[of u] by auto
     thus "u \<preceq>\<^sub>t v" by simp
   qed
   with lt_alt[OF False] ord_term_lin.Max_le_iff[OF finite_keys[of p] \<open>keys p \<noteq> {}\<close>]
     show ?thesis by simp
 qed
 
 lemma lt_gr:
   assumes "lookup p s \<noteq> 0" and "t \<prec>\<^sub>t s"
   shows "t \<prec>\<^sub>t lt p"
   using assms lt_max ord_term_lin.order.strict_trans2 by blast
 
 lemma lc_not_0:
   assumes "p \<noteq> 0"
   shows "lc p \<noteq> 0"
 proof -
   from keys_zero assms have "keys p \<noteq> {}" by auto
   from lt_alt[OF assms] ord_term_lin.Max_in[OF finite_keys this] show ?thesis by (simp add: in_keys_iff lc_def)
 qed
 
 lemma lc_eq_zero_iff: "lc p = 0 \<longleftrightarrow> p = 0"
   using lc_not_0 lc_zero by blast
 
 lemma lt_in_keys:
   assumes "p \<noteq> 0"
   shows "lt p \<in> (keys p)"
   by (metis assms in_keys_iff lc_def lc_not_0)
 
 lemma lt_monomial:
   "lt (monomial c t) = t" if "c \<noteq> 0"
   using that by (auto simp add: lt_def dest: monomial_0D)
 
 lemma lc_monomial [simp]: "lc (monomial c t) = c"
 proof (cases "c = 0")
   case True
   thus ?thesis by simp
 next
   case False
   thus ?thesis by (simp add: lc_def lt_monomial)
 qed
    
 lemma lt_le_iff: "lt p \<preceq>\<^sub>t v \<longleftrightarrow> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = 0)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (intro allI impI)
     fix u
     note \<open>lt p \<preceq>\<^sub>t v\<close>
     also assume "v \<prec>\<^sub>t u"
     finally have "lt p \<prec>\<^sub>t u" .
     hence "\<not> u \<preceq>\<^sub>t lt p" by simp
     with lt_max[of p u] show "lookup p u = 0" by blast
   qed
 next
   assume ?R
   thus ?L using lt_le by auto
 qed
 
 lemma lt_plus_eqI:
   assumes "lt p \<prec>\<^sub>t lt q"
   shows "lt (p + q) = lt q"
 proof (cases "q = 0")
   case True
   with assms have "lt p \<prec>\<^sub>t min_term" by (simp add: lt_def)
   with min_term_min[of "lt p"] show ?thesis by simp
 next
   case False
   show ?thesis
   proof (intro lt_eqI)
     from lt_gr[of p "lt q" "lt p"] assms have "lookup p (lt q) = 0" by blast
     with lookup_add[of p q "lt q"] lc_not_0[OF False] show "lookup (p + q) (lt q) \<noteq> 0"
       unfolding lc_def by simp
   next
     fix u
     assume "lookup (p + q) u \<noteq> 0"
     show "u \<preceq>\<^sub>t lt q"
     proof (rule ccontr)
       assume "\<not> u \<preceq>\<^sub>t lt q"
       hence qs: "lt q \<prec>\<^sub>t u" by simp
       with assms have "lt p \<prec>\<^sub>t u" by simp
       with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
       moreover from qs lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
       ultimately show False using \<open>lookup (p + q) u \<noteq> 0\<close> lookup_add[of p q u] by auto
     qed
   qed
 qed
 
 lemma lt_plus_eqI_2:
   assumes "lt q \<prec>\<^sub>t lt p"
   shows "lt (p + q) = lt p"
 proof (cases "p = 0")
   case True
   with assms have "lt q \<prec>\<^sub>t min_term" by (simp add: lt_def)
   with min_term_min[of "lt q"] show ?thesis by simp
 next
   case False
   show ?thesis
   proof (intro lt_eqI)
     from lt_gr[of q "lt p" "lt q"] assms have "lookup q (lt p) = 0" by blast
     with lookup_add[of p q "lt p"] lc_not_0[OF False] show "lookup (p + q) (lt p) \<noteq> 0"
       unfolding lc_def by simp
   next
     fix u
     assume "lookup (p + q) u \<noteq> 0"
     show "u \<preceq>\<^sub>t lt p"
     proof (rule ccontr)
       assume "\<not> u \<preceq>\<^sub>t lt p"
       hence ps: "lt p \<prec>\<^sub>t u" by simp
       with assms have "lt q \<prec>\<^sub>t u" by simp
       with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
       also from ps lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
       ultimately show False using \<open>lookup (p + q) u \<noteq> 0\<close> lookup_add[of p q u] by auto
     qed
   qed
 qed
 
 lemma lt_plus_eqI_3:
   assumes "lt q = lt p" and "lc p + lc q \<noteq> 0"
   shows "lt (p + q) = lt (p::'t \<Rightarrow>\<^sub>0 'b::monoid_add)"
 proof (rule lt_eqI)
   from assms(2) show "lookup (p + q) (lt p) \<noteq> 0" by (simp add: lookup_add lc_def assms(1))
 next
   fix u
   assume "lookup (p + q) u \<noteq> 0"
   hence "lookup p u + lookup q u \<noteq> 0" by (simp add: lookup_add)
   hence "lookup p u \<noteq> 0 \<or> lookup q u \<noteq> 0" by auto
   thus "u \<preceq>\<^sub>t lt p"
   proof
     assume "lookup p u \<noteq> 0"
     thus ?thesis by (rule lt_max)
   next
     assume "lookup q u \<noteq> 0"
     hence "u \<preceq>\<^sub>t lt q" by (rule lt_max)
     thus ?thesis by (simp only: assms(1))
   qed
 qed
 
 lemma lt_plus_lessE:
   assumes "lt p \<prec>\<^sub>t lt (p + q)"
   shows "lt p \<prec>\<^sub>t lt q"
 proof (rule ccontr)
   assume "\<not> lt p \<prec>\<^sub>t lt q"
   hence "lt p = lt q \<or> lt q \<prec>\<^sub>t lt p" by auto
   thus False
   proof
     assume lt_eq: "lt p = lt q"
     have "lt (p + q) \<preceq>\<^sub>t lt p"
     proof (rule lt_le)
       fix u
       assume "lt p \<prec>\<^sub>t u"
       with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
       from \<open>lt p \<prec>\<^sub>t u\<close> have "lt q \<prec>\<^sub>t u" using lt_eq by simp
       with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
       with \<open>lookup p u = 0\<close> show "lookup (p + q) u = 0" by (simp add: lookup_add)
     qed
     with assms show False by simp
   next
     assume "lt q \<prec>\<^sub>t lt p"
     from lt_plus_eqI_2[OF this] assms show False by simp
   qed
 qed
 
 lemma lt_plus_lessE_2:
   assumes "lt q \<prec>\<^sub>t lt (p + q)"
   shows "lt q \<prec>\<^sub>t lt p"
 proof (rule ccontr)
   assume "\<not> lt q \<prec>\<^sub>t lt p"
   hence "lt q = lt p \<or> lt p \<prec>\<^sub>t lt q" by auto
   thus False
   proof
     assume lt_eq: "lt q = lt p"
     have "lt (p + q) \<preceq>\<^sub>t lt q"
     proof (rule lt_le)
       fix u
       assume "lt q \<prec>\<^sub>t u"
       with lt_gr[of q u "lt q"] have "lookup q u = 0" by blast
       from \<open>lt q \<prec>\<^sub>t u\<close> have "lt p \<prec>\<^sub>t u" using lt_eq by simp
       with lt_gr[of p u "lt p"] have "lookup p u = 0" by blast
       with \<open>lookup q u = 0\<close> show "lookup (p + q) u = 0" by (simp add: lookup_add)
     qed
     with assms show False by simp
   next
     assume "lt p \<prec>\<^sub>t lt q"
     from lt_plus_eqI[OF this] assms show False by simp
   qed
 qed
 
 lemma lt_plus_lessI':
   fixes p q :: "'t \<Rightarrow>\<^sub>0 'b::monoid_add"
   assumes "p + q \<noteq> 0" and lt_eq: "lt q = lt p" and lc_eq: "lc p + lc q = 0"
   shows "lt (p + q) \<prec>\<^sub>t lt p"
 proof (rule ccontr)
   assume "\<not> lt (p + q) \<prec>\<^sub>t lt p"
   hence "lt (p + q) = lt p \<or> lt p \<prec>\<^sub>t lt (p + q)" by auto
   thus False
   proof
     assume "lt (p + q) = lt p"
     have "lookup (p + q) (lt p) = (lookup p (lt p)) + (lookup q (lt q))" unfolding lt_eq lookup_add ..
     also have "... = lc p + lc q" unfolding lc_def ..
     also have "... = 0" unfolding lc_eq by simp
     finally have "lookup (p + q) (lt p) = 0" .
     hence "lt (p + q) \<noteq> lt p" using lc_not_0[OF \<open>p + q \<noteq> 0\<close>] unfolding lc_def by auto
     with \<open>lt (p + q) = lt p\<close> show False by simp
   next
     assume "lt p \<prec>\<^sub>t lt (p + q)"
     have "lt p \<prec>\<^sub>t lt q" by (rule lt_plus_lessE, fact+)
     hence "lt p \<noteq> lt q" by simp
     with lt_eq show False by simp
   qed
 qed
 
 corollary lt_plus_lessI:
   fixes p q :: "'t \<Rightarrow>\<^sub>0 'b::group_add"
   assumes "p + q \<noteq> 0" and "lt q = lt p" and "lc q = - lc p"
   shows "lt (p + q) \<prec>\<^sub>t lt p"
   using assms(1, 2)
 proof (rule lt_plus_lessI')
   from assms(3) show "lc p + lc q = 0" by simp
 qed
 
 lemma lt_plus_distinct_eq_max:
   assumes "lt p \<noteq> lt q"
   shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
 proof (rule ord_term_lin.linorder_cases)
   assume a: "lt p \<prec>\<^sub>t lt q"
   hence "lt (p + q) = lt q" by (rule lt_plus_eqI)
   also from a have "... = ord_term_lin.max (lt p) (lt q)"
     by (simp add: ord_term_lin.max.absorb2)
   finally show ?thesis .
 next
   assume a: "lt q \<prec>\<^sub>t lt p"
   hence "lt (p + q) = lt p" by (rule lt_plus_eqI_2)
   also from a have "... = ord_term_lin.max (lt p) (lt q)"
     by (simp add: ord_term_lin.max.absorb1)
   finally show ?thesis .
 next
   assume "lt p = lt q"
   with assms show ?thesis ..
 qed
 
 lemma lt_plus_le_max: "lt (p + q) \<preceq>\<^sub>t ord_term_lin.max (lt p) (lt q)"
 proof (cases "lt p = lt q")
   case True
   show ?thesis
   proof (rule lt_le)
     fix u
     assume "ord_term_lin.max (lt p) (lt q) \<prec>\<^sub>t u"
     hence "lt p \<prec>\<^sub>t u" and "lt q \<prec>\<^sub>t u" by simp_all
     hence "lookup p u = 0" and "lookup q u = 0" using lt_max ord_term_lin.leD by blast+
     thus "lookup (p + q) u = 0" by (simp add: lookup_add)
   qed
 next
   case False
   hence "lt (p + q) = ord_term_lin.max (lt p) (lt q)" by (rule lt_plus_distinct_eq_max)
   thus ?thesis by simp
 qed
 
 lemma lt_minus_eqI: "lt p \<prec>\<^sub>t lt q \<Longrightarrow> lt (p - q) = lt q" for p q :: "'t \<Rightarrow>\<^sub>0 'b::ab_group_add"
   by (metis lt_plus_eqI_2 lt_uminus uminus_add_conv_diff)
 
 lemma lt_minus_eqI_2: "lt q \<prec>\<^sub>t lt p \<Longrightarrow> lt (p - q) = lt p" for p q :: "'t \<Rightarrow>\<^sub>0 'b::ab_group_add"
   by (metis lt_minus_eqI lt_uminus minus_diff_eq)
 
 lemma lt_minus_eqI_3:
   assumes "lt q = lt p" and "lc q \<noteq> lc p"
   shows "lt (p - q) = lt (p::'t \<Rightarrow>\<^sub>0 'b::ab_group_add)"
 proof (rule lt_eqI)
   from assms(2) show "lookup (p - q) (lt p) \<noteq> 0" by (simp add: lookup_minus lc_def assms(1))
 next
   fix u
   assume "lookup (p - q) u \<noteq> 0"
   hence "lookup p u \<noteq> lookup q u" by (simp add: lookup_minus)
   hence "lookup p u \<noteq> 0 \<or> lookup q u \<noteq> 0" by auto
   thus "u \<preceq>\<^sub>t lt p"
   proof
     assume "lookup p u \<noteq> 0"
     thus ?thesis by (rule lt_max)
   next
     assume "lookup q u \<noteq> 0"
     hence "u \<preceq>\<^sub>t lt q" by (rule lt_max)
     thus ?thesis by (simp only: assms(1))
   qed
 qed
 
 lemma lt_minus_distinct_eq_max:
   assumes "lt p \<noteq> lt (q::'t \<Rightarrow>\<^sub>0 'b::ab_group_add)"
   shows "lt (p - q) = ord_term_lin.max (lt p) (lt q)"
 proof (rule ord_term_lin.linorder_cases)
   assume a: "lt p \<prec>\<^sub>t lt q"
   hence "lt (p - q) = lt q" by (rule lt_minus_eqI)
   also from a have "... = ord_term_lin.max (lt p) (lt q)"
     by (simp add: ord_term_lin.max.absorb2)
   finally show ?thesis .
 next
   assume a: "lt q \<prec>\<^sub>t lt p"
   hence "lt (p - q) = lt p" by (rule lt_minus_eqI_2)
   also from a have "... = ord_term_lin.max (lt p) (lt q)"
     by (simp add: ord_term_lin.max.absorb1)
   finally show ?thesis .
 next
   assume "lt p = lt q"
   with assms show ?thesis ..
 qed
 
 lemma lt_minus_lessE: "lt p \<prec>\<^sub>t lt (p - q) \<Longrightarrow> lt p \<prec>\<^sub>t lt q" for p q :: "'t \<Rightarrow>\<^sub>0 'b::ab_group_add"
   using lt_minus_eqI_2 by fastforce
 
 lemma lt_minus_lessE_2: "lt q \<prec>\<^sub>t lt (p - q) \<Longrightarrow> lt q \<prec>\<^sub>t lt p" for p q :: "'t \<Rightarrow>\<^sub>0 'b::ab_group_add"
   using lt_plus_eqI_2 by fastforce
 
 lemma lt_minus_lessI: "p - q \<noteq> 0 \<Longrightarrow> lt q = lt p \<Longrightarrow> lc q = lc p \<Longrightarrow> lt (p - q) \<prec>\<^sub>t lt p"
   for p q :: "'t \<Rightarrow>\<^sub>0 'b::ab_group_add"
   by (metis (no_types, hide_lams) diff_diff_eq2 diff_self group_eq_aux lc_def lc_not_0 lookup_minus
       lt_minus_eqI ord_term_lin.antisym_conv3)
     
 lemma lt_max_keys:
   assumes "v \<in> keys p"
   shows "v \<preceq>\<^sub>t lt p"
 proof (rule lt_max)
   from assms show "lookup p v \<noteq> 0" by (simp add: in_keys_iff)
 qed
 
 lemma lt_eqI_keys:
   assumes "v \<in> keys p" and a2: "\<And>u. u \<in> keys p \<Longrightarrow> u \<preceq>\<^sub>t v"
   shows "lt p = v"
   by (rule lt_eqI, simp_all only: in_keys_iff[symmetric], fact+)
     
 lemma lt_gr_keys:
   assumes "u \<in> keys p" and "v \<prec>\<^sub>t u"
   shows "v \<prec>\<^sub>t lt p"
 proof (rule lt_gr)
   from assms(1) show "lookup p u \<noteq> 0" by (simp add: in_keys_iff)
 qed fact
 
 lemma lt_plus_eq_maxI:
   assumes "lt p = lt q \<Longrightarrow> lc p + lc q \<noteq> 0"
   shows "lt (p + q) = ord_term_lin.max (lt p) (lt q)"
 proof (cases "lt p = lt q")
   case True
   show ?thesis
   proof (rule lt_eqI_keys)
     from True have "lc p + lc q \<noteq> 0" by (rule assms)
     thus "ord_term_lin.max (lt p) (lt q) \<in> keys (p + q)"
       by (simp add: in_keys_iff lc_def lookup_add True)
   next
     fix u
     assume "u \<in> keys (p + q)"
     hence "u \<preceq>\<^sub>t lt (p + q)" by (rule lt_max_keys)
     also have "... \<preceq>\<^sub>t ord_term_lin.max (lt p) (lt q)" by (fact lt_plus_le_max)
     finally show "u \<preceq>\<^sub>t ord_term_lin.max (lt p) (lt q)" .
   qed
 next
   case False
   thus ?thesis by (rule lt_plus_distinct_eq_max)
 qed
 
 lemma lt_monom_mult:
   assumes "c \<noteq> (0::'b::semiring_no_zero_divisors)" and "p \<noteq> 0"
   shows "lt (monom_mult c t p) = t \<oplus> lt p"
 proof (intro lt_eqI)
   from assms(1) show "lookup (monom_mult c t p) (t \<oplus> lt p) \<noteq> 0"
   proof (simp add: lookup_monom_mult_plus)
     show "lookup p (lt p) \<noteq> 0"
       using assms(2) lt_in_keys by auto
   qed
 next
   fix u::'t
   assume "lookup (monom_mult c t p) u \<noteq> 0"
   hence "u \<in> keys (monom_mult c t p)" by (simp add: in_keys_iff)
   also have "... \<subseteq> (\<oplus>) t ` keys p" by (fact keys_monom_mult_subset)
   finally obtain v where "v \<in> keys p" and "u = t \<oplus> v" ..
   show "u \<preceq>\<^sub>t t \<oplus> lt p" unfolding \<open>u = t \<oplus> v\<close>
   proof (rule splus_mono)
     from \<open>v \<in> keys p\<close> show "v \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
   qed
 qed
 
 lemma lt_monom_mult_zero:
   assumes "c \<noteq> (0::'b::semiring_no_zero_divisors)"
   shows "lt (monom_mult c 0 p) = lt p"
 proof (cases "p = 0")
   case True
   show ?thesis by (simp add: True)
 next
   case False
   with assms show ?thesis by (simp add: lt_monom_mult term_simps)
 qed
 
 corollary lt_map_scale: "c \<noteq> (0::'b::semiring_no_zero_divisors) \<Longrightarrow> lt (c \<cdot> p) = lt p"
   by (simp add: map_scale_eq_monom_mult lt_monom_mult_zero)
 
 lemma lc_monom_mult [simp]: "lc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * lc p"
 proof (cases "c = 0")
   case True
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (cases "p = 0")
     case True
     thus ?thesis by simp
   next
     case False
     with \<open>c \<noteq> 0\<close> show ?thesis by (simp add: lc_def lt_monom_mult lookup_monom_mult_plus)
   qed
 qed
 
 corollary lc_map_scale [simp]: "lc (c \<cdot> p) = (c::'b::semiring_no_zero_divisors) * lc p"
   by (simp add: map_scale_eq_monom_mult)
 
 lemma (in ordered_term) lt_mult_scalar_monomial_right:
   assumes "c \<noteq> (0::'b::semiring_no_zero_divisors)" and "p \<noteq> 0"
   shows "lt (p \<odot> monomial c v) = punit.lt p \<oplus> v"
 proof (intro lt_eqI)
   from assms(1) show "lookup (p \<odot> monomial c v) (punit.lt p \<oplus> v) \<noteq> 0"
   proof (simp add: lookup_mult_scalar_monomial_right_plus)
     from assms(2) show "lookup p (punit.lt p) \<noteq> 0"
       using in_keys_iff punit.lt_in_keys by fastforce
   qed
 next
   fix u::'t
   assume "lookup (p \<odot> monomial c v) u \<noteq> 0"
   hence "u \<in> keys (p \<odot> monomial c v)" by (simp add: in_keys_iff)
   also have "... \<subseteq> (\<lambda>t. t \<oplus> v) ` keys p" by (fact keys_mult_scalar_monomial_right_subset)
   finally obtain t where "t \<in> keys p" and "u = t \<oplus> v" ..
   show "u \<preceq>\<^sub>t punit.lt p \<oplus> v" unfolding \<open>u = t \<oplus> v\<close>
   proof (rule splus_mono_left)
     from \<open>t \<in> keys p\<close> show "t \<preceq> punit.lt p" by (rule punit.lt_max_keys)
   qed
 qed
 
 lemma lc_mult_scalar_monomial_right:
   "lc (p \<odot> monomial c v) = punit.lc p * (c::'b::semiring_no_zero_divisors)"
 proof (cases "c = 0")
   case True
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (cases "p = 0")
     case True
     thus ?thesis by simp
   next
     case False
     with \<open>c \<noteq> 0\<close> show ?thesis
       by (simp add: punit.lc_def lc_def lt_mult_scalar_monomial_right lookup_mult_scalar_monomial_right_plus)
   qed
 qed
 
 lemma lookup_monom_mult_eq_zero:
   assumes "s \<oplus> lt p \<prec>\<^sub>t v"
   shows "lookup (monom_mult (c::'b::semiring_no_zero_divisors) s p) v = 0"
   by (metis assms aux lt_gr lt_monom_mult monom_mult_zero_left monom_mult_zero_right
       ord_term_lin.order.strict_implies_not_eq)
 
 lemma in_keys_monom_mult_le:
   assumes "v \<in> keys (monom_mult c t p)"
   shows "v \<preceq>\<^sub>t t \<oplus> lt p"
 proof -
   from keys_monom_mult_subset assms have "v \<in> (\<oplus>) t ` (keys p)" ..
   then obtain u where "u \<in> keys p" and "v = t \<oplus> u" ..
   from \<open>u \<in> keys p\<close> have "u \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
   thus "v \<preceq>\<^sub>t t \<oplus> lt p" unfolding \<open>v = t \<oplus> u\<close> by (rule splus_mono)
 qed
 
 lemma lt_monom_mult_le: "lt (monom_mult c t p) \<preceq>\<^sub>t t \<oplus> lt p"
   by (metis aux in_keys_monom_mult_le lt_in_keys lt_le_iff)
 
 lemma monom_mult_inj_2:
   assumes "monom_mult c t1 p = monom_mult c t2 p"
     and "c \<noteq> 0" and "(p::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors) \<noteq> 0"
   shows "t1 = t2"
 proof -
   from assms(1) have "lt (monom_mult c t1 p) = lt (monom_mult c t2 p)" by simp
   with \<open>c \<noteq> 0\<close> \<open>p \<noteq> 0\<close> have "t1 \<oplus> lt p = t2 \<oplus> lt p" by (simp add: lt_monom_mult)
   thus ?thesis by (simp add: term_simps)
 qed
 
 subsection \<open>Trailing Term and Trailing Coefficient: @{const tt} and @{const tc}\<close>
 
 lemma tt_zero [simp]: "tt 0 = min_term"
   by (simp add: tt_def)
 
 lemma tc_zero [simp]: "tc 0 = 0"
   by (simp add: tc_def)
 
 lemma tt_alt:
   assumes "p \<noteq> 0"
   shows "tt p = ord_term_lin.Min (keys p)"
   using assms unfolding tt_def by simp
 
 lemma tt_min_keys:
   assumes "v \<in> keys p"
   shows "tt p \<preceq>\<^sub>t v"
 proof -
   from assms have "keys p \<noteq> {}" by auto
   hence "p \<noteq> 0" by simp
   from tt_alt[OF this] ord_term_lin.Min_le[OF finite_keys assms] show ?thesis by simp
 qed
 
 lemma tt_min:
   assumes "lookup p v \<noteq> 0"
   shows "tt p \<preceq>\<^sub>t v"
 proof -
   from assms have "v \<in> keys p" unfolding keys_def by simp
   thus ?thesis by (rule tt_min_keys)
 qed
   
 lemma tt_in_keys:
   assumes "p \<noteq> 0"
   shows "tt p \<in> keys p"
   unfolding tt_alt[OF assms]
   by (rule ord_term_lin.Min_in, fact finite_keys, simp add: assms)
 
 lemma tt_eqI:
   assumes "v \<in> keys p" and "\<And>u. u \<in> keys p \<Longrightarrow> v \<preceq>\<^sub>t u"
   shows "tt p = v"
 proof -
   from assms(1) have "keys p \<noteq> {}" by auto
   hence "p \<noteq> 0" by simp
   from assms(1) have "tt p \<preceq>\<^sub>t v" by (rule tt_min_keys)
   moreover have "v \<preceq>\<^sub>t tt p" by (rule assms(2), rule tt_in_keys, fact \<open>p \<noteq> 0\<close>)
   ultimately show ?thesis by simp
 qed
 
 lemma tt_gr:
   assumes "\<And>u. u \<in> keys p \<Longrightarrow> v \<prec>\<^sub>t u" and "p \<noteq> 0"
   shows "v \<prec>\<^sub>t tt p"
 proof -
   from \<open>p \<noteq> 0\<close> have "keys p \<noteq> {}" by simp
   show ?thesis by (rule assms(1), rule tt_in_keys, fact \<open>p \<noteq> 0\<close>)
 qed
 
 lemma tt_less:
   assumes "u \<in> keys p" and "u \<prec>\<^sub>t v"
   shows "tt p \<prec>\<^sub>t v"
 proof -
   from \<open>u \<in> keys p\<close> have "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
   also have "... \<prec>\<^sub>t v" by fact
   finally show "tt p \<prec>\<^sub>t v" .
 qed
 
 lemma tt_ge:
   assumes "\<And>u. u \<prec>\<^sub>t v \<Longrightarrow> lookup p u = 0" and "p \<noteq> 0"
   shows "v \<preceq>\<^sub>t tt p"
 proof -
   from \<open>p \<noteq> 0\<close> have "keys p \<noteq> {}" by simp
   have "\<forall>u\<in>keys p. v \<preceq>\<^sub>t u"
   proof
     fix u::'t
     assume "u \<in> keys p"
     hence "lookup p u \<noteq> 0" unfolding keys_def by simp
     hence "\<not> u \<prec>\<^sub>t v" using assms(1)[of u] by auto
     thus "v \<preceq>\<^sub>t u" by simp
   qed
   with tt_alt[OF \<open>p \<noteq> 0\<close>] ord_term_lin.Min_ge_iff[OF finite_keys[of p] \<open>keys p \<noteq> {}\<close>]
     show ?thesis by simp
 qed
   
 lemma tt_ge_keys:
   assumes "\<And>u. u \<in> keys p \<Longrightarrow> v \<preceq>\<^sub>t u" and "p \<noteq> 0"
   shows "v \<preceq>\<^sub>t tt p"
   by (rule assms(1), rule tt_in_keys, fact)
 
 lemma tt_ge_iff: "v \<preceq>\<^sub>t tt p \<longleftrightarrow> ((p \<noteq> 0 \<or> v = min_term) \<and> (\<forall>u. u \<prec>\<^sub>t v \<longrightarrow> lookup p u = 0))"
   (is "?L \<longleftrightarrow> (?A \<and> ?B)")
 proof
   assume ?L
   show "?A \<and> ?B"
   proof (intro conjI allI impI)
     show "p \<noteq> 0 \<or> v = min_term"
     proof (cases "p = 0")
       case True
       show ?thesis
       proof (rule disjI2)
         from \<open>?L\<close> True have "v \<preceq>\<^sub>t min_term" by (simp add: tt_def)
         with min_term_min[of v] show "v = min_term" by simp
       qed
     next
       case False
       thus ?thesis ..
     qed
   next
     fix u
     assume "u \<prec>\<^sub>t v"
     also note \<open>v \<preceq>\<^sub>t tt p\<close>
     finally have "u \<prec>\<^sub>t tt p" .
     hence "\<not> tt p \<preceq>\<^sub>t u" by simp
     with tt_min[of p u] show "lookup p u = 0" by blast
   qed
 next
   assume "?A \<and> ?B"
   hence ?A and ?B by simp_all
   show ?L
   proof (cases "p = 0")
     case True
     with \<open>?A\<close> have "v = min_term" by simp
     with True show ?thesis by (simp add: tt_def)
   next
     case False
     from \<open>?B\<close> show ?thesis using tt_ge[OF _ False] by auto
   qed
 qed
 
 lemma tc_not_0:
   assumes "p \<noteq> 0"
   shows "tc p \<noteq> 0"
   unfolding tc_def in_keys_iff[symmetric] using assms by (rule tt_in_keys)
 
 lemma tt_monomial:
   assumes "c \<noteq> 0"
   shows "tt (monomial c v) = v"
 proof (rule tt_eqI)
   from keys_of_monomial[OF assms, of v] show "v \<in> keys (monomial c v)" by simp
 next
   fix u
   assume "u \<in> keys (monomial c v)"
   with keys_of_monomial[OF assms, of v] have "u = v" by simp
   thus "v \<preceq>\<^sub>t u" by simp
 qed
 
 lemma tc_monomial [simp]: "tc (monomial c t) = c"
 proof (cases "c = 0")
   case True
   thus ?thesis by simp
 next
   case False
   thus ?thesis by (simp add: tc_def tt_monomial)
 qed
   
 lemma tt_plus_eqI:
   assumes "p \<noteq> 0" and "tt p \<prec>\<^sub>t tt q"
   shows "tt (p + q) = tt p"
 proof (intro tt_eqI)
   from tt_less[of "tt p" q "tt q"] \<open>tt p \<prec>\<^sub>t tt q\<close> have "tt p \<notin> keys q" by blast
   with lookup_add[of p q "tt p"] tc_not_0[OF \<open>p \<noteq> 0\<close>] show "tt p \<in> keys (p + q)"
     unfolding in_keys_iff tc_def by simp
 next
   fix u
   assume "u \<in> keys (p + q)"
   show "tt p \<preceq>\<^sub>t u"
   proof (rule ccontr)
     assume "\<not> tt p \<preceq>\<^sub>t u"
     hence sp: "u \<prec>\<^sub>t tt p" by simp
     hence "u \<prec>\<^sub>t tt q" using \<open>tt p \<prec>\<^sub>t tt q\<close> by simp
     with tt_less[of u q "tt q"] have "u \<notin> keys q" by blast
     moreover from sp tt_less[of u p "tt p"] have "u \<notin> keys p" by blast
     ultimately show False using \<open>u \<in> keys (p + q)\<close> Poly_Mapping.keys_add[of p q] by auto
   qed
 qed
     
 lemma tt_plus_lessE:
   fixes p q
   assumes "p + q \<noteq> 0" and tt: "tt (p + q) \<prec>\<^sub>t tt p"
   shows "tt q \<prec>\<^sub>t tt p"
 proof (cases "p = 0")
   case True
   with tt show ?thesis by simp
 next
   case False
   show ?thesis
   proof (rule ccontr)
     assume "\<not> tt q \<prec>\<^sub>t tt p"
     hence "tt p = tt q \<or> tt p \<prec>\<^sub>t tt q" by auto
     thus False
     proof
       assume tt_eq: "tt p = tt q"
       have "tt p \<preceq>\<^sub>t tt (p + q)"
       proof (rule tt_ge_keys)
         fix u
         assume "u \<in> keys (p + q)"
         hence "u \<in> keys p \<union> keys q"
         proof
           show "keys (p + q) \<subseteq> keys p \<union> keys q" by (fact Poly_Mapping.keys_add)
         qed
         thus "tt p \<preceq>\<^sub>t u"
         proof
           assume "u \<in> keys p"
           thus ?thesis by (rule tt_min_keys)
         next
           assume "u \<in> keys q"
           thus ?thesis unfolding tt_eq by (rule tt_min_keys)
         qed
       qed (fact \<open>p + q \<noteq> 0\<close>)
       with tt show False by simp
     next
       assume "tt p \<prec>\<^sub>t tt q"
       from tt_plus_eqI[OF False this] tt show False by (simp add: ac_simps)
     qed
   qed
 qed
   
 lemma tt_plus_lessI:
   fixes p q :: "_ \<Rightarrow>\<^sub>0 'b::ring"
   assumes "p + q \<noteq> 0" and tt_eq: "tt q = tt p" and tc_eq: "tc q = - tc p"
   shows "tt p \<prec>\<^sub>t tt (p + q)"
 proof (rule ccontr)
   assume "\<not> tt p \<prec>\<^sub>t tt (p + q)"
   hence "tt p = tt (p + q) \<or> tt (p + q) \<prec>\<^sub>t tt p" by auto
   thus False
   proof
     assume "tt p = tt (p + q)"
     have "lookup (p + q) (tt p) = (lookup p (tt p)) + (lookup q (tt q))" unfolding tt_eq lookup_add ..
     also have "... = tc p + tc q" unfolding tc_def ..
     also have "... = 0" unfolding tc_eq by simp
     finally have "lookup (p + q) (tt p) = 0" .
     hence "tt (p + q) \<noteq> tt p" using tc_not_0[OF \<open>p + q \<noteq> 0\<close>] unfolding tc_def by auto
     with \<open>tt p = tt (p + q)\<close> show False by simp
   next
     assume "tt (p + q) \<prec>\<^sub>t tt p"
     have "tt q \<prec>\<^sub>t tt p" by (rule tt_plus_lessE, fact+)
     hence "tt q \<noteq> tt p" by simp
     with tt_eq show False by simp
   qed
 qed
 
 lemma tt_uminus [simp]: "tt (- p) = tt p"
   by (simp add: tt_def keys_uminus)
 
 lemma tc_uminus [simp]: "tc (- p) = - tc p"
   by (simp add: tc_def)
 
 lemma tt_monom_mult:
   assumes "c \<noteq> (0::'b::semiring_no_zero_divisors)" and "p \<noteq> 0"
   shows "tt (monom_mult c t p) = t \<oplus> tt p"
 proof (intro tt_eqI, rule keys_monom_multI, rule tt_in_keys, fact, fact)
   fix u
   assume "u \<in> keys (monom_mult c t p)"
   then obtain v where "v \<in> keys p" and u: "u = t \<oplus> v" by (rule keys_monom_multE)
   show "t \<oplus> tt p \<preceq>\<^sub>t u" unfolding u add.commute[of t] by (rule splus_mono, rule tt_min_keys, fact)
 qed
 
 lemma tt_map_scale: "c \<noteq> (0::'b::semiring_no_zero_divisors) \<Longrightarrow> tt (c \<cdot> p) = tt p"
   by (cases "p = 0") (simp_all add: map_scale_eq_monom_mult tt_monom_mult term_simps)
 
 lemma tc_monom_mult [simp]: "tc (monom_mult c t p) = (c::'b::semiring_no_zero_divisors) * tc p"
 proof (cases "c = 0")
   case True
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (cases "p = 0")
     case True
     thus ?thesis by simp
   next
     case False
     with \<open>c \<noteq> 0\<close> show ?thesis by (simp add: tc_def tt_monom_mult lookup_monom_mult_plus)
   qed
 qed
 
 corollary tc_map_scale [simp]: "tc (c \<cdot> p) = (c::'b::semiring_no_zero_divisors) * tc p"
   by (simp add: map_scale_eq_monom_mult)
 
 lemma in_keys_monom_mult_ge:
   assumes "v \<in> keys (monom_mult c t p)"
   shows "t \<oplus> tt p \<preceq>\<^sub>t v"
 proof -
   from keys_monom_mult_subset assms have "v \<in> (\<oplus>) t ` (keys p)" ..
   then obtain u where "u \<in> keys p" and "v = t \<oplus> u" ..
   from \<open>u \<in> keys p\<close> have "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
   thus "t \<oplus> tt p \<preceq>\<^sub>t v" unfolding \<open>v = t \<oplus> u\<close> by (rule splus_mono)
 qed
 
 lemma lt_ge_tt: "tt p \<preceq>\<^sub>t lt p"
 proof (cases "p = 0")
   case True
   show ?thesis unfolding True lt_def tt_def by simp
 next
   case False
   show ?thesis by (rule lt_max_keys, rule tt_in_keys, fact False)
 qed
 
 lemma lt_eq_tt_monomial:
   assumes "is_monomial p"
   shows "lt p = tt p"
 proof -
   from assms obtain c v where "c \<noteq> 0" and p: "p = monomial c v" by (rule is_monomial_monomial)
   from \<open>c \<noteq> 0\<close> have "lt p = v" and "tt p = v" unfolding p by (rule lt_monomial, rule tt_monomial)
   thus ?thesis by simp
 qed
 
 subsection \<open>@{const higher} and @{const lower}\<close>
 
 lemma lookup_higher: "lookup (higher p u) v = (if u \<prec>\<^sub>t v then lookup p v else 0)"
   by (auto simp add: higher_def lookup_except)
 
 lemma lookup_higher_when: "lookup (higher p u) v = (lookup p v when u \<prec>\<^sub>t v)"
   by (auto simp add: lookup_higher when_def)
 
 lemma higher_plus: "higher (p + q) v = higher p v + higher q v"
   by (rule poly_mapping_eqI, simp add: lookup_add lookup_higher)
 
 lemma higher_uminus [simp]: "higher (- p) v = -(higher p v)"
   by (rule poly_mapping_eqI, simp add: lookup_higher)
 
 lemma higher_minus: "higher (p - q) v = higher p v - higher q v"
   by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_higher)
 
 lemma higher_zero [simp]: "higher 0 t = 0"
   by (rule poly_mapping_eqI, simp add: lookup_higher)
 
 lemma higher_eq_iff: "higher p v = higher q v \<longleftrightarrow> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (intro allI impI)
     fix u
     assume "v \<prec>\<^sub>t u"
     moreover from \<open>?L\<close> have "lookup (higher p v) u = lookup (higher q v) u" by simp
     ultimately show "lookup p u = lookup q u" by (simp add: lookup_higher)
   qed
 next
   assume ?R
   show ?L
   proof (rule poly_mapping_eqI, simp add: lookup_higher, rule)
     fix u
     assume "v \<prec>\<^sub>t u"
     with \<open>?R\<close> show "lookup p u = lookup q u" by simp
   qed
 qed
 
 lemma higher_eq_zero_iff: "higher p v = 0 \<longleftrightarrow> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = 0)"
 proof -
   have "higher p v = higher 0 v \<longleftrightarrow> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup 0 u)" by (rule higher_eq_iff)
   thus ?thesis by simp
 qed
 
 lemma keys_higher: "keys (higher p v) = {u\<in>keys p. v \<prec>\<^sub>t u}"
   by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_higher)
 
 lemma higher_higher: "higher (higher p u) v = higher p (ord_term_lin.max u v)"
   by (rule poly_mapping_eqI, simp add: lookup_higher)
 
 lemma lookup_lower: "lookup (lower p u) v = (if v \<prec>\<^sub>t u then lookup p v else 0)"
   by (auto simp add: lower_def lookup_except)
 
 lemma lookup_lower_when: "lookup (lower p u) v = (lookup p v when v \<prec>\<^sub>t u)"
   by (auto simp add: lookup_lower when_def)
 
 lemma lower_plus: "lower (p + q) v = lower p v + lower q v"
   by (rule poly_mapping_eqI, simp add: lookup_add lookup_lower)
 
 lemma lower_uminus [simp]: "lower (- p) v = - lower p v"
   by (rule poly_mapping_eqI, simp add: lookup_lower)
 
 lemma lower_minus:  "lower (p - (q::_ \<Rightarrow>\<^sub>0 'b::ab_group_add)) v = lower p v - lower q v"
    by (auto intro!: poly_mapping_eqI simp: lookup_minus lookup_lower)
 
 lemma lower_zero [simp]: "lower 0 v = 0"
   by (rule poly_mapping_eqI, simp add: lookup_lower)
 
 lemma lower_eq_iff: "lower p v = lower q v \<longleftrightarrow> (\<forall>u. u \<prec>\<^sub>t v \<longrightarrow> lookup p u = lookup q u)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (intro allI impI)
     fix u
     assume "u \<prec>\<^sub>t v"
     moreover from \<open>?L\<close> have "lookup (lower p v) u = lookup (lower q v) u" by simp
     ultimately show "lookup p u = lookup q u" by (simp add: lookup_lower)
   qed
 next
   assume ?R
   show ?L
   proof (rule poly_mapping_eqI, simp add: lookup_lower, rule)
     fix u
     assume "u \<prec>\<^sub>t v"
     with \<open>?R\<close> show "lookup p u = lookup q u" by simp
   qed
 qed
 
 lemma lower_eq_zero_iff: "lower p v = 0 \<longleftrightarrow> (\<forall>u. u \<prec>\<^sub>t v \<longrightarrow> lookup p u = 0)"
 proof -
   have "lower p v = lower 0 v \<longleftrightarrow> (\<forall>u. u \<prec>\<^sub>t v \<longrightarrow> lookup p u = lookup 0 u)" by (rule lower_eq_iff)
   thus ?thesis by simp
 qed
 
 lemma keys_lower: "keys (lower p v) = {u\<in>keys p. u \<prec>\<^sub>t v}"
   by (rule set_eqI, simp only: in_keys_iff, simp add: lookup_lower)
 
 lemma lower_lower: "lower (lower p u) v = lower p (ord_term_lin.min u v)"
   by (rule poly_mapping_eqI, simp add: lookup_lower)
 
 lemma lt_higher:
   assumes "v \<prec>\<^sub>t lt p"
   shows "lt (higher p v) = lt p"
 proof (rule lt_eqI_keys, simp_all add: keys_higher, rule conjI, rule lt_in_keys, rule)
   assume "p = 0"
   hence "lt p = min_term" by (simp add: lt_def)
   with min_term_min[of v] assms show False by simp
 next
   fix u
   assume "u \<in> keys p \<and> v \<prec>\<^sub>t u"
   hence "u \<in> keys p" ..
   thus "u \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
 qed fact
 
 lemma lc_higher:
   assumes "v \<prec>\<^sub>t lt p"
   shows "lc (higher p v) = lc p"
   by (simp add: lc_def lt_higher assms lookup_higher)
 
 lemma higher_eq_zero_iff': "higher p v = 0 \<longleftrightarrow> lt p \<preceq>\<^sub>t v"
   by (simp add: higher_eq_zero_iff lt_le_iff)
 
 lemma higher_id_iff: "higher p v = p \<longleftrightarrow> (p = 0 \<or> v \<prec>\<^sub>t tt p)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (cases "p = 0")
     case True
     thus ?thesis ..
   next
     case False
     show ?thesis
     proof (rule disjI2, rule tt_gr)
       fix u
       assume "u \<in> keys p"
       hence "lookup p u \<noteq> 0" by (simp add: in_keys_iff)
       from \<open>?L\<close> have "lookup (higher p v) u = lookup p u" by simp
       hence "lookup p u = (if v \<prec>\<^sub>t u then lookup p u else 0)" by (simp only: lookup_higher)
       hence "\<not> v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = 0" by simp
       with \<open>lookup p u \<noteq> 0\<close> show "v \<prec>\<^sub>t u" by auto
     qed fact
   qed
 next
   assume ?R
   show ?L
   proof (cases "p = 0")
     case True
     thus ?thesis by simp
   next
     case False
     with \<open>?R\<close> have "v \<prec>\<^sub>t tt p" by simp
     show ?thesis
     proof (rule poly_mapping_eqI, simp add: lookup_higher, intro impI)
       fix u
       assume "\<not> v \<prec>\<^sub>t u"
       hence "u \<preceq>\<^sub>t v" by simp
       from this \<open>v \<prec>\<^sub>t tt p\<close> have "u \<prec>\<^sub>t tt p" by simp
       hence "\<not> tt p \<preceq>\<^sub>t u" by simp
       with tt_min[of p u] show "lookup p u = 0" by blast
     qed
   qed
 qed
 
 lemma tt_lower:
   assumes "tt p \<prec>\<^sub>t v"
   shows "tt (lower p v) = tt p"
 proof (cases "p = 0")
   case True
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (rule tt_eqI, simp_all add: keys_lower, rule, rule tt_in_keys)
     fix u
     assume "u \<in> keys p \<and> u \<prec>\<^sub>t v"
     hence "u \<in> keys p" ..
     thus "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
   qed fact+
 qed
 
 lemma tc_lower:
   assumes "tt p \<prec>\<^sub>t v"
   shows "tc (lower p v) = tc p"
   by (simp add: tc_def tt_lower assms lookup_lower)
 
 lemma lt_lower: "lt (lower p v) \<preceq>\<^sub>t lt p"
 proof (cases "lower p v = 0")
   case True
   thus ?thesis by (simp add: lt_def min_term_min)
 next
   case False
   show ?thesis
   proof (rule lt_le, simp add: lookup_lower, rule impI, rule ccontr)
     fix u
     assume "lookup p u \<noteq> 0"
     hence "u \<preceq>\<^sub>t lt p" by (rule lt_max)
     moreover assume "lt p \<prec>\<^sub>t u"
     ultimately show False by simp
   qed
 qed
 
 lemma lt_lower_less:
   assumes "lower p v \<noteq> 0"
   shows "lt (lower p v) \<prec>\<^sub>t v"
   using assms
 proof (rule lt_less)
   fix u
   assume "v \<preceq>\<^sub>t u"
   thus "lookup (lower p v) u = 0" by (simp add: lookup_lower_when)
 qed
 
 lemma lt_lower_eq_iff: "lt (lower p v) = lt p \<longleftrightarrow> (lt p = min_term \<or> lt p \<prec>\<^sub>t v)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (rule ccontr, simp, elim conjE)
     assume "lt p \<noteq> min_term"
     hence "min_term \<prec>\<^sub>t lt p" using min_term_min ord_term_lin.dual_order.not_eq_order_implies_strict
       by blast
     assume "\<not> lt p \<prec>\<^sub>t v"
     hence "v \<preceq>\<^sub>t lt p" by simp
     have "lt (lower p v) \<prec>\<^sub>t lt p"
     proof (cases "lower p v = 0")
       case True
       thus ?thesis using \<open>min_term \<prec>\<^sub>t lt p\<close> by (simp add: lt_def)
     next
       case False
       show ?thesis
       proof (rule lt_less)
         fix u
         assume "lt p \<preceq>\<^sub>t u"
         with \<open>v \<preceq>\<^sub>t lt p\<close> have "\<not> u \<prec>\<^sub>t v" by simp
         thus "lookup (lower p v) u = 0" by (simp add: lookup_lower)
       qed fact
     qed
     with \<open>?L\<close> show False by simp
   qed
 next
   assume ?R
   show ?L
   proof (cases "lt p = min_term")
     case True
     hence "lt p \<preceq>\<^sub>t lt (lower p v)" by (simp add: min_term_min)
     with lt_lower[of p v] show ?thesis by simp
   next
     case False
     with \<open>?R\<close> have "lt p \<prec>\<^sub>t v" by simp
     show ?thesis
     proof (rule lt_eqI_keys, simp_all add: keys_lower, rule conjI, rule lt_in_keys, rule)
       assume "p = 0"
       hence "lt p = min_term" by (simp add: lt_def)
       with False show False ..
     next
       fix u
       assume "u \<in> keys p \<and> u \<prec>\<^sub>t v"
       hence "u \<in> keys p" ..
       thus "u \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
     qed fact
   qed
 qed
 
 lemma tt_higher:
   assumes "v \<prec>\<^sub>t lt p"
   shows "tt p \<preceq>\<^sub>t tt (higher p v)"
 proof (rule tt_ge_keys, simp add: keys_higher)
   fix u
   assume "u \<in> keys p \<and> v \<prec>\<^sub>t u"
   hence "u \<in> keys p" ..
   thus "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
 next
   show "higher p v \<noteq> 0"
   proof (simp add: higher_eq_zero_iff, intro exI conjI)
     have "p \<noteq> 0"
     proof
       assume "p = 0"
       hence "lt p \<preceq>\<^sub>t v" by (simp add: lt_def min_term_min)
       with assms show False by simp
     qed
     thus "lookup p (lt p) \<noteq> 0"
       using lt_in_keys by auto 
   qed fact
 qed
 
 lemma tt_higher_eq_iff:
   "tt (higher p v) = tt p \<longleftrightarrow> ((lt p \<preceq>\<^sub>t v \<and> tt p = min_term) \<or> v \<prec>\<^sub>t tt p)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (rule ccontr, simp, elim conjE)
     assume a: "lt p \<preceq>\<^sub>t v \<longrightarrow> tt p \<noteq> min_term"
     assume "\<not> v \<prec>\<^sub>t tt p"
     hence "tt p \<preceq>\<^sub>t v" by simp
     have "tt p \<prec>\<^sub>t tt (higher p v)"
     proof (cases "higher p v = 0")
       case True
       with \<open>?L\<close> have "tt p = min_term" by (simp add: tt_def)
       with a have "v \<prec>\<^sub>t lt p" by auto
       have "lt p \<noteq> min_term"
       proof
         assume "lt p = min_term"
         with \<open>v \<prec>\<^sub>t lt p\<close> show False using min_term_min[of v] by auto
       qed
       hence "p \<noteq> 0" by (auto simp add: lt_def)
       from \<open>v \<prec>\<^sub>t lt p\<close> have "higher p v \<noteq> 0" by (simp add: higher_eq_zero_iff')
       from this True show ?thesis ..
     next
       case False
       show ?thesis
       proof (rule tt_gr)
         fix u
         assume "u \<in> keys (higher p v)"
         hence "v \<prec>\<^sub>t u" by (simp add: keys_higher)
         with \<open>tt p \<preceq>\<^sub>t v\<close> show "tt p \<prec>\<^sub>t u" by simp
       qed fact
     qed
     with \<open>?L\<close> show False by simp
   qed
 next
   assume ?R
   show ?L
   proof (cases "lt p \<preceq>\<^sub>t v \<and> tt p = min_term")
     case True
     hence "lt p \<preceq>\<^sub>t v" and "tt p = min_term" by simp_all
     from \<open>lt p \<preceq>\<^sub>t v\<close> have "higher p v = 0" by (simp add: higher_eq_zero_iff')
     with \<open>tt p = min_term\<close> show ?thesis by (simp add: tt_def)
   next
     case False
     with \<open>?R\<close> have "v \<prec>\<^sub>t tt p" by simp
     show ?thesis
     proof (rule tt_eqI, simp_all add: keys_higher, rule conjI, rule tt_in_keys, rule)
       assume "p = 0"
       hence "tt p = min_term" by (simp add: tt_def)
       with \<open>v \<prec>\<^sub>t tt p\<close> min_term_min[of v] show False by simp
     next
       fix u
       assume "u \<in> keys p \<and> v \<prec>\<^sub>t u"
       hence "u \<in> keys p" ..
       thus "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
     qed fact
   qed
 qed
 
 lemma lower_eq_zero_iff': "lower p v = 0 \<longleftrightarrow> (p = 0 \<or> v \<preceq>\<^sub>t tt p)"
   by (auto simp add: lower_eq_zero_iff tt_ge_iff)
 
 lemma lower_id_iff: "lower p v = p \<longleftrightarrow> (p = 0 \<or> lt p \<prec>\<^sub>t v)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
   proof (cases "p = 0")
     case True
     thus ?thesis ..
   next
     case False
     show ?thesis
     proof (rule disjI2, rule lt_less)
       fix u
       assume "v \<preceq>\<^sub>t u"
       from \<open>?L\<close> have "lookup (lower p v) u = lookup p u" by simp
       hence "lookup p u = (if u \<prec>\<^sub>t v then lookup p u else 0)" by (simp only: lookup_lower)
       hence "v \<preceq>\<^sub>t u \<Longrightarrow> lookup p u = 0" by (meson ord_term_lin.leD)
       with \<open>v \<preceq>\<^sub>t u\<close> show "lookup p u = 0" by simp
     qed fact
   qed
 next
   assume ?R
   show ?L
   proof (cases "p = 0", simp)
     case False
     with \<open>?R\<close> have "lt p \<prec>\<^sub>t v" by simp
     show ?thesis
     proof (rule poly_mapping_eqI, simp add: lookup_lower, intro impI)
       fix u
       assume "\<not> u \<prec>\<^sub>t v"
       hence "v \<preceq>\<^sub>t u" by simp
       with \<open>lt p \<prec>\<^sub>t v\<close> have "lt p \<prec>\<^sub>t u" by simp
       hence "\<not> u \<preceq>\<^sub>t lt p" by simp
       with lt_max[of p u] show "lookup p u = 0" by blast
     qed
   qed
 qed
     
 lemma lower_higher_commute: "higher (lower p s) t = lower (higher p t) s"
   by (rule poly_mapping_eqI, simp add: lookup_higher lookup_lower)
 
 lemma lt_lower_higher:
   assumes "v \<prec>\<^sub>t lt (lower p u)"
   shows "lt (lower (higher p v) u) = lt (lower p u)"
   by (simp add: lower_higher_commute[symmetric] lt_higher[OF assms])
 
 lemma lc_lower_higher:
   assumes "v \<prec>\<^sub>t lt (lower p u)"
   shows "lc (lower (higher p v) u) = lc (lower p u)"
   using assms by (simp add: lc_def lt_lower_higher lookup_lower lookup_higher)
 
 lemma trailing_monomial_higher:
   assumes "p \<noteq> 0"
   shows "p = (higher p (tt p)) + monomial (tc p) (tt p)"
 proof (rule poly_mapping_eqI, simp only: lookup_add)
   fix v
   show "lookup p v = lookup (higher p (tt p)) v + lookup (monomial (tc p) (tt p)) v"
   proof (cases "tt p \<preceq>\<^sub>t v")
     case True
     show ?thesis
     proof (cases "v = tt p")
       assume "v = tt p"
       hence "\<not> tt p \<prec>\<^sub>t v" by simp
       hence "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
       moreover from \<open>v = tt p\<close> have "lookup (monomial (tc p) (tt p)) v = tc p" by (simp add: lookup_single)
       moreover from \<open>v = tt p\<close> have "lookup p v = tc p" by (simp add: tc_def)
       ultimately show ?thesis by simp
     next
       assume "v \<noteq> tt p"
       from this True have "tt p \<prec>\<^sub>t v" by simp
       hence "lookup (higher p (tt p)) v = lookup p v" by (simp add: lookup_higher)
       moreover from \<open>v \<noteq> tt p\<close> have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
       ultimately show ?thesis by simp
     qed
   next
     case False
     hence "v \<prec>\<^sub>t tt p" by simp
     hence "tt p \<noteq> v" by simp
     from False have "\<not> tt p \<prec>\<^sub>t v" by simp
     have "lookup p v = 0"
     proof (rule ccontr)
       assume "lookup p v \<noteq> 0"
       from tt_min[OF this] False show False by simp
     qed
     moreover from \<open>tt p \<noteq> v\<close> have "lookup (monomial (tc p) (tt p)) v = 0" by (simp add: lookup_single)
     moreover from \<open>\<not> tt p \<prec>\<^sub>t v\<close> have "lookup (higher p (tt p)) v = 0" by (simp add: lookup_higher)
     ultimately show ?thesis by simp
   qed
 qed
 
 lemma higher_lower_decomp: "higher p v + monomial (lookup p v) v + lower p v = p"
 proof (rule poly_mapping_eqI)
   fix u
   show "lookup (higher p v + monomial (lookup p v) v + lower p v) u = lookup p u"
   proof (rule ord_term_lin.linorder_cases)
     assume "u \<prec>\<^sub>t v"
     thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
   next
     assume "u = v"
     thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
   next
     assume "v \<prec>\<^sub>t u"
     thus ?thesis by (simp add: lookup_add lookup_higher_when lookup_single lookup_lower_when)
   qed
 qed
 
 subsection \<open>@{const tail}\<close>
 
 lemma lookup_tail: "lookup (tail p) v = (if v \<prec>\<^sub>t lt p then lookup p v else 0)"
   by (simp add: lookup_lower tail_def)
 
 lemma lookup_tail_when: "lookup (tail p) v = (lookup p v when v \<prec>\<^sub>t lt p)"
   by (simp add: lookup_lower_when tail_def)
 
 lemma lookup_tail_2: "lookup (tail p) v = (if v = lt p then 0 else lookup p v)"
 proof (rule ord_term_lin.linorder_cases[of v "lt p"])
   assume "v \<prec>\<^sub>t lt p"
   hence "v \<noteq> lt p" by simp
   from this \<open>v \<prec>\<^sub>t lt p\<close> lookup_tail[of p v] show ?thesis by simp
 next
   assume "v = lt p"
   hence "\<not> v \<prec>\<^sub>t lt p" by simp
   from \<open>v = lt p\<close> this lookup_tail[of p v] show ?thesis by simp
 next
   assume "lt p \<prec>\<^sub>t v"
   hence "\<not> v \<preceq>\<^sub>t lt p" by simp
   hence cp: "lookup p v = 0"
     using lt_max by blast
   from \<open>\<not> v \<preceq>\<^sub>t lt p\<close> have "\<not> v = lt p" and "\<not> v \<prec>\<^sub>t lt p" by simp_all
   thus ?thesis using cp lookup_tail[of p v] by simp
 qed
 
 lemma leading_monomial_tail: "p = monomial (lc p) (lt p) + tail p" for p::"_ \<Rightarrow>\<^sub>0 'b::comm_monoid_add"
 proof (rule poly_mapping_eqI)
   fix v
   have "lookup p v = lookup (monomial (lc p) (lt p)) v + lookup (tail p) v"
   proof (cases "v \<preceq>\<^sub>t lt p")
     case True
     show ?thesis
     proof (cases "v = lt p")
       assume "v = lt p"
       hence "\<not> v \<prec>\<^sub>t lt p" by simp
       hence c3: "lookup (tail p) v = 0" unfolding lookup_tail[of p v] by simp
       from \<open>v = lt p\<close> have c2: "lookup (monomial (lc p) (lt p)) v = lc p" by simp
       from \<open>v = lt p\<close> have c1: "lookup p v = lc p" by (simp add: lc_def)
       from c1 c2 c3 show ?thesis by simp
     next
       assume "v \<noteq> lt p"
       from this True have "v \<prec>\<^sub>t lt p" by simp
       hence c2: "lookup (tail p) v = lookup p v" unfolding lookup_tail[of p v] by simp
       from \<open>v \<noteq> lt p\<close> have c1: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
       from c1 c2 show ?thesis by simp
     qed
   next
     case False
     hence "lt p \<prec>\<^sub>t v" by simp
     hence "lt p \<noteq> v" by simp
     from False have "\<not> v \<prec>\<^sub>t lt p" by simp
     have c1: "lookup p v = 0"
     proof (rule ccontr)
       assume "lookup p v \<noteq> 0"
       from lt_max[OF this] False show False by simp
     qed
     from \<open>lt p \<noteq> v\<close> have c2: "lookup (monomial (lc p) (lt p)) v = 0" by (simp add: lookup_single)
     from \<open>\<not> v \<prec>\<^sub>t lt p\<close> lookup_tail[of p v] have c3: "lookup (tail p) v = 0" by simp
     from c1 c2 c3 show ?thesis by simp
   qed
   thus "lookup p v = lookup (monomial (lc p) (lt p) + tail p) v" by (simp add: lookup_add)
 qed
 
 lemma tail_alt: "tail p = except p {lt p}"
   by (rule poly_mapping_eqI, simp add: lookup_tail_2 lookup_except)
 
 corollary tail_alt_2: "tail p = p - monomial (lc p) (lt p)"
 proof -
   have "p = monomial (lc p) (lt p) + tail p" by (fact leading_monomial_tail)
   also have "... = tail p + monomial (lc p) (lt p)" by (simp only: add.commute)
   finally have "p - monomial (lc p) (lt p) = (tail p + monomial (lc p) (lt p)) - monomial (lc p) (lt p)" by simp
   thus ?thesis by simp
 qed
 
 lemma tail_zero [simp]: "tail 0 = 0"
   by (simp only: tail_alt except_zero)
 
 lemma lt_tail:
   assumes "tail p \<noteq> 0"
   shows "lt (tail p) \<prec>\<^sub>t lt p"
 proof (intro lt_less)
   fix u
   assume "lt p \<preceq>\<^sub>t u"
   hence "\<not> u \<prec>\<^sub>t lt p" by simp
   thus "lookup (tail p) u = 0" unfolding lookup_tail[of p u] by simp
 qed fact
 
 lemma keys_tail: "keys (tail p) = keys p - {lt p}"
   by (simp add: tail_alt keys_except)
 
 lemma tail_monomial: "tail (monomial c v) = 0"
   by (metis (no_types, lifting) lookup_tail_2 lookup_single_not_eq lt_less lt_monomial
       ord_term_lin.dual_order.strict_implies_not_eq single_zero tail_zero)
 
 lemma (in ordered_term) mult_scalar_tail_rec_left:
   "p \<odot> q = monom_mult (punit.lc p) (punit.lt p) q + (punit.tail p) \<odot> q"
   unfolding punit.lc_def punit.tail_alt by (fact mult_scalar_rec_left)
 
 lemma mult_scalar_tail_rec_right: "p \<odot> q = p \<odot> monomial (lc q) (lt q) + p \<odot> tail q"
   unfolding tail_alt lc_def by (rule mult_scalar_rec_right)
 
 lemma lt_tail_max:
   assumes "tail p \<noteq> 0" and "v \<in> keys p" and "v \<prec>\<^sub>t lt p"
   shows "v \<preceq>\<^sub>t lt (tail p)"
 proof (rule lt_max_keys, simp add: keys_tail assms(2))
   from assms(3) show "v \<noteq> lt p" by auto
 qed
 
 lemma keys_tail_less_lt:
   assumes "v \<in> keys (tail p)"
   shows "v \<prec>\<^sub>t lt p"
   using assms by (meson in_keys_iff lookup_tail)
 
 lemma tt_tail:
   assumes "tail p \<noteq> 0"
   shows "tt (tail p) = tt p"
 proof (rule tt_eqI, simp_all add: keys_tail)
   from assms have "p \<noteq> 0" using tail_zero by auto
   show "tt p \<in> keys p \<and> tt p \<noteq> lt p"
   proof (rule conjI, rule tt_in_keys, fact)
     have "tt p \<prec>\<^sub>t lt p"
       by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
     thus "tt p \<noteq> lt p" by simp
   qed
 next
   fix u
   assume "u \<in> keys p \<and> u \<noteq> lt p"
   hence "u \<in> keys p" ..
   thus "tt p \<preceq>\<^sub>t u" by (rule tt_min_keys)
 qed
 
 lemma tc_tail:
   assumes "tail p \<noteq> 0"
   shows "tc (tail p) = tc p"
 proof (simp add: tc_def tt_tail[OF assms] lookup_tail_2, rule)
   assume "tt p = lt p"
   moreover have "tt p \<prec>\<^sub>t lt p"
     by (metis assms lower_eq_zero_iff' tail_def ord_term_lin.le_less_linear)
   ultimately show "lookup p (lt p) = 0" by simp
 qed
 
 lemma tt_tail_min:
   assumes "s \<in> keys p"
   shows "tt (tail p) \<preceq>\<^sub>t s"
 proof (cases "tail p = 0")
   case True
   hence "tt (tail p) = min_term" by (simp add: tt_def)
   thus ?thesis by (simp add: min_term_min)
 next
   case False
   from assms show ?thesis by (simp add: tt_tail[OF False], rule tt_min_keys)
 qed
 
 lemma tail_monom_mult:
   "tail (monom_mult c t p) = monom_mult (c::'b::semiring_no_zero_divisors) t (tail p)"
 proof (cases "p = 0")
   case True
   hence "tail p = 0" and "monom_mult c t p = 0" by simp_all
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (cases "c = 0")
     case True
     hence "monom_mult c t p = 0" and "monom_mult c t (tail p) = 0" by simp_all
     thus ?thesis by simp
   next
     case False
     let ?a = "monom_mult c t p"
     let ?b = "monom_mult c t (tail p)"
     from \<open>p \<noteq> 0\<close> False have "?a \<noteq> 0" by (simp add: monom_mult_eq_zero_iff)
     from False \<open>p \<noteq> 0\<close> have lt_a: "lt ?a = t \<oplus> lt p" by (rule lt_monom_mult)
     show ?thesis
     proof (rule poly_mapping_eqI, simp add: lookup_tail lt_a, intro conjI impI)
       fix u
       assume "u \<prec>\<^sub>t t \<oplus> lt p"
       show "lookup (monom_mult c t p) u = lookup (monom_mult c t (tail p)) u"
       proof (cases "t adds\<^sub>p u")
         case True
         then obtain v where "u = t \<oplus> v" by (rule adds_ppE)
         from \<open>u \<prec>\<^sub>t t \<oplus> lt p\<close> have "v \<prec>\<^sub>t lt p" unfolding \<open>u = t \<oplus> v\<close> by (rule ord_term_strict_canc) 
         hence "lookup p v = lookup (tail p) v" by (simp add: lookup_tail)
         thus ?thesis by (simp add: \<open>u = t \<oplus> v\<close> lookup_monom_mult_plus)
       next
         case False
         hence "lookup ?a u = 0" by (simp add: lookup_monom_mult)
         moreover have "lookup ?b u = 0"
           proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF \<open>c \<noteq> 0\<close>])
           assume "u \<in> (\<oplus>) t ` keys (tail p)"
           then obtain v where "u = t \<oplus> v" by auto
           hence "t adds\<^sub>p u" by (simp add: term_simps)
           with False show False ..
         qed
         ultimately show ?thesis by simp
       qed
     next
       fix u
       assume "\<not> u \<prec>\<^sub>t t \<oplus> lt p"
       hence "t \<oplus> lt p \<preceq>\<^sub>t u" by simp
       show "lookup (monom_mult c t (tail p)) u = 0"
       proof (rule ccontr, simp only: in_keys_iff[symmetric] keys_monom_mult[OF False])
         assume "u \<in> (\<oplus>) t ` keys (tail p)"
         then obtain v where "v \<in> keys (tail p)" and "u = t \<oplus> v" by auto
         from \<open>t \<oplus> lt p \<preceq>\<^sub>t u\<close> have "lt p \<preceq>\<^sub>t v" unfolding \<open>u = t \<oplus> v\<close> by (rule ord_term_canc)
         from \<open>v \<in> keys (tail p)\<close> have "v \<in> keys p" and "v \<noteq> lt p" by (simp_all add: keys_tail)
         from \<open>v \<in> keys p\<close> have "v \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
         with \<open>lt p \<preceq>\<^sub>t v\<close> have "v = lt p " by simp
         with \<open>v \<noteq> lt p\<close> show False ..
       qed
     qed
   qed
 qed
 
 lemma keys_plus_eq_lt_tt_D:
   assumes "keys (p + q) = {lt p, tt q}" and "lt q \<prec>\<^sub>t lt p" and "tt q \<prec>\<^sub>t tt (p::_ \<Rightarrow>\<^sub>0 'b::comm_monoid_add)"
   shows "tail p + higher q (tt q) = 0"
 proof -
   note assms(3)
   also have "... \<preceq>\<^sub>t lt p" by (rule lt_ge_tt)
   finally have "tt q \<prec>\<^sub>t lt p" .
   hence "lt p \<noteq> tt q" by simp
   have "q \<noteq> 0"
   proof
     assume "q = 0"
     hence "tt q = min_term" by (simp add: tt_def)
     with \<open>q = 0\<close> assms(1) have "keys p = {lt p, min_term}" by simp
     hence "min_term \<in> keys p" by simp
     hence "tt p \<preceq>\<^sub>t tt q" unfolding \<open>tt q = min_term\<close> by (rule tt_min_keys)
     with assms(3) show False by simp
   qed
   hence "tc q \<noteq> 0" by (rule tc_not_0)
   have "p = monomial (lc p) (lt p) + tail p" by (rule leading_monomial_tail)
   moreover from \<open>q \<noteq> 0\<close> have "q = higher q (tt q) + monomial (tc q) (tt q)" by (rule trailing_monomial_higher)
   ultimately have pq: "p + q = (monomial (lc p) (lt p) + monomial (tc q) (tt q)) + (tail p + higher q (tt q))"
     (is "_ = (?m1 + ?m2) + ?b") by (simp add: algebra_simps)
   have keys_m1: "keys ?m1 = {lt p}"
   proof (rule keys_of_monomial, rule lc_not_0, rule)
     assume "p = 0"
     with assms(2) have "lt q \<prec>\<^sub>t min_term" by (simp add: lt_def)
     with min_term_min[of "lt q"] show False by simp
   qed
   moreover from \<open>tc q \<noteq> 0\<close> have keys_m2: "keys ?m2 = {tt q}" by (rule keys_of_monomial)
   ultimately have keys_m1_m2: "keys (?m1 + ?m2) = {lt p, tt q}"
     using \<open>lt p \<noteq> tt q\<close> keys_plus_eqI[of ?m1 ?m2] by auto
   show ?thesis
   proof (rule ccontr)
     assume "?b \<noteq> 0"
     hence "keys ?b \<noteq> {}" by simp
     then obtain t where "t \<in> keys ?b" by blast
     hence t_in: "t \<in> keys (tail p) \<union> keys (higher q (tt q))"
       using Poly_Mapping.keys_add[of "tail p" "higher q (tt q)"] by blast
     hence "t \<noteq> lt p"
     proof (rule, simp add: keys_tail, simp add: keys_higher, elim conjE)
       assume "t \<in> keys q"
       hence "t \<preceq>\<^sub>t lt q" by (rule lt_max_keys)
       from this assms(2) show ?thesis by simp
     qed
     moreover from t_in have "t \<noteq> tt q"
     proof (rule, simp add: keys_tail, elim conjE)
       assume "t \<in> keys p"
       hence "tt p \<preceq>\<^sub>t t" by (rule tt_min_keys)
       with assms(3) show ?thesis by simp
     next
       assume "t \<in> keys (higher q (tt q))"
       thus ?thesis by (auto simp only: keys_higher)
     qed
     ultimately have "t \<notin> keys (?m1 + ?m2)" by (simp add: keys_m1_m2)
     moreover from in_keys_plusI2[OF \<open>t \<in> keys ?b\<close> this] have "t \<in> keys (?m1 + ?m2)"
       by (simp only: keys_m1_m2 pq[symmetric] assms(1))
     ultimately show False ..
   qed
 qed
 
 subsection \<open>Order Relation on Polynomials\<close>
 
 definition ord_strict_p :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool" (infixl "\<prec>\<^sub>p" 50) where
   "p \<prec>\<^sub>p q \<longleftrightarrow> (\<exists>v. lookup p v = 0 \<and> lookup q v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u))"
 
 definition ord_p :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool" (infixl "\<preceq>\<^sub>p" 50) where
   "ord_p p q \<equiv> (p \<prec>\<^sub>p q \<or> p = q)"
 
 lemma ord_strict_pI:
   assumes "lookup p v = 0" and "lookup q v \<noteq> 0" and "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u"
   shows "p \<prec>\<^sub>p q"
   unfolding ord_strict_p_def using assms by blast
 
 lemma ord_strict_pE:
   assumes "p \<prec>\<^sub>p q"
   obtains v where "lookup p v = 0" and "lookup q v \<noteq> 0" and "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u"
   using assms unfolding ord_strict_p_def by blast
 
 lemma not_ord_pI:
   assumes "lookup p v \<noteq> lookup q v" and "lookup p v \<noteq> 0" and "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u"
   shows "\<not> p \<preceq>\<^sub>p q"
 proof
   assume "p \<preceq>\<^sub>p q"
   hence "p \<prec>\<^sub>p q \<or> p = q" by (simp only: ord_p_def)
   thus False
   proof
     assume "p \<prec>\<^sub>p q"
     then obtain v' where 1: "lookup p v' = 0" and 2: "lookup q v' \<noteq> 0"
       and 3: "\<And>u. v' \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u" by (rule ord_strict_pE, blast)
     from 1 2 have "lookup p v' \<noteq> lookup q v'" by simp
     hence "\<not> v \<prec>\<^sub>t v'" using assms(3) by blast
     hence "v' \<prec>\<^sub>t v \<or> v' = v" by auto
     thus ?thesis
     proof
       assume "v' \<prec>\<^sub>t v"
       hence "lookup p v = lookup q v" by (rule 3)
       with assms(1) show ?thesis ..
     next
       assume "v' = v"
       with assms(2) 1 show ?thesis by auto
     qed
   next
     assume "p = q"
     hence "lookup p v = lookup q v" by simp
     with assms(1) show ?thesis ..
   qed
 qed
 
 corollary not_ord_strict_pI:
   assumes "lookup p v \<noteq> lookup q v" and "lookup p v \<noteq> 0" and "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u"
   shows "\<not> p \<prec>\<^sub>p q"
 proof -
   from assms have "\<not> p \<preceq>\<^sub>p q" by (rule not_ord_pI)
   thus ?thesis by (simp add: ord_p_def)
 qed
 
 lemma ord_strict_higher: "p \<prec>\<^sub>p q \<longleftrightarrow> (\<exists>v. lookup p v = 0 \<and> lookup q v \<noteq> 0 \<and> higher p v = higher q v)"
   unfolding ord_strict_p_def higher_eq_iff ..
 
 lemma ord_strict_p_asymmetric:
   assumes "p \<prec>\<^sub>p q"
   shows "\<not> q \<prec>\<^sub>p p"
   using assms unfolding ord_strict_p_def
 proof
   fix v1::'t
   assume "lookup p v1 = 0 \<and> lookup q v1 \<noteq> 0 \<and> (\<forall>u. v1 \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u)"
   hence "lookup p v1 = 0" and "lookup q v1 \<noteq> 0" and v1: "\<forall>u. v1 \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u"
     by auto
   show "\<not> (\<exists>v. lookup q v = 0 \<and> lookup p v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup q u = lookup p u))"
   proof (intro notI, erule exE)
     fix v2::'t
     assume "lookup q v2 = 0 \<and> lookup p v2 \<noteq> 0 \<and> (\<forall>u. v2 \<prec>\<^sub>t u \<longrightarrow> lookup q u = lookup p u)"
     hence "lookup q v2 = 0" and "lookup p v2 \<noteq> 0" and v2: "\<forall>u. v2 \<prec>\<^sub>t u \<longrightarrow> lookup q u = lookup p u"
       by auto
     show False
     proof (rule ord_term_lin.linorder_cases)
       assume "v1 \<prec>\<^sub>t v2"
       from v1[rule_format, OF this] \<open>lookup q v2 = 0\<close> \<open>lookup p v2 \<noteq> 0\<close> show ?thesis by simp
     next
       assume "v1 = v2"
       thus ?thesis using \<open>lookup p v1 = 0\<close> \<open>lookup p v2 \<noteq> 0\<close> by simp
     next
       assume "v2 \<prec>\<^sub>t v1"
       from v2[rule_format, OF this] \<open>lookup p v1 = 0\<close> \<open>lookup q v1 \<noteq> 0\<close> show ?thesis by simp
     qed
   qed
 qed
 
 lemma ord_strict_p_irreflexive: "\<not> p \<prec>\<^sub>p p"
   unfolding ord_strict_p_def
 proof (intro notI, erule exE)
   fix v::'t
   assume "lookup p v = 0 \<and> lookup p v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup p u)"
   hence "lookup p v = 0" and "lookup p v \<noteq> 0" by auto
   thus False by simp
 qed
 
 lemma ord_strict_p_transitive:
   assumes "a \<prec>\<^sub>p b" and "b \<prec>\<^sub>p c"
   shows "a \<prec>\<^sub>p c"
 proof -
   from \<open>a \<prec>\<^sub>p b\<close> obtain v1 where "lookup a v1 = 0"
                             and "lookup b v1 \<noteq> 0"
                             and v1[rule_format]: "(\<forall>u. v1 \<prec>\<^sub>t u \<longrightarrow> lookup a u = lookup b u)"
     unfolding ord_strict_p_def by auto
   from \<open>b \<prec>\<^sub>p c\<close> obtain v2 where "lookup b v2 = 0"
                             and "lookup c v2 \<noteq> 0"
                             and v2[rule_format]: "(\<forall>u. v2 \<prec>\<^sub>t u \<longrightarrow> lookup b u = lookup c u)"
     unfolding ord_strict_p_def by auto
   show "a \<prec>\<^sub>p c"
   proof (rule ord_term_lin.linorder_cases)
     assume "v1 \<prec>\<^sub>t v2"
     show ?thesis unfolding ord_strict_p_def
     proof
       show "lookup a v2 = 0 \<and> lookup c v2 \<noteq> 0 \<and> (\<forall>u. v2 \<prec>\<^sub>t u \<longrightarrow> lookup a u = lookup c u)"
       proof (intro conjI allI impI)
         from \<open>lookup b v2 = 0\<close> v1[OF \<open>v1 \<prec>\<^sub>t v2\<close>] show "lookup a v2 = 0" by simp
       next
         from \<open>lookup c v2 \<noteq> 0\<close> show "lookup c v2 \<noteq> 0" .
       next
         fix u
         assume "v2 \<prec>\<^sub>t u"
         from ord_term_lin.less_trans[OF \<open>v1 \<prec>\<^sub>t v2\<close> this] have "v1 \<prec>\<^sub>t u" .
         from v2[OF \<open>v2 \<prec>\<^sub>t u\<close>] v1[OF this] show "lookup a u = lookup c u" by simp
       qed
     qed
   next
     assume "v2 \<prec>\<^sub>t v1"
     show ?thesis unfolding ord_strict_p_def
     proof
       show "lookup a v1 = 0 \<and> lookup c v1 \<noteq> 0 \<and> (\<forall>u. v1 \<prec>\<^sub>t u \<longrightarrow> lookup a u = lookup c u)"
       proof (intro conjI allI impI)
         from \<open>lookup a v1 = 0\<close> show "lookup a v1 = 0" .
       next
         from \<open>lookup b v1 \<noteq> 0\<close> v2[OF \<open>v2 \<prec>\<^sub>t v1\<close>] show "lookup c v1 \<noteq> 0" by simp
       next
         fix u
         assume "v1 \<prec>\<^sub>t u"
         from ord_term_lin.less_trans[OF \<open>v2 \<prec>\<^sub>t v1\<close> this] have "v2 \<prec>\<^sub>t u" .
         from v1[OF \<open>v1 \<prec>\<^sub>t u\<close>] v2[OF this] show "lookup a u = lookup c u" by simp
       qed
     qed
   next
     assume "v1 = v2"
     thus ?thesis using \<open>lookup b v1 \<noteq> 0\<close> \<open>lookup b v2 = 0\<close> by simp
   qed
 qed
 
 sublocale order ord_p ord_strict_p
 proof (intro order_strictI)
   fix p q :: "'t \<Rightarrow>\<^sub>0 'b"
   show "(p \<preceq>\<^sub>p q) = (p \<prec>\<^sub>p q \<or> p = q)" unfolding ord_p_def ..
 next
   fix p q :: "'t \<Rightarrow>\<^sub>0 'b"
   assume "p \<prec>\<^sub>p q"
   thus "\<not> q \<prec>\<^sub>p p" by (rule ord_strict_p_asymmetric)
 next
   fix p::"'t \<Rightarrow>\<^sub>0 'b"
   show "\<not> p \<prec>\<^sub>p p" by (fact ord_strict_p_irreflexive)
 next
   fix a b c :: "'t \<Rightarrow>\<^sub>0 'b"
   assume "a \<prec>\<^sub>p b" and "b \<prec>\<^sub>p c"
   thus "a \<prec>\<^sub>p c" by (rule ord_strict_p_transitive)
 qed
 
 lemma ord_p_zero_min: "0 \<preceq>\<^sub>p p"
   unfolding ord_p_def ord_strict_p_def
 proof (cases "p = 0")
   case True
   thus "(\<exists>v. lookup 0 v = 0 \<and> lookup p v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup 0 u = lookup p u)) \<or> 0 = p"
     by auto
 next
   case False
   show "(\<exists>v. lookup 0 v = 0 \<and> lookup p v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup 0 u = lookup p u)) \<or> 0 = p"
   proof
     show "(\<exists>v. lookup 0 v = 0 \<and> lookup p v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup 0 u = lookup p u))"
     proof
       show "lookup 0 (lt p) = 0 \<and> lookup p (lt p) \<noteq> 0 \<and> (\<forall>u. (lt p) \<prec>\<^sub>t u \<longrightarrow> lookup 0 u = lookup p u)"
       proof (intro conjI allI impI)
         show "lookup 0 (lt p) = 0" by (transfer, simp)
       next
         from lc_not_0[OF False] show "lookup p (lt p) \<noteq> 0" unfolding lc_def .
       next
         fix u
         assume "lt p \<prec>\<^sub>t u"
         hence "\<not> u \<preceq>\<^sub>t lt p" by simp
         hence "lookup p u = 0" using lt_max[of p u] by metis
         thus "lookup 0 u = lookup p u" by simp
       qed
     qed
   qed
 qed
 
 lemma lt_ord_p:
   assumes "lt p \<prec>\<^sub>t lt q"
   shows "p \<prec>\<^sub>p q"
 proof -
   have "q \<noteq> 0"
   proof
     assume "q = 0"
     with assms have "lt p \<prec>\<^sub>t min_term" by (simp add: lt_def)
     with min_term_min[of "lt p"] show False by simp
   qed
   show ?thesis unfolding ord_strict_p_def
   proof (intro exI conjI allI impI)
     show "lookup p (lt q) = 0"
     proof (rule ccontr)
       assume "lookup p (lt q) \<noteq> 0"
       from lt_max[OF this] \<open>lt p \<prec>\<^sub>t lt q\<close> show False by simp
     qed
   next
     from lc_not_0[OF \<open>q \<noteq> 0\<close>] show "lookup q (lt q) \<noteq> 0" unfolding lc_def .
   next
     fix u
     assume "lt q \<prec>\<^sub>t u"
     hence "lt p \<prec>\<^sub>t u" using \<open>lt p \<prec>\<^sub>t lt q\<close> by simp
     have c1: "lookup q u = 0"
     proof (rule ccontr)
       assume "lookup q u \<noteq> 0"
       from lt_max[OF this] \<open>lt q \<prec>\<^sub>t u\<close> show False by simp
     qed
     have c2: "lookup p u = 0"
     proof (rule ccontr)
       assume "lookup p u \<noteq> 0"
       from lt_max[OF this] \<open>lt p \<prec>\<^sub>t u\<close> show False by simp
     qed
     from c1 c2 show "lookup p u = lookup q u" by simp
   qed
 qed
 
 lemma ord_p_lt:
   assumes "p \<preceq>\<^sub>p q"
   shows "lt p \<preceq>\<^sub>t lt q"
 proof (rule ccontr)
   assume "\<not> lt p \<preceq>\<^sub>t lt q"
   hence "lt q \<prec>\<^sub>t lt p" by simp
   from lt_ord_p[OF this] \<open>p \<preceq>\<^sub>p q\<close> show False by simp
 qed
 
 lemma ord_p_tail:
   assumes "p \<noteq> 0" and "lt p = lt q" and "p \<prec>\<^sub>p q"
   shows "tail p \<prec>\<^sub>p tail q"
   using assms unfolding ord_strict_p_def
 proof -
   assume "p \<noteq> 0" and "lt p = lt q"
     and "\<exists>v. lookup p v = 0 \<and> lookup q v \<noteq> 0 \<and> (\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u)"
   then obtain v where "lookup p v = 0"
                   and "lookup q v \<noteq> 0"
                   and a: "\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u" by auto
   from lt_max[OF \<open>lookup q v \<noteq> 0\<close>] \<open>lt p = lt q\<close> have "v \<prec>\<^sub>t lt p \<or> v = lt p" by auto
   hence "v \<prec>\<^sub>t lt p"
   proof
     assume "v \<prec>\<^sub>t lt p"
     thus ?thesis .
   next
     assume "v = lt p"
     thus ?thesis using lc_not_0[OF \<open>p \<noteq> 0\<close>] \<open>lookup p v = 0\<close> unfolding lc_def by auto
   qed
   have pt: "lookup (tail p) v = lookup p v" using lookup_tail[of p v] \<open>v \<prec>\<^sub>t lt p\<close> by simp
   have "q \<noteq> 0"
   proof
     assume "q = 0"
     hence  "p \<prec>\<^sub>p 0" using \<open>p \<prec>\<^sub>p q\<close> by simp
     hence "\<not> 0 \<preceq>\<^sub>p p" by auto
     thus False using ord_p_zero_min[of p] by simp
   qed
   have qt: "lookup (tail q) v = lookup q v"
     using lookup_tail[of q v] \<open>v \<prec>\<^sub>t lt p\<close> \<open>lt p = lt q\<close> by simp
   show "\<exists>w. lookup (tail p) w = 0 \<and> lookup (tail q) w \<noteq> 0 \<and>
         (\<forall>u. w \<prec>\<^sub>t u \<longrightarrow> lookup (tail p) u = lookup (tail q) u)"
   proof (intro exI conjI allI impI)
     from pt \<open>lookup p v = 0\<close> show "lookup (tail p) v = 0" by simp
   next
     from qt \<open>lookup q v \<noteq> 0\<close> show "lookup (tail q) v \<noteq> 0" by simp
   next
     fix u
     assume "v \<prec>\<^sub>t u"
     from a[rule_format, OF \<open>v \<prec>\<^sub>t u\<close>] lookup_tail[of p u] lookup_tail[of q u]
       \<open>lt p = lt q\<close> show "lookup (tail p) u = lookup (tail q) u" by simp
   qed
 qed
 
 lemma tail_ord_p:
   assumes "p \<noteq> 0"
   shows "tail p \<prec>\<^sub>p p"
 proof (cases "tail p = 0")
   case True
   with ord_p_zero_min[of p] \<open>p \<noteq> 0\<close> show ?thesis by simp
 next
   case False
   from lt_tail[OF False] show ?thesis by (rule lt_ord_p)
 qed
 
 lemma higher_lookup_eq_zero:
   assumes pt: "lookup p v = 0" and hp: "higher p v = 0" and le: "q \<preceq>\<^sub>p p"
   shows "(lookup q v = 0) \<and> (higher q v) = 0"
 using le unfolding ord_p_def
 proof
   assume "q \<prec>\<^sub>p p"
   thus ?thesis unfolding ord_strict_p_def
   proof
     fix w
     assume "lookup q w = 0 \<and> lookup p w \<noteq> 0 \<and> (\<forall>u. w \<prec>\<^sub>t u \<longrightarrow> lookup q u = lookup p u)"
     hence qs: "lookup q w = 0" and ps: "lookup p w \<noteq> 0" and u: "\<forall>u. w \<prec>\<^sub>t u \<longrightarrow> lookup q u = lookup p u"
       by auto
     from hp have pu: "\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = 0" by (simp only: higher_eq_zero_iff)
     from pu[rule_format, of w] ps have "\<not> v \<prec>\<^sub>t w" by auto
     hence "w \<preceq>\<^sub>t v" by simp
     hence "w \<prec>\<^sub>t v \<or> w = v" by auto
     hence st: "w \<prec>\<^sub>t v"
     proof (rule disjE, simp_all)
       assume "w = v"
       from this pt ps show False by simp
     qed
     show ?thesis
     proof
       from u[rule_format, OF st] pt show "lookup q v = 0" by simp
     next
       have "\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup q u = 0"
       proof (intro allI, intro impI)
         fix u
         assume "v \<prec>\<^sub>t u"
         from this st have "w \<prec>\<^sub>t u" by simp
         from u[rule_format, OF this] pu[rule_format, OF \<open>v \<prec>\<^sub>t u\<close>] show "lookup q u = 0" by simp
       qed
       thus "higher q v = 0" by (simp only: higher_eq_zero_iff)
     qed
   qed
 next
   assume "q = p"
   thus ?thesis using assms by simp
 qed
 
 lemma ord_strict_p_recI:
   assumes "lt p = lt q" and "lc p = lc q" and tail: "tail p \<prec>\<^sub>p tail q"
   shows "p \<prec>\<^sub>p q"
 proof -
   from tail obtain v where pt: "lookup (tail p) v = 0"
                       and qt: "lookup (tail q) v \<noteq> 0"
                       and a: "\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup (tail p) u = lookup (tail q) u"
     unfolding ord_strict_p_def by auto
   from qt lookup_zero[of v] have "tail q \<noteq> 0" by auto
   from lt_max[OF qt] lt_tail[OF this] have "v \<prec>\<^sub>t lt q" by simp
   hence "v \<prec>\<^sub>t lt p" using \<open>lt p = lt q\<close> by simp
   show ?thesis unfolding ord_strict_p_def
   proof (rule exI[of _ v], intro conjI allI impI)
     from lookup_tail[of p v] \<open>v \<prec>\<^sub>t lt p\<close> pt show "lookup p v = 0" by simp
   next
     from lookup_tail[of q v] \<open>v \<prec>\<^sub>t lt q\<close> qt show "lookup q v \<noteq> 0" by simp
   next
     fix u
     assume "v \<prec>\<^sub>t u"
     from this a have s: "lookup (tail p) u = lookup (tail q) u" by simp
     show "lookup p u = lookup q u"
     proof (cases "u = lt p")
       case True
       from True \<open>lc p = lc q\<close> \<open>lt p = lt q\<close> show ?thesis unfolding lc_def by simp
     next
       case False
       from False s lookup_tail_2[of p u] lookup_tail_2[of q u] \<open>lt p = lt q\<close> show ?thesis by simp
     qed
   qed
 qed
 
 lemma ord_strict_p_recE1:
   assumes "p \<prec>\<^sub>p q"
   shows "q \<noteq> 0"
 proof
   assume "q = 0"
   from this assms ord_p_zero_min[of p] show False by simp
 qed
 
 lemma ord_strict_p_recE2:
   assumes "p \<noteq> 0" and "p \<prec>\<^sub>p q" and "lt p = lt q"
   shows "lc p = lc q"
 proof -
   from \<open>p \<prec>\<^sub>p q\<close> obtain v where pt: "lookup p v = 0"
                           and qt: "lookup q v \<noteq> 0"
                           and a: "\<forall>u. v \<prec>\<^sub>t u \<longrightarrow> lookup p u = lookup q u"
     unfolding ord_strict_p_def by auto
   show ?thesis
   proof (cases "v \<prec>\<^sub>t lt p")
     case True
     from this a have "lookup p (lt p) = lookup q (lt p)" by simp
     thus ?thesis using \<open>lt p = lt q\<close> unfolding lc_def by simp
   next
     case False
     from this lt_max[OF qt] \<open>lt p = lt q\<close> have "v = lt p" by simp
     from this lc_not_0[OF \<open>p \<noteq> 0\<close>] pt show ?thesis unfolding lc_def by auto
   qed
 qed
 
 lemma ord_strict_p_rec [code]:
   "p \<prec>\<^sub>p q =
   (q \<noteq> 0 \<and>
     (p = 0 \<or>
       (let v1 = lt p; v2 = lt q in
         (v1 \<prec>\<^sub>t v2 \<or> (v1 = v2 \<and> lookup p v1 = lookup q v2 \<and> lower p v1 \<prec>\<^sub>p lower q v2))
       )
     )
    )"
   (is "?L = ?R")
 proof
   assume ?L
   show ?R
   proof (intro conjI, rule ord_strict_p_recE1, fact)
     have "((lt p = lt q \<and> lc p = lc q \<and> tail p \<prec>\<^sub>p tail q) \<or> lt p \<prec>\<^sub>t lt q) \<or> p = 0"
     proof (intro disjCI)
       assume "p \<noteq> 0" and nl: "\<not> lt p \<prec>\<^sub>t lt q"
       from \<open>?L\<close> have "p \<preceq>\<^sub>p q" by simp
       from ord_p_lt[OF this] nl have "lt p = lt q" by simp
       show "lt p = lt q \<and> lc p = lc q \<and> tail p \<prec>\<^sub>p tail q"
         by (intro conjI, fact, rule ord_strict_p_recE2, fact+, rule ord_p_tail, fact+)
     qed
     thus "p = 0 \<or>
             (let v1 = lt p; v2 = lt q in
               (v1 \<prec>\<^sub>t v2 \<or> v1 = v2 \<and> lookup p v1 = lookup q v2 \<and> lower p v1 \<prec>\<^sub>p lower q v2)
             )"
       unfolding lc_def tail_def by auto
   qed
 next
   assume ?R
   hence "q \<noteq> 0"
     and dis: "p = 0 \<or>
                 (let v1 = lt p; v2 = lt q in
                   (v1 \<prec>\<^sub>t v2 \<or> v1 = v2 \<and> lookup p v1 = lookup q v2 \<and> lower p v1 \<prec>\<^sub>p lower q v2)
                 )"
     by simp_all
   show ?L
   proof (cases "p = 0")
     assume "p = 0"
     hence "p \<preceq>\<^sub>p q" using ord_p_zero_min[of q] by simp
     thus ?thesis using \<open>p = 0\<close> \<open>q \<noteq> 0\<close> by simp
   next
     assume "p \<noteq> 0"
     hence "let v1 = lt p; v2 = lt q in
             (v1 \<prec>\<^sub>t v2 \<or> v1 = v2 \<and> lookup p v1 = lookup q v2 \<and> lower p v1 \<prec>\<^sub>p lower q v2)"
       using dis by simp
     hence "lt p \<prec>\<^sub>t lt q \<or> (lt p = lt q \<and> lc p = lc q \<and> tail p \<prec>\<^sub>p tail q)"
       unfolding lc_def tail_def by (simp add: Let_def)
     thus ?thesis
     proof
       assume "lt p \<prec>\<^sub>t lt q"
       from lt_ord_p[OF this] show ?thesis .
     next
       assume "lt p = lt q \<and> lc p = lc q \<and> tail p \<prec>\<^sub>p tail q"
       hence "lt p = lt q" and "lc p = lc q" and "tail p \<prec>\<^sub>p tail q" by simp_all
       thus ?thesis by (rule ord_strict_p_recI)
     qed
   qed
 qed
 
 lemma ord_strict_p_monomial_iff: "p \<prec>\<^sub>p monomial c v \<longleftrightarrow> (c \<noteq> 0 \<and> (p = 0 \<or> lt p \<prec>\<^sub>t v))"
 proof -
   from ord_p_zero_min[of "tail p"] have *: "\<not> tail p \<prec>\<^sub>p 0" by auto
   show ?thesis
     by (simp add: ord_strict_p_rec[of p] Let_def tail_def[symmetric] lc_def[symmetric]
         monomial_0_iff tail_monomial *, simp add: lt_monomial cong: conj_cong)
 qed
 
 corollary ord_strict_p_monomial_plus:
   assumes "p \<prec>\<^sub>p monomial c v" and "q \<prec>\<^sub>p monomial c v"
   shows "p + q \<prec>\<^sub>p monomial c v"
 proof -
   from assms(1) have "c \<noteq> 0" and "p = 0 \<or> lt p \<prec>\<^sub>t v" by (simp_all add: ord_strict_p_monomial_iff)
   from this(2) show ?thesis
   proof
     assume "p = 0"
     with assms(2) show ?thesis by simp
   next
     assume "lt p \<prec>\<^sub>t v"
     from assms(2) have "q = 0 \<or> lt q \<prec>\<^sub>t v" by (simp add: ord_strict_p_monomial_iff)
     thus ?thesis
     proof
       assume "q = 0"
       with assms(1) show ?thesis by simp
     next
       assume "lt q \<prec>\<^sub>t v"
       with \<open>lt p \<prec>\<^sub>t v\<close> have "lt (p + q) \<prec>\<^sub>t v"
         using lt_plus_le_max ord_term_lin.dual_order.strict_trans2 ord_term_lin.max_less_iff_conj
         by blast 
       with \<open>c \<noteq> 0\<close> show ?thesis by (simp add: ord_strict_p_monomial_iff)
     qed
   qed
 qed
 
 lemma ord_strict_p_monom_mult:
   assumes "p \<prec>\<^sub>p q" and "c \<noteq> (0::'b::semiring_no_zero_divisors)"
   shows "monom_mult c t p \<prec>\<^sub>p monom_mult c t q"
 proof -
   from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v \<noteq> 0"
     and 3: "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u" unfolding ord_strict_p_def by auto
   show ?thesis unfolding ord_strict_p_def
   proof (intro exI conjI allI impI)
     from 1 show "lookup (monom_mult c t p) (t \<oplus> v) = 0" by (simp add: lookup_monom_mult_plus)
   next
     from 2 assms(2) show "lookup (monom_mult c t q) (t \<oplus> v) \<noteq> 0" by (simp add: lookup_monom_mult_plus)
   next
     fix u
     assume "t \<oplus> v \<prec>\<^sub>t u"
     show "lookup (monom_mult c t p) u = lookup (monom_mult c t q) u"
     proof (cases "t adds\<^sub>p u")
       case True
       then obtain w where u: "u = t \<oplus> w" ..
       from \<open>t \<oplus> v \<prec>\<^sub>t u\<close> have "v \<prec>\<^sub>t w" unfolding u by (rule ord_term_strict_canc)
       hence "lookup p w = lookup q w" by (rule 3)
       thus ?thesis by (simp add: u lookup_monom_mult_plus)
     next
       case False
       thus ?thesis by (simp add: lookup_monom_mult)
     qed
   qed
 qed
 
 lemma ord_strict_p_plus:
   assumes "p \<prec>\<^sub>p q" and "keys r \<inter> keys q = {}"
   shows "p + r \<prec>\<^sub>p q + r"
 proof -
   from assms(1) obtain v where 1: "lookup p v = 0" and 2: "lookup q v \<noteq> 0"
     and 3: "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u" unfolding ord_strict_p_def by auto
   have eq: "lookup r v = 0"
     by (meson "2" assms(2) disjoint_iff_not_equal in_keys_iff)
   show ?thesis unfolding ord_strict_p_def
   proof (intro exI conjI allI impI, simp_all add: lookup_add)
     from 1 show "lookup p v + lookup r v = 0" by (simp add: eq)
   next
     from 2 show "lookup q v + lookup r v \<noteq> 0" by (simp add: eq)
   next
     fix u
     assume "v \<prec>\<^sub>t u"
     hence "lookup p u = lookup q u" by (rule 3)
     thus "lookup p u + lookup r u = lookup q u + lookup r u" by simp
   qed
 qed
 
 lemma poly_mapping_tail_induct [case_names 0 tail]:
   assumes "P 0" and "\<And>p. p \<noteq> 0 \<Longrightarrow> P (tail p) \<Longrightarrow> P p"
   shows "P p"
 proof (induct "card (keys p)" arbitrary: p)
   case 0
   with finite_keys[of p] have "keys p = {}" by simp
   hence "p = 0" by simp
   from \<open>P 0\<close> show ?case unfolding \<open>p = 0\<close> .
 next
   case ind: (Suc n)
   from ind(2) have "keys p \<noteq> {}" by auto
   hence "p \<noteq> 0" by simp
   thus ?case
   proof (rule assms(2))
     show "P (tail p)"
     proof (rule ind(1))
       from \<open>p \<noteq> 0\<close> have "lt p \<in> keys p" by (rule lt_in_keys)
       hence "card (keys (tail p)) = card (keys p) - 1" by (simp add: keys_tail)
       also have "... = n" unfolding ind(2)[symmetric] by simp
       finally show "n = card (keys (tail p))" by simp
     qed
   qed
 qed
 
 lemma poly_mapping_neqE:
   assumes "p \<noteq> q"
   obtains v where "v \<in> keys p \<union> keys q" and "lookup p v \<noteq> lookup q v"
     and "\<And>u. v \<prec>\<^sub>t u \<Longrightarrow> lookup p u = lookup q u"
 proof -
   let ?A = "{v. lookup p v \<noteq> lookup q v}"
   define v where "v = ord_term_lin.Max ?A"
   have "?A \<subseteq> keys p \<union> keys q"
     using UnI2 in_keys_iff by fastforce
   also have "finite ..." by (rule finite_UnI) (fact finite_keys)+
   finally(finite_subset) have fin: "finite ?A" .
   moreover have "?A \<noteq> {}"
   proof
     assume "?A = {}"
     hence "p = q"
       using poly_mapping_eqI by fastforce
     with assms show False ..
   qed
   ultimately have "v \<in> ?A" unfolding v_def by (rule ord_term_lin.Max_in)
   show ?thesis
   proof
     from \<open>?A \<subseteq> keys p \<union> keys q\<close> \<open>v \<in> ?A\<close> show "v \<in> keys p \<union> keys q" ..
   next
     from \<open>v \<in> ?A\<close> show "lookup p v \<noteq> lookup q v" by simp
   next
     fix u
     assume "v \<prec>\<^sub>t u"
     show "lookup p u = lookup q u"
     proof (rule ccontr)
       assume "lookup p u \<noteq> lookup q u"
       hence "u \<in> ?A" by simp
       with fin have "u \<preceq>\<^sub>t v" unfolding v_def by (rule ord_term_lin.Max_ge)
       with \<open>v \<prec>\<^sub>t u\<close> show False by simp
     qed
   qed
 qed
 
 subsection \<open>Monomials\<close>
 
 lemma keys_monomial:
   assumes "is_monomial p"
   shows "keys p = {lt p}"
   using assms by (metis is_monomial_monomial lt_monomial keys_of_monomial)
 
 lemma monomial_eq_itself:
   assumes "is_monomial p"
   shows "monomial (lc p) (lt p) = p"
 proof -
   from assms have "p \<noteq> 0" by (rule monomial_not_0)
   hence "lc p \<noteq> 0" by (rule lc_not_0)
   hence keys1: "keys (monomial (lc p) (lt p)) = {lt p}" by (rule keys_of_monomial)
   show ?thesis
     by (rule poly_mapping_keys_eqI, simp only: keys_monomial[OF assms] keys1,
         simp only: keys1 lookup_single Poly_Mapping.when_def, auto simp add: lc_def)
 qed
 
 lemma lt_eq_min_term_monomial:
   assumes "lt p = min_term"
   shows "monomial (lc p) min_term = p"
 proof (rule poly_mapping_eqI)
   fix v
   from min_term_min[of v] have "v = min_term \<or> min_term \<prec>\<^sub>t v" by auto
   thus "lookup (monomial (lc p) min_term) v = lookup p v"
   proof
     assume "v = min_term"
     thus ?thesis by (simp add: lookup_single lc_def assms)
   next
     assume "min_term \<prec>\<^sub>t v"
     moreover have "v \<notin> keys p"
     proof
       assume "v \<in> keys p"
       hence "v \<preceq>\<^sub>t lt p" by (rule lt_max_keys)
       with \<open>min_term \<prec>\<^sub>t v\<close> show False by (simp add: assms)
     qed
     ultimately show ?thesis by (simp add: lookup_single in_keys_iff)
   qed
 qed
 
 lemma is_monomial_monomial_ordered:
   assumes "is_monomial p"
   obtains c v where "c \<noteq> 0" and "lc p = c" and "lt p = v" and "p = monomial c v"
 proof -
   from assms obtain c v where "c \<noteq> 0" and p_eq: "p = monomial c v" by (rule is_monomial_monomial)
   note this(1)
   moreover have "lc p = c" unfolding p_eq by (rule lc_monomial)
   moreover from \<open>c \<noteq> 0\<close> have "lt p = v" unfolding p_eq by (rule lt_monomial)
   ultimately show ?thesis using p_eq ..
 qed
 
 lemma monomial_plus_not_0:
   assumes "c \<noteq> 0" and "lt p \<prec>\<^sub>t v"
   shows "monomial c v + p \<noteq> 0"
 proof
   assume "monomial c v + p = 0"
   hence "0 = lookup (monomial c v + p) v" by simp
   also have "... = c + lookup p v" by (simp add: lookup_add)
   also have "... = c"
   proof -
     from assms(2) have "\<not> v \<preceq>\<^sub>t lt p" by simp
     with lt_max[of p v] have "lookup p v = 0" by blast
     thus ?thesis by simp
   qed
   finally show False using \<open>c \<noteq> 0\<close> by simp
 qed
 
 lemma lt_monomial_plus:
   assumes "c \<noteq> (0::'b::comm_monoid_add)" and "lt p \<prec>\<^sub>t v"
   shows "lt (monomial c v + p) = v"
 proof -
   have eq: "lt (monomial c v) = v" by (simp only: lt_monomial[OF \<open>c \<noteq> 0\<close>])
   moreover have "lt (p + monomial c v) = lt (monomial c v)" by (rule lt_plus_eqI, simp only: eq, fact)
   ultimately show ?thesis by (simp add: add.commute)
 qed
 
 lemma lc_monomial_plus:
   assumes "c \<noteq> (0::'b::comm_monoid_add)" and "lt p \<prec>\<^sub>t v"
   shows "lc (monomial c v + p) = c"
 proof -
   from assms(2) have "\<not> v \<preceq>\<^sub>t lt p" by simp
   with lt_max[of p v] have "lookup p v = 0" by blast
   thus ?thesis by (simp add: lc_def lt_monomial_plus[OF assms] lookup_add)
 qed
 
 lemma tt_monomial_plus:
   assumes "p \<noteq> (0::_ \<Rightarrow>\<^sub>0 'b::comm_monoid_add)" and "lt p \<prec>\<^sub>t v"
   shows "tt (monomial c v + p) = tt p"
 proof (cases "c = 0")
   case True
   thus ?thesis by (simp add: monomial_0I)
 next
   case False
   have eq: "tt (monomial c v) = v" by (simp only: tt_monomial[OF \<open>c \<noteq> 0\<close>])
   moreover have "tt (p + monomial c v) = tt p"
   proof (rule tt_plus_eqI, fact, simp only: eq)
     from lt_ge_tt[of p] assms(2) show "tt p \<prec>\<^sub>t v" by simp
   qed
   ultimately show ?thesis by (simp add: ac_simps)
 qed
 
 lemma tc_monomial_plus:
   assumes "p \<noteq> (0::_ \<Rightarrow>\<^sub>0 'b::comm_monoid_add)" and "lt p \<prec>\<^sub>t v"
   shows "tc (monomial c v + p) = tc p"
 proof (simp add: tc_def tt_monomial_plus[OF assms] lookup_add lookup_single Poly_Mapping.when_def,
     rule impI)
   assume "v = tt p"
   with assms(2) have "lt p \<prec>\<^sub>t tt p" by simp
   with lt_ge_tt[of p] show "c + lookup p (tt p) = lookup p (tt p)" by simp
 qed
 
 lemma tail_monomial_plus:
   assumes "c \<noteq> (0::'b::comm_monoid_add)" and "lt p \<prec>\<^sub>t v"
   shows "tail (monomial c v + p) = p" (is "tail ?q = _")
 proof -
   from assms have "lt ?q = v" by (rule lt_monomial_plus)
   moreover have "lower (monomial c v) v = 0"
     by (simp add: lower_eq_zero_iff', rule disjI2, simp add: tt_monomial[OF \<open>c \<noteq> 0\<close>])
   ultimately show ?thesis by (simp add: tail_def lower_plus lower_id_iff, intro disjI2 assms(2))
 qed
 
 subsection \<open>Lists of Keys\<close>
 
 text \<open>In algorithms one very often needs to compute the sorted list of all terms appearing
   in a list of polynomials.\<close>
 
 definition pps_to_list :: "'t set \<Rightarrow> 't list" where
   "pps_to_list S = rev (ord_term_lin.sorted_list_of_set S)"
 
 definition keys_to_list :: "('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 't list"
   where "keys_to_list p = pps_to_list (keys p)"
 
 definition Keys_to_list :: "('t \<Rightarrow>\<^sub>0 'b::zero) list \<Rightarrow> 't list"
   where "Keys_to_list ps = fold (\<lambda>p ts. merge_wrt (\<succ>\<^sub>t) (keys_to_list p) ts) ps []"
 
 text \<open>Function @{const pps_to_list} turns finite sets of terms into sorted lists, where the
   lists are sorted descending (i.\,e. greater elements come before smaller ones).\<close>
 
 lemma distinct_pps_to_list: "distinct (pps_to_list S)"
   unfolding pps_to_list_def distinct_rev by (rule ord_term_lin.distinct_sorted_list_of_set)
 
 lemma set_pps_to_list:
   assumes "finite S"
   shows "set (pps_to_list S) = S"
   unfolding pps_to_list_def set_rev using assms by simp
 
 lemma length_pps_to_list: "length (pps_to_list S) = card S"
 proof (cases "finite S")
   case True
   from distinct_card[OF distinct_pps_to_list] have "length (pps_to_list S) = card (set (pps_to_list S))"
     by simp
   also from True have "... = card S" by (simp only: set_pps_to_list)
   finally show ?thesis .
 next
   case False
   thus ?thesis by (simp add: pps_to_list_def)
 qed
 
 lemma pps_to_list_sorted_wrt: "sorted_wrt (\<succ>\<^sub>t) (pps_to_list S)"
 proof -
   have "sorted_wrt (\<succeq>\<^sub>t) (pps_to_list S)"
   proof -
     have tr: "transp (\<preceq>\<^sub>t)" using transp_def by fastforce
     have *: "(\<lambda>x y. y \<succeq>\<^sub>t x) = (\<preceq>\<^sub>t)" by simp
     show ?thesis
-      by (simp only: * pps_to_list_def sorted_wrt_rev ord_term_lin.sorted_sorted_wrt[symmetric],
+      by (simp only: * pps_to_list_def sorted_wrt_rev,
           rule ord_term_lin.sorted_sorted_list_of_set)
   qed
   with distinct_pps_to_list have "sorted_wrt (\<lambda>x y. x \<succeq>\<^sub>t y \<and> x \<noteq> y) (pps_to_list S)"
     by (rule distinct_sorted_wrt_imp_sorted_wrt_strict)
   moreover have "(\<succ>\<^sub>t) = (\<lambda>x y. x \<succeq>\<^sub>t y \<and> x \<noteq> y)"
     using ord_term_lin.dual_order.order_iff_strict by auto
   ultimately show ?thesis by simp
 qed
 
 lemma pps_to_list_nth_leI:
   assumes "j \<le> i" and "i < card S"
   shows "(pps_to_list S) ! i \<preceq>\<^sub>t (pps_to_list S) ! j"
 proof (cases "j = i")
   case True
   show ?thesis by (simp add: True)
 next
   case False
   with assms(1) have "j < i" by simp
   let ?ts = "pps_to_list S"
   from pps_to_list_sorted_wrt \<open>j < i\<close> have "(\<prec>\<^sub>t)\<inverse>\<inverse> (?ts ! j) (?ts ! i)"
   proof (rule sorted_wrt_nth_less)
     from assms(2) show "i < length ?ts" by (simp only: length_pps_to_list)
   qed
   thus ?thesis by simp
 qed
 
 lemma pps_to_list_nth_lessI:
   assumes "j < i" and "i < card S"
   shows "(pps_to_list S) ! i \<prec>\<^sub>t (pps_to_list S) ! j"
 proof -
   let ?ts = "pps_to_list S"
   from assms(1) have "j \<le> i" and "i \<noteq> j" by simp_all
   with assms(2) have "i < length ?ts" and "j < length ?ts" by (simp_all only: length_pps_to_list)
   show ?thesis
   proof (rule ord_term_lin.neq_le_trans)
     from \<open>i \<noteq> j\<close> show "?ts ! i \<noteq> ?ts ! j"
       by (simp add: nth_eq_iff_index_eq[OF distinct_pps_to_list \<open>i < length ?ts\<close> \<open>j < length ?ts\<close>])
   next
     from \<open>j \<le> i\<close> assms(2) show "?ts ! i \<preceq>\<^sub>t ?ts ! j" by (rule pps_to_list_nth_leI)
   qed
 qed
 
 lemma pps_to_list_nth_leD:
   assumes "(pps_to_list S) ! i \<preceq>\<^sub>t (pps_to_list S) ! j" and "j < card S"
   shows "j \<le> i"
 proof (rule ccontr)
   assume "\<not> j \<le> i"
   hence "i < j" by simp
   from this \<open>j < card S\<close> have "(pps_to_list S) ! j \<prec>\<^sub>t (pps_to_list S) ! i" by (rule pps_to_list_nth_lessI)
   with assms(1) show False by simp
 qed
 
 lemma pps_to_list_nth_lessD:
   assumes "(pps_to_list S) ! i \<prec>\<^sub>t (pps_to_list S) ! j" and "j < card S"
   shows "j < i"
 proof (rule ccontr)
   assume "\<not> j < i"
   hence "i \<le> j" by simp
   from this \<open>j < card S\<close> have "(pps_to_list S) ! j \<preceq>\<^sub>t (pps_to_list S) ! i" by (rule pps_to_list_nth_leI)
   with assms(1) show False by simp
 qed
 
 lemma set_keys_to_list: "set (keys_to_list p) = keys p"
   by (simp add: keys_to_list_def set_pps_to_list)
 
 lemma length_keys_to_list: "length (keys_to_list p) = card (keys p)"
   by (simp only: keys_to_list_def length_pps_to_list)
 
 lemma keys_to_list_zero [simp]: "keys_to_list 0 = []"
   by (simp add: keys_to_list_def pps_to_list_def)
 
 lemma Keys_to_list_Nil [simp]: "Keys_to_list [] = []"
   by (simp add: Keys_to_list_def)
 
 lemma set_Keys_to_list: "set (Keys_to_list ps) = Keys (set ps)"
 proof -
   have "set (Keys_to_list ps) = (\<Union>p\<in>set ps. set (keys_to_list p)) \<union> set []"
     unfolding Keys_to_list_def by (rule set_fold, simp only: set_merge_wrt)
   also have "... = Keys (set ps)" by (simp add: Keys_def set_keys_to_list)
   finally show ?thesis .
 qed
 
 lemma Keys_to_list_sorted_wrt_aux:
   assumes "sorted_wrt (\<succ>\<^sub>t) ts"
   shows "sorted_wrt (\<succ>\<^sub>t) (fold (\<lambda>p ts. merge_wrt (\<succ>\<^sub>t) (keys_to_list p) ts) ps ts)"
   using assms
 proof (induct ps arbitrary: ts)
   case Nil
   thus ?case by simp
 next
   case (Cons p ps)
   show ?case
   proof (simp only: fold.simps o_def, rule Cons(1), rule sorted_merge_wrt)
     show "transp (\<succ>\<^sub>t)" unfolding transp_def by fastforce
   next
     fix x y :: 't
     assume "x \<noteq> y"
     thus "x \<succ>\<^sub>t y \<or> y \<succ>\<^sub>t x" by auto
   next
     show "sorted_wrt (\<succ>\<^sub>t) (keys_to_list p)" unfolding keys_to_list_def
       by (fact pps_to_list_sorted_wrt)
   qed fact
 qed
 
 corollary Keys_to_list_sorted_wrt: "sorted_wrt (\<succ>\<^sub>t) (Keys_to_list ps)"
   unfolding Keys_to_list_def
 proof (rule Keys_to_list_sorted_wrt_aux)
   show "sorted_wrt (\<succ>\<^sub>t) []" by simp
 qed
 
 corollary distinct_Keys_to_list: "distinct (Keys_to_list ps)"
 proof (rule distinct_sorted_wrt_irrefl)
   show "irreflp (\<succ>\<^sub>t)" by (simp add: irreflp_def)
 next
   show "transp (\<succ>\<^sub>t)" unfolding transp_def by fastforce
 next
   show "sorted_wrt (\<succ>\<^sub>t) (Keys_to_list ps)" by (fact Keys_to_list_sorted_wrt)
 qed
 
 lemma length_Keys_to_list: "length (Keys_to_list ps) = card (Keys (set ps))"
 proof -
   from distinct_Keys_to_list have "card (set (Keys_to_list ps)) = length (Keys_to_list ps)"
     by (rule distinct_card)
   thus ?thesis by (simp only: set_Keys_to_list)
 qed
 
 lemma Keys_to_list_eq_pps_to_list: "Keys_to_list ps = pps_to_list (Keys (set ps))"
   using _ Keys_to_list_sorted_wrt distinct_Keys_to_list pps_to_list_sorted_wrt distinct_pps_to_list
 proof (rule sorted_wrt_distinct_set_unique)
   show "antisymp (\<succ>\<^sub>t)" unfolding antisymp_def by fastforce
 next
   from finite_set have fin: "finite (Keys (set ps))" by (rule finite_Keys)
   show "set (Keys_to_list ps) = set (pps_to_list (Keys (set ps)))"
     by (simp add: set_Keys_to_list set_pps_to_list[OF fin])
 qed
 
 subsection \<open>Multiplication\<close>
 
 lemma in_keys_mult_scalar_le:
   assumes "v \<in> keys (p \<odot> q)"
   shows "v \<preceq>\<^sub>t punit.lt p \<oplus> lt q"
 proof -
   from assms obtain t u where "t \<in> keys p" and "u \<in> keys q" and "v = t \<oplus> u"
     by (rule in_keys_mult_scalarE)
   from \<open>t \<in> keys p\<close> have "t \<preceq> punit.lt p" by (rule punit.lt_max_keys)
   from \<open>u \<in> keys q\<close> have "u \<preceq>\<^sub>t lt q" by (rule lt_max_keys)
   hence "v \<preceq>\<^sub>t t \<oplus> lt q" unfolding \<open>v = t \<oplus> u\<close> by (rule splus_mono)
   also from \<open>t \<preceq> punit.lt p\<close> have "... \<preceq>\<^sub>t punit.lt p \<oplus> lt q" by (rule splus_mono_left)
   finally show ?thesis .
 qed
 
 lemma in_keys_mult_scalar_ge:
   assumes "v \<in> keys (p \<odot> q)"
   shows "punit.tt p \<oplus> tt q \<preceq>\<^sub>t v"
 proof -
   from assms obtain t u where "t \<in> keys p" and "u \<in> keys q" and "v = t \<oplus> u"
     by (rule in_keys_mult_scalarE)
   from \<open>t \<in> keys p\<close> have "punit.tt p \<preceq> t" by (rule punit.tt_min_keys)
   from \<open>u \<in> keys q\<close> have "tt q \<preceq>\<^sub>t u" by (rule tt_min_keys)
   hence "punit.tt p \<oplus> tt q \<preceq>\<^sub>t punit.tt p \<oplus> u" by (rule splus_mono)
   also from \<open>punit.tt p \<preceq> t\<close> have "... \<preceq>\<^sub>t v" unfolding \<open>v = t \<oplus> u\<close> by (rule splus_mono_left)
   finally show ?thesis .
 qed
 
 lemma (in ordered_term) lookup_mult_scalar_lt_lt:
   "lookup (p \<odot> q) (punit.lt p \<oplus> lt q) = punit.lc p * lc q"
 proof (induct p rule: punit.poly_mapping_tail_induct)
   case 0
   show ?case by simp
 next
   case step: (tail p)
   from step(1) have "punit.lc p \<noteq> 0" by (rule punit.lc_not_0)
   let ?t = "punit.lt p \<oplus> lt q"
   show ?case
   proof (cases "is_monomial p")
     case True
     then obtain c t where "c \<noteq> 0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
       by (rule punit.is_monomial_monomial_ordered)
     hence "p \<odot> q = monom_mult (punit.lc p) (punit.lt p) q" by (simp add: mult_scalar_monomial)
     thus ?thesis by (simp add: lookup_monom_mult_plus lc_def)
   next
     case False
     have "punit.lt (punit.tail p) \<noteq> punit.lt p"
     proof (simp add: punit.tail_def punit.lt_lower_eq_iff, rule)
       assume "punit.lt p = 0"
       have "keys p \<subseteq> {punit.lt p}"
       proof (rule, simp)
         fix s
         assume "s \<in> keys p"
         hence "s \<preceq> punit.lt p" by (rule punit.lt_max_keys)
         moreover have "punit.lt p \<preceq> s" unfolding \<open>punit.lt p = 0\<close> by (rule zero_min)
         ultimately show "s = punit.lt p" by simp
       qed
       hence "card (keys p) = 0 \<or> card (keys p) = 1" using subset_singletonD by fastforce
       thus False
       proof
         assume "card (keys p) = 0"
         hence "p = 0" by (meson card_0_eq keys_eq_empty finite_keys) 
         with step(1) show False ..
       next
         assume "card (keys p) = 1"
         with False show False unfolding is_monomial_def ..
       qed
     qed
     with punit.lt_lower[of p "punit.lt p"] have "punit.lt (punit.tail p) \<prec> punit.lt p"
       by (simp add: punit.tail_def)
     have eq: "lookup ((punit.tail p) \<odot> q) ?t = 0"
     proof (rule ccontr)
       assume "lookup ((punit.tail p) \<odot> q) ?t \<noteq> 0"
       hence "?t \<preceq>\<^sub>t punit.lt (punit.tail p) \<oplus> lt q"
         by (meson in_keys_mult_scalar_le lookup_not_eq_zero_eq_in_keys) 
       hence "punit.lt p \<preceq> punit.lt (punit.tail p)" by (rule ord_term_canc_left)
       also have "... \<prec> punit.lt p" by fact
       finally show False ..
     qed
     from step(2) have "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = punit.lc p * lc q"
       by (simp only: lookup_monom_mult_plus lc_def)
     thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
   qed
 qed
 
 lemma lookup_mult_scalar_tt_tt: "lookup (p \<odot> q) (punit.tt p \<oplus> tt q) = punit.tc p * tc q"
 proof (induct p rule: punit.poly_mapping_tail_induct)
   case 0
   show ?case by simp
 next
   case step: (tail p)
   from step(1) have "punit.lc p \<noteq> 0" by (rule punit.lc_not_0)
   let ?t = "punit.tt p \<oplus> tt q"
   show ?case
   proof (cases "is_monomial p")
     case True
     then obtain c t where "c \<noteq> 0" and "punit.lt p = t" and "punit.lc p = c" and p_eq: "p = monomial c t"
       by (rule punit.is_monomial_monomial_ordered)
     from \<open>c \<noteq> 0\<close> have "punit.tt p = t" and "punit.tc p = c" by (simp_all add: p_eq punit.tt_monomial)
     with p_eq have "p \<odot> q = monom_mult (punit.tc p) (punit.tt p) q" by (simp add: mult_scalar_monomial)
     thus ?thesis by (simp add: lookup_monom_mult_plus tc_def)
   next
     case False
     from step(1) have "keys p \<noteq> {}" by simp
     with finite_keys have "card (keys p) \<noteq> 0" by auto
     with False have "2 \<le> card (keys p)" unfolding is_monomial_def by linarith
     then obtain s t where "s \<in> keys p" and "t \<in> keys p" and "s \<prec> t"
       by (metis (mono_tags, lifting) card.empty card.infinite card_insert_disjoint card_mono empty_iff
           finite.emptyI insertCI lessI not_less numeral_2_eq_2 ordered_powerprod_lin.infinite_growing
           ordered_powerprod_lin.neqE preorder_class.less_le_trans subsetI)
     from this(1) this(3) have "punit.tt p \<prec> t" by (rule punit.tt_less)
     also from \<open>t \<in> keys p\<close> have "t \<preceq> punit.lt p" by (rule punit.lt_max_keys)
     finally have "punit.tt p \<prec> punit.lt p" .
     hence tt_tail: "punit.tt (punit.tail p) = punit.tt p" and tc_tail: "punit.tc (punit.tail p) = punit.tc p"
       unfolding punit.tail_def by (rule punit.tt_lower, rule punit.tc_lower)
     have eq: "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t = 0"
     proof (rule ccontr)
       assume "lookup (monom_mult (punit.lc p) (punit.lt p) q) ?t \<noteq> 0"
       hence "punit.lt p \<oplus> tt q \<preceq>\<^sub>t ?t"
         by (meson in_keys_iff in_keys_monom_mult_ge) 
       hence "punit.lt p \<preceq> punit.tt p" by (rule ord_term_canc_left)
       also have "... \<prec> punit.lt p" by fact
       finally show False ..
     qed
     from step(2) have "lookup (punit.tail p \<odot> q) ?t = punit.tc p * tc q" by (simp only: tt_tail tc_tail)
     thus ?thesis by (simp add: mult_scalar_tail_rec_left[of p q] lookup_add eq)
   qed
 qed
 
 lemma lt_mult_scalar:
   assumes "p \<noteq> 0" and "q \<noteq> (0::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "lt (p \<odot> q) = punit.lt p \<oplus> lt q"
 proof (rule lt_eqI_keys, simp only: in_keys_iff lookup_mult_scalar_lt_lt)
   from assms(1) have "punit.lc p \<noteq> 0" by (rule punit.lc_not_0)
   moreover from assms(2) have "lc q \<noteq> 0" by (rule lc_not_0)
   ultimately show "punit.lc p * lc q \<noteq> 0" by simp
 qed (rule in_keys_mult_scalar_le)
 
 lemma tt_mult_scalar:
   assumes "p \<noteq> 0" and "q \<noteq> (0::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "tt (p \<odot> q) = punit.tt p \<oplus> tt q"
 proof (rule tt_eqI, simp only: in_keys_iff lookup_mult_scalar_tt_tt)
   from assms(1) have "punit.tc p \<noteq> 0" by (rule punit.tc_not_0)
   moreover from assms(2) have "tc q \<noteq> 0" by (rule tc_not_0)
   ultimately show "punit.tc p * tc q \<noteq> 0" by simp
 qed (rule in_keys_mult_scalar_ge)
 
 lemma lc_mult_scalar: "lc (p \<odot> q) = punit.lc p * lc (q::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
 proof (cases "p = 0")
   case True
   thus ?thesis by (simp add: lc_def)
 next
   case False
   show ?thesis
   proof (cases "q = 0")
     case True
     thus ?thesis by (simp add: lc_def)
   next
     case False
     with \<open>p \<noteq> 0\<close> show ?thesis by (simp add: lc_def lt_mult_scalar lookup_mult_scalar_lt_lt)
   qed
 qed
 
 lemma tc_mult_scalar: "tc (p \<odot> q) = punit.tc p * tc (q::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
 proof (cases "p = 0")
   case True
   thus ?thesis by (simp add: tc_def)
 next
   case False
   show ?thesis
   proof (cases "q = 0")
     case True
     thus ?thesis by (simp add: tc_def)
   next
     case False
     with \<open>p \<noteq> 0\<close> show ?thesis by (simp add: tc_def tt_mult_scalar lookup_mult_scalar_tt_tt)
   qed
 qed
 
 lemma mult_scalar_not_zero:
   assumes "p \<noteq> 0" and "q \<noteq> (0::'t \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "p \<odot> q \<noteq> 0"
 proof
   assume "p \<odot> q = 0"
   hence "0 = lc (p \<odot> q)" by (simp add: lc_def)
   also have "... = punit.lc p * lc q" by (rule lc_mult_scalar)
   finally have "punit.lc p * lc q = 0" by simp
   moreover from assms(1) have "punit.lc p \<noteq> 0" by (rule punit.lc_not_0)
   moreover from assms(2) have "lc q \<noteq> 0" by (rule lc_not_0)
   ultimately show False by simp
 qed
 
 end (* ordered_term_powerprod *)
 
 context ordered_powerprod
 begin
 
 lemmas in_keys_times_le = punit.in_keys_mult_scalar_le[simplified]
 lemmas in_keys_times_ge = punit.in_keys_mult_scalar_ge[simplified]
 lemmas lookup_times_lp_lp = punit.lookup_mult_scalar_lt_lt[simplified]
 lemmas lookup_times_tp_tp = punit.lookup_mult_scalar_tt_tt[simplified]
 lemmas lookup_times_monomial_right_plus = punit.lookup_mult_scalar_monomial_right_plus[simplified]
 lemmas lookup_times_monomial_right = punit.lookup_mult_scalar_monomial_right[simplified]
 lemmas lp_times = punit.lt_mult_scalar[simplified]
 lemmas tp_times = punit.tt_mult_scalar[simplified]
 lemmas lc_times = punit.lc_mult_scalar[simplified]
 lemmas tc_times = punit.tc_mult_scalar[simplified]
 lemmas times_not_zero = punit.mult_scalar_not_zero[simplified]
 lemmas times_tail_rec_left = punit.mult_scalar_tail_rec_left[simplified]
 lemmas times_tail_rec_right = punit.mult_scalar_tail_rec_right[simplified]
 lemmas punit_in_keys_monom_mult_le = punit.in_keys_monom_mult_le[simplified]
 lemmas punit_in_keys_monom_mult_ge = punit.in_keys_monom_mult_ge[simplified]
 lemmas lp_monom_mult = punit.lt_monom_mult[simplified]
 lemmas tp_monom_mult = punit.tt_monom_mult[simplified]
 
 end
 
 subsection \<open>@{term dgrad_p_set} and @{term dgrad_p_set_le}\<close>
 
 locale gd_term =
     ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
       for pair_of_term::"'t \<Rightarrow> ('a::graded_dickson_powerprod \<times> 'k::{the_min,wellorder})"
       and term_of_pair::"('a \<times> 'k) \<Rightarrow> 't"
       and ord::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<preceq>" 50)
       and ord_strict (infixl "\<prec>" 50)
       and ord_term::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<preceq>\<^sub>t" 50)
       and ord_term_strict::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<prec>\<^sub>t" 50)
 begin
 
 sublocale gd_powerprod ..
 
 lemma adds_term_antisym:
   assumes "u adds\<^sub>t v" and "v adds\<^sub>t u"
   shows "u = v"
   using assms unfolding adds_term_def using adds_antisym by (metis term_of_pair_pair)
 
 definition dgrad_p_set :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero) set"
   where "dgrad_p_set d m = {p. pp_of_term ` keys p \<subseteq> dgrad_set d m}"
 
 definition dgrad_p_set_le :: "('a \<Rightarrow> nat) \<Rightarrow> (('t \<Rightarrow>\<^sub>0 'b) set) \<Rightarrow> (('t \<Rightarrow>\<^sub>0 'b::zero) set) \<Rightarrow> bool"
   where "dgrad_p_set_le d F G \<longleftrightarrow> (dgrad_set_le d (pp_of_term ` Keys F) (pp_of_term ` Keys G))"
 
 lemma in_dgrad_p_set_iff: "p \<in> dgrad_p_set d m \<longleftrightarrow> (\<forall>v\<in>keys p. d (pp_of_term v) \<le> m)"
   by (auto simp add: dgrad_p_set_def dgrad_set_def)
 
 lemma dgrad_p_setI [intro]:
   assumes "\<And>v. v \<in> keys p \<Longrightarrow> d (pp_of_term v) \<le> m"
   shows "p \<in> dgrad_p_set d m"
   using assms by (auto simp: in_dgrad_p_set_iff)
 
 lemma dgrad_p_setD:
   assumes "p \<in> dgrad_p_set d m" and "v \<in> keys p"
   shows "d (pp_of_term v) \<le> m"
   using assms by (simp only: in_dgrad_p_set_iff)
 
 lemma zero_in_dgrad_p_set: "0 \<in> dgrad_p_set d m"
   by (rule, simp)
 
 lemma dgrad_p_set_zero [simp]: "dgrad_p_set (\<lambda>_. 0) m = UNIV"
   by auto
 
 lemma subset_dgrad_p_set_zero: "F \<subseteq> dgrad_p_set (\<lambda>_. 0) m"
   by simp
 
 lemma dgrad_p_set_subset:
   assumes "m \<le> n"
   shows "dgrad_p_set d m \<subseteq> dgrad_p_set d n"
   using assms by (auto simp: dgrad_p_set_def dgrad_set_def)
 
 lemma dgrad_p_setD_lp:
   assumes "p \<in> dgrad_p_set d m" and "p \<noteq> 0"
   shows "d (lp p) \<le> m"
   by (rule dgrad_p_setD, fact, rule lt_in_keys, fact)
 
 lemma dgrad_p_set_exhaust_expl:
   assumes "finite F"
   shows "F \<subseteq> dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
 proof
   fix f
   assume "f \<in> F"
   from assms have "finite (Keys F)" by (rule finite_Keys)
   have fin: "finite (d ` pp_of_term ` Keys F)" by (intro finite_imageI, fact)
   show "f \<in> dgrad_p_set d (Max (d ` pp_of_term ` Keys F))"
   proof (rule dgrad_p_setI)
     fix v
     assume "v \<in> keys f"
     from this \<open>f \<in> F\<close> have "v \<in> Keys F" by (rule in_KeysI)
     hence "d (pp_of_term v) \<in> d ` pp_of_term ` Keys F" by simp
     with fin show "d (pp_of_term v) \<le> Max (d ` pp_of_term ` Keys F)" by (rule Max_ge)
   qed
 qed
 
 lemma dgrad_p_set_exhaust:
   assumes "finite F"
   obtains m where "F \<subseteq> dgrad_p_set d m"
 proof
   from assms show "F \<subseteq> dgrad_p_set d (Max (d ` pp_of_term ` Keys F))" by (rule dgrad_p_set_exhaust_expl)
 qed
 
 lemma dgrad_p_set_insert:
   assumes "F \<subseteq> dgrad_p_set d m"
   obtains n where "m \<le> n" and "f \<in> dgrad_p_set d n" and "F \<subseteq> dgrad_p_set d n"
 proof -
   have "finite {f}" by simp
   then obtain m1 where "{f} \<subseteq> dgrad_p_set d m1" by (rule dgrad_p_set_exhaust)
   hence "f \<in> dgrad_p_set d m1" by simp
   define n where "n = ord_class.max m m1"
   have "m \<le> n" and "m1 \<le> n" by (simp_all add: n_def)
   from this(1) show ?thesis
   proof
     from \<open>m1 \<le> n\<close> have "dgrad_p_set d m1 \<subseteq> dgrad_p_set d n" by (rule dgrad_p_set_subset)
     with \<open>f \<in> dgrad_p_set d m1\<close> show "f \<in> dgrad_p_set d n" ..
   next
     from \<open>m \<le> n\<close> have "dgrad_p_set d m \<subseteq> dgrad_p_set d n" by (rule dgrad_p_set_subset)
     with assms show "F \<subseteq> dgrad_p_set d n" by (rule subset_trans)
   qed
 qed
 
 lemma dgrad_p_set_leI:
   assumes "\<And>f. f \<in> F \<Longrightarrow> dgrad_p_set_le d {f} G"
   shows "dgrad_p_set_le d F G"
   unfolding dgrad_p_set_le_def dgrad_set_le_def
 proof
   fix s
   assume "s \<in> pp_of_term ` Keys F"
   then obtain v where "v \<in> Keys F" and "s = pp_of_term v" ..
   from this(1) obtain f where "f \<in> F" and "v \<in> keys f" by (rule in_KeysE)
   from this(2) have "s \<in> pp_of_term ` Keys {f}" by (simp add: \<open>s = pp_of_term v\<close> Keys_insert)
   from \<open>f \<in> F\<close> have "dgrad_p_set_le d {f} G" by (rule assms)
   from this \<open>s \<in> pp_of_term ` Keys {f}\<close> show "\<exists>t\<in>pp_of_term ` Keys G. d s \<le> d t"
     unfolding dgrad_p_set_le_def dgrad_set_le_def ..
 qed
 
 lemma dgrad_p_set_le_trans [trans]:
   assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d G H"
   shows "dgrad_p_set_le d F H"
   using assms unfolding dgrad_p_set_le_def by (rule dgrad_set_le_trans)
 
 lemma dgrad_p_set_le_subset:
   assumes "F \<subseteq> G"
   shows "dgrad_p_set_le d F G"
   unfolding dgrad_p_set_le_def by (rule dgrad_set_le_subset, rule image_mono, rule Keys_mono, fact)
 
 lemma dgrad_p_set_leI_insert_keys:
   assumes "dgrad_p_set_le d F G" and "dgrad_set_le d (pp_of_term ` keys f) (pp_of_term ` Keys G)"
   shows "dgrad_p_set_le d (insert f F) G"
   using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)
 
 lemma dgrad_p_set_leI_insert:
   assumes "dgrad_p_set_le d F G" and "dgrad_p_set_le d {f} G"
   shows "dgrad_p_set_le d (insert f F) G"
   using assms by (simp add: dgrad_p_set_le_def Keys_insert dgrad_set_le_Un image_Un)
 
 lemma dgrad_p_set_leI_Un:
   assumes "dgrad_p_set_le d F1 G" and "dgrad_p_set_le d F2 G"
   shows "dgrad_p_set_le d (F1 \<union> F2) G"
   using assms by (auto simp: dgrad_p_set_le_def dgrad_set_le_def Keys_Un)
 
 lemma dgrad_p_set_le_dgrad_p_set:
   assumes "dgrad_p_set_le d F G" and "G \<subseteq> dgrad_p_set d m"
   shows "F \<subseteq> dgrad_p_set d m"
 proof
   fix f
   assume "f \<in> F"
   show "f \<in> dgrad_p_set d m"
   proof (rule dgrad_p_setI)
     fix v
     assume "v \<in> keys f"
     from this \<open>f \<in> F\<close> have "v \<in> Keys F" by (rule in_KeysI)
     hence "pp_of_term v \<in> pp_of_term ` Keys F" by simp
     with assms(1) obtain s where "s \<in> pp_of_term ` Keys G" and "d (pp_of_term v) \<le> d s"
       unfolding dgrad_p_set_le_def by (rule dgrad_set_leE)
     from this(1) obtain u where "u \<in> Keys G" and s: "s = pp_of_term u" ..
     from this(1) obtain g where "g \<in> G" and "u \<in> keys g" by (rule in_KeysE)
     from this(1) assms(2) have "g \<in> dgrad_p_set d m" ..
     from this \<open>u \<in> keys g\<close> have "d s \<le> m" unfolding s by (rule dgrad_p_setD)
     with \<open>d (pp_of_term v) \<le> d s\<close> show "d (pp_of_term v) \<le> m" by (rule le_trans)
   qed
 qed
 
 lemma dgrad_p_set_le_except: "dgrad_p_set_le d {except p S} {p}"
   by (auto simp add: dgrad_p_set_le_def Keys_insert keys_except intro: dgrad_set_le_subset)
 
 lemma dgrad_p_set_le_tail: "dgrad_p_set_le d {tail p} {p}"
   by (simp only: tail_def lower_def, fact dgrad_p_set_le_except)
 
 lemma dgrad_p_set_le_plus: "dgrad_p_set_le d {p + q} {p, q}"
   by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact Poly_Mapping.keys_add)
 
 lemma dgrad_p_set_le_uminus: "dgrad_p_set_le d {-p} {p}"
   by (simp add: dgrad_p_set_le_def Keys_insert keys_uminus, fact dgrad_set_le_refl)
 
 lemma dgrad_p_set_le_minus: "dgrad_p_set_le d {p - q} {p, q}"
   by (simp add: dgrad_p_set_le_def Keys_insert, rule dgrad_set_le_subset, rule image_mono, fact keys_minus)
 
 lemma dgrad_set_le_monom_mult:
   assumes "dickson_grading d"
   shows "dgrad_set_le d (pp_of_term ` keys (monom_mult c t p)) (insert t (pp_of_term ` keys p))"
 proof (rule dgrad_set_leI)
   fix s
   assume "s \<in> pp_of_term ` keys (monom_mult c t p)"
   with keys_monom_mult_subset have "s \<in> pp_of_term ` ((\<oplus>) t ` keys p)" by fastforce
   then obtain v where "v \<in> keys p" and s: "s = pp_of_term (t \<oplus> v)" by fastforce
   have "d s = ord_class.max (d t) (d (pp_of_term v))"
     by (simp only: s pp_of_term_splus dickson_gradingD1[OF assms(1)])
   hence "d s = d t \<or> d s = d (pp_of_term v)" by auto
   thus "\<exists>t\<in>insert t (pp_of_term ` keys p). d s \<le> d t"
   proof
     assume "d s = d t"
     thus ?thesis by simp
   next
     assume "d s = d (pp_of_term v)"
     show ?thesis
     proof
       from \<open>d s = d (pp_of_term v)\<close> show "d s \<le> d (pp_of_term v)" by simp
     next
       from \<open>v \<in> keys p\<close> show "pp_of_term v \<in> insert t (pp_of_term ` keys p)" by simp
     qed
   qed
 qed
 
 lemma dgrad_p_set_closed_plus:
   assumes "p \<in> dgrad_p_set d m" and "q \<in> dgrad_p_set d m"
   shows "p + q \<in> dgrad_p_set d m"
 proof -
   from dgrad_p_set_le_plus have "{p + q} \<subseteq> dgrad_p_set d m"
   proof (rule dgrad_p_set_le_dgrad_p_set)
     from assms show "{p, q} \<subseteq> dgrad_p_set d m" by simp
   qed
   thus ?thesis by simp
 qed
 
 lemma dgrad_p_set_closed_uminus:
   assumes "p \<in> dgrad_p_set d m"
   shows "-p \<in> dgrad_p_set d m"
 proof -
   from dgrad_p_set_le_uminus have "{-p} \<subseteq> dgrad_p_set d m"
   proof (rule dgrad_p_set_le_dgrad_p_set)
     from assms show "{p} \<subseteq> dgrad_p_set d m" by simp
   qed
   thus ?thesis by simp
 qed
 
 lemma dgrad_p_set_closed_minus:
   assumes "p \<in> dgrad_p_set d m" and "q \<in> dgrad_p_set d m"
   shows "p - q \<in> dgrad_p_set d m"
 proof -
   from dgrad_p_set_le_minus have "{p - q} \<subseteq> dgrad_p_set d m"
   proof (rule dgrad_p_set_le_dgrad_p_set)
     from assms show "{p, q} \<subseteq> dgrad_p_set d m" by simp
   qed
   thus ?thesis by simp
 qed
 
 lemma dgrad_p_set_closed_monom_mult:
   assumes "dickson_grading d" and "d t \<le> m" and "p \<in> dgrad_p_set d m"
   shows "monom_mult c t p \<in> dgrad_p_set d m"
 proof (rule dgrad_p_setI)
   fix v
   assume "v \<in> keys (monom_mult c t p)"
   hence "pp_of_term v \<in> pp_of_term ` keys (monom_mult c t p)" by simp
   with dgrad_set_le_monom_mult[OF assms(1)] obtain s where "s \<in> insert t (pp_of_term ` keys p)"
     and "d (pp_of_term v) \<le> d s" by (rule dgrad_set_leE)
   from this(1) have "s = t \<or> s \<in> pp_of_term ` keys p" by simp
   thus "d (pp_of_term v) \<le> m"
   proof
     assume "s = t"
     with \<open>d (pp_of_term v) \<le> d s\<close> assms(2) show ?thesis by simp
   next
     assume "s \<in> pp_of_term ` keys p"
     then obtain u where "u \<in> keys p" and "s = pp_of_term u" ..
     from assms(3) this(1) have "d s \<le> m" unfolding \<open>s = pp_of_term u\<close> by (rule dgrad_p_setD)
     with \<open>d (pp_of_term v) \<le> d s\<close> show ?thesis by (rule le_trans)
   qed
 qed
 
 lemma dgrad_p_set_closed_monom_mult_zero:
   assumes "p \<in> dgrad_p_set d m"
   shows "monom_mult c 0 p \<in> dgrad_p_set d m"
 proof (rule dgrad_p_setI)
   fix v
   assume "v \<in> keys (monom_mult c 0 p)"
   hence "pp_of_term v \<in> pp_of_term ` keys (monom_mult c 0 p)" by simp
   then obtain u where "u \<in> keys (monom_mult c 0 p)" and eq: "pp_of_term v = pp_of_term u" ..
   from this(1) have "u \<in> keys p" by (metis keys_monom_multE splus_zero)
   with assms have "d (pp_of_term u) \<le> m" by (rule dgrad_p_setD)
   thus "d (pp_of_term v) \<le> m" by (simp only: eq)
 qed
 
 lemma dgrad_p_set_closed_except:
   assumes "p \<in> dgrad_p_set d m"
   shows "except p S \<in> dgrad_p_set d m"
   by (rule dgrad_p_setI, rule dgrad_p_setD, rule assms, simp add: keys_except)
 
 lemma dgrad_p_set_closed_tail:
   assumes "p \<in> dgrad_p_set d m"
   shows "tail p \<in> dgrad_p_set d m"
   unfolding tail_def lower_def using assms by (rule dgrad_p_set_closed_except)
 
 subsection \<open>Dickson's Lemma for Sequences of Terms\<close>
 
 lemma Dickson_term:
   assumes "dickson_grading d" and "finite K"
   shows "almost_full_on (adds\<^sub>t) {t. pp_of_term t \<in> dgrad_set d m \<and> component_of_term t \<in> K}"
     (is "almost_full_on _ ?A")
 proof (rule almost_full_onI)
   fix seq :: "nat \<Rightarrow> 't"
   assume *: "\<forall>i. seq i \<in> ?A"
   define seq' where "seq' = (\<lambda>i. (pp_of_term (seq i), component_of_term (seq i)))"
   have "pp_of_term ` ?A \<subseteq> {x. d x \<le> m}" by (auto dest: dgrad_setD)
   moreover from assms(1) have "almost_full_on (adds) {x. d x \<le> m}" by (rule dickson_gradingD2)
   ultimately have "almost_full_on (adds) (pp_of_term ` ?A)" by (rule almost_full_on_subset)
   moreover have "almost_full_on (=) (component_of_term ` ?A)"
   proof (rule eq_almost_full_on_finite_set)
     have "component_of_term ` ?A \<subseteq> K" by blast
     thus "finite (component_of_term ` ?A)" using assms(2) by (rule finite_subset)
   qed
   ultimately have "almost_full_on (prod_le (adds) (=)) (pp_of_term ` ?A \<times> component_of_term ` ?A)"
     by (rule almost_full_on_Sigma)
   moreover from * have "\<And>i. seq' i \<in> pp_of_term ` ?A \<times> component_of_term ` ?A" by (simp add: seq'_def)
   ultimately obtain i j where "i < j" and "prod_le (adds) (=) (seq' i) (seq' j)"
     by (rule almost_full_onD)
   from this(2) have "seq i adds\<^sub>t seq j" by (simp add: seq'_def prod_le_def adds_term_def)
   with \<open>i < j\<close> show "good (adds\<^sub>t) seq" by (rule goodI)
 qed
 
 corollary Dickson_termE:
   assumes "dickson_grading d" and "finite (component_of_term ` range (f::nat \<Rightarrow> 't))"
     and "pp_of_term ` range f \<subseteq> dgrad_set d m"
   obtains i j where "i < j" and "f i adds\<^sub>t f j"
 proof -
   let ?A = "{t. pp_of_term t \<in> dgrad_set d m \<and> component_of_term t \<in> component_of_term ` range f}"
   from assms(1, 2) have "almost_full_on (adds\<^sub>t) ?A" by (rule Dickson_term)
   moreover from assms(3) have "\<And>i. f i \<in> ?A" by blast
   ultimately obtain i j where "i < j" and "f i adds\<^sub>t f j" by (rule almost_full_onD)
   thus ?thesis ..
 qed
 
 lemma ex_finite_adds_term:
   assumes "dickson_grading d" and "finite (component_of_term ` S)" and "pp_of_term ` S \<subseteq> dgrad_set d m"
   obtains T where "finite T" and "T \<subseteq> S" and "\<And>s. s \<in> S \<Longrightarrow> (\<exists>t\<in>T. t adds\<^sub>t s)"
 proof -
   let ?A = "{t. pp_of_term t \<in> dgrad_set d m \<and> component_of_term t \<in> component_of_term ` S}"
   have "reflp ((adds\<^sub>t)::'t \<Rightarrow> _)" by (simp add: reflp_def adds_term_refl)
   moreover have "almost_full_on (adds\<^sub>t) S"
   proof (rule almost_full_on_subset)
     from assms(3) show "S \<subseteq> ?A" by blast
   next
     from assms(1, 2) show "almost_full_on (adds\<^sub>t) ?A" by (rule Dickson_term)
   qed
   ultimately obtain T where "finite T" and "T \<subseteq> S" and "\<And>s. s \<in> S \<Longrightarrow> (\<exists>t\<in>T. t adds\<^sub>t s)"
     by (rule almost_full_on_finite_subsetE, blast)
   thus ?thesis ..
 qed
 
 subsection \<open>Well-foundedness\<close>
 
 definition dickson_less_v :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 't \<Rightarrow> 't \<Rightarrow> bool"
   where "dickson_less_v d m v u \<longleftrightarrow> (d (pp_of_term v) \<le> m \<and> d (pp_of_term u) \<le> m \<and> v \<prec>\<^sub>t u)"
 
 definition dickson_less_p :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> bool"
   where "dickson_less_p d m p q \<longleftrightarrow> ({p, q} \<subseteq> dgrad_p_set d m \<and> p \<prec>\<^sub>p q)"
 
 lemma dickson_less_vI:
   assumes "d (pp_of_term v) \<le> m" and "d (pp_of_term u) \<le> m" and "v \<prec>\<^sub>t u"
   shows "dickson_less_v d m v u"
   using assms by (simp add: dickson_less_v_def)
 
 lemma dickson_less_vD1:
   assumes "dickson_less_v d m v u"
   shows "d (pp_of_term v) \<le> m"
   using assms by (simp add: dickson_less_v_def)
 
 lemma dickson_less_vD2:
   assumes "dickson_less_v d m v u"
   shows "d (pp_of_term u) \<le> m"
   using assms by (simp add: dickson_less_v_def)
 
 lemma dickson_less_vD3:
   assumes "dickson_less_v d m v u"
   shows "v \<prec>\<^sub>t u"
   using assms by (simp add: dickson_less_v_def)
 
 lemma dickson_less_v_irrefl: "\<not> dickson_less_v d m v v"
   by (simp add: dickson_less_v_def)
 
 lemma dickson_less_v_trans:
   assumes "dickson_less_v d m v u" and "dickson_less_v d m u w"
   shows "dickson_less_v d m v w"
   using assms by (auto simp add: dickson_less_v_def)
 
 lemma wf_dickson_less_v_aux1:
   assumes "dickson_grading d" and "\<And>i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
   obtains i where "\<And>j. j > i \<Longrightarrow> component_of_term (seq j) < component_of_term (seq i)"
 proof -
   let ?Q = "pp_of_term ` range seq"
   have "pp_of_term (seq 0) \<in> ?Q" by simp
   with wf_dickson_less[OF assms(1)] obtain t where "t \<in> ?Q" and *: "\<And>s. dickson_less d m s t \<Longrightarrow> s \<notin> ?Q"
     by (rule wfE_min[to_pred], blast)
   from this(1) obtain i where t: "t = pp_of_term (seq i)" by fastforce
   show ?thesis
   proof
     fix j
     assume "i < j"
     with _ assms(2) have dlv: "dickson_less_v d m (seq j) (seq i)"
     proof (rule transp_sequence)
       from dickson_less_v_trans show "transp (dickson_less_v d m)" by (rule transpI)
     qed
     hence "seq j \<prec>\<^sub>t seq i" by (rule dickson_less_vD3)
     define s where "s = pp_of_term (seq j)"
     have "pp_of_term (seq j) \<in> ?Q" by simp
     hence "\<not> dickson_less d m s t" unfolding s_def using * by blast
     moreover from dlv have "d s \<le> m" and "d t \<le> m" unfolding s_def t
       by (rule dickson_less_vD1, rule dickson_less_vD2)
     ultimately have "t \<preceq> s" by (simp add: dickson_less_def)
     show "component_of_term (seq j) < component_of_term (seq i)"
     proof (rule ccontr, simp only: not_less)
       assume "component_of_term (seq i) \<le> component_of_term (seq j)"
       with \<open>t \<preceq> s\<close> have "seq i \<preceq>\<^sub>t seq j" unfolding s_def t by (rule ord_termI)
       moreover from dlv have "seq j \<prec>\<^sub>t seq i" by (rule dickson_less_vD3)
       ultimately show False by simp
     qed
   qed
 qed
 
 lemma wf_dickson_less_v_aux2:
   assumes "dickson_grading d" and "\<And>i::nat. dickson_less_v d m (seq (Suc i)) (seq i)"
     and "\<And>i::nat. component_of_term (seq i) < k"
   shows thesis
   using assms(2, 3)
 proof (induct k arbitrary: seq thesis rule: less_induct)
   case (less k)
   from assms(1) less(2) obtain i where *: "\<And>j. j > i \<Longrightarrow> component_of_term (seq j) < component_of_term (seq i)"
     by (rule wf_dickson_less_v_aux1, blast)
   define seq1 where "seq1 = (\<lambda>j. seq (Suc (i + j)))"
   from less(3) show ?case
   proof (rule less(1))
     fix j
     show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact less(2))
   next
     fix j
     show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def *)
   qed
 qed
 
 lemma wf_dickson_less_v:
   assumes "dickson_grading d"
   shows "wfP (dickson_less_v d m)"
 proof (rule wfP_chain, rule, elim exE)
   fix seq::"nat \<Rightarrow> 't"
   assume "\<forall>i. dickson_less_v d m (seq (Suc i)) (seq i)"
   hence *: "\<And>i. dickson_less_v d m (seq (Suc i)) (seq i)" ..
   with assms obtain i where **: "\<And>j. j > i \<Longrightarrow> component_of_term (seq j) < component_of_term (seq i)"
     by (rule wf_dickson_less_v_aux1, blast)
   define seq1 where "seq1 = (\<lambda>j. seq (Suc (i + j)))"
   from assms show False
   proof (rule wf_dickson_less_v_aux2)
     fix j
     show "dickson_less_v d m (seq1 (Suc j)) (seq1 j)" by (simp add: seq1_def, fact *)
   next
     fix j
     show "component_of_term (seq1 j) < component_of_term (seq i)" by (simp add: seq1_def **)
   qed
 qed
 
 lemma dickson_less_v_zero: "dickson_less_v (\<lambda>_. 0) m = (\<prec>\<^sub>t)"
   by (rule, rule, simp add: dickson_less_v_def)
 
 lemma dickson_less_pI:
   assumes "p \<in> dgrad_p_set d m" and "q \<in> dgrad_p_set d m" and "p \<prec>\<^sub>p q"
   shows "dickson_less_p d m p q"
   using assms by (simp add: dickson_less_p_def)
 
 lemma dickson_less_pD1:
   assumes "dickson_less_p d m p q"
   shows "p \<in> dgrad_p_set d m"
   using assms by (simp add: dickson_less_p_def)
 
 lemma dickson_less_pD2:
   assumes "dickson_less_p d m p q"
   shows "q \<in> dgrad_p_set d m"
   using assms by (simp add: dickson_less_p_def)
 
 lemma dickson_less_pD3:
   assumes "dickson_less_p d m p q"
   shows "p \<prec>\<^sub>p q"
   using assms by (simp add: dickson_less_p_def)
 
 lemma dickson_less_p_irrefl: "\<not> dickson_less_p d m p p"
   by (simp add: dickson_less_p_def)
 
 lemma dickson_less_p_trans:
   assumes "dickson_less_p d m p q" and "dickson_less_p d m q r"
   shows "dickson_less_p d m p r"
   using assms by (auto simp add: dickson_less_p_def)
 
 lemma dickson_less_p_mono:
   assumes "dickson_less_p d m p q" and "m \<le> n"
   shows "dickson_less_p d n p q"
 proof -
   from assms(2) have "dgrad_p_set d m \<subseteq> dgrad_p_set d n" by (rule dgrad_p_set_subset)
   moreover from assms(1) have "p \<in> dgrad_p_set d m" and "q \<in> dgrad_p_set d m" and "p \<prec>\<^sub>p q"
     by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
   ultimately have "p \<in> dgrad_p_set d n" and "q \<in> dgrad_p_set d n" by auto
   from this \<open>p \<prec>\<^sub>p q\<close> show ?thesis by (rule dickson_less_pI)
 qed
 
 lemma dickson_less_p_zero: "dickson_less_p (\<lambda>_. 0) m = (\<prec>\<^sub>p)"
   by (rule, rule, simp add: dickson_less_p_def)
 
 lemma wf_dickson_less_p_aux:
   assumes "dickson_grading d"
   assumes "x \<in> Q" and "\<forall>y\<in>Q. y \<noteq> 0 \<longrightarrow> (y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) u)"
   shows "\<exists>p\<in>Q. (\<forall>q\<in>Q. \<not> dickson_less_p d m q p)"
   using assms(2) assms(3)
 proof (induct u arbitrary: x Q rule: wfP_induct[OF wf_dickson_less_v, OF assms(1)])
   fix u::'t and x::"'t \<Rightarrow>\<^sub>0 'b" and Q::"('t \<Rightarrow>\<^sub>0 'b) set"
   assume hyp: "\<forall>u0. dickson_less_v d m u0 u \<longrightarrow> (\<forall>x0 Q0::('t \<Rightarrow>\<^sub>0 'b) set. x0 \<in> Q0 \<longrightarrow>
                             (\<forall>y\<in>Q0. y \<noteq> 0 \<longrightarrow> (y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) u0)) \<longrightarrow>
                             (\<exists>p\<in>Q0. \<forall>q\<in>Q0. \<not> dickson_less_p d m q p))"
   assume "x \<in> Q"
   assume "\<forall>y\<in>Q. y \<noteq> 0 \<longrightarrow> (y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) u)"
   hence bounded: "\<And>y. y \<in> Q \<Longrightarrow> y \<noteq> 0 \<Longrightarrow> (y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) u)" by auto
   show "\<exists>p\<in>Q. \<forall>q\<in>Q. \<not> dickson_less_p d m q p"
   proof (cases "0 \<in> Q")
     case True
     show ?thesis
     proof (rule, rule, rule)
       fix q::"'t \<Rightarrow>\<^sub>0 'b"
       assume "dickson_less_p d m q 0"
       hence "q \<prec>\<^sub>p 0" by (rule dickson_less_pD3)
       thus False using ord_p_zero_min[of q] by simp
     next
       from True show "0 \<in> Q" .
     qed
   next
     case False
     define Q1 where "Q1 = {lt p | p. p \<in> Q}"
     from \<open>x \<in> Q\<close> have "lt x \<in> Q1" unfolding Q1_def by auto
     with wf_dickson_less_v[OF assms(1)] obtain v
       where "v \<in> Q1" and v_min_1: "\<And>q. dickson_less_v d m q v \<Longrightarrow> q \<notin> Q1"
       by (rule wfE_min[to_pred], auto)
     have v_min: "\<And>q. q \<in> Q \<Longrightarrow> \<not> dickson_less_v d m (lt q) v"
     proof -
       fix q
       assume "q \<in> Q"
       hence "lt q \<in> Q1" unfolding Q1_def by auto
       thus "\<not> dickson_less_v d m (lt q) v" using v_min_1 by auto
     qed
     from \<open>v \<in> Q1\<close> obtain p where "lt p = v" and "p \<in> Q" unfolding Q1_def by auto
     hence "p \<noteq> 0" using False by auto
     with \<open>p \<in> Q\<close> have "p \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt p) u" by (rule bounded)
     hence "p \<in> dgrad_p_set d m" and "dickson_less_v d m (lt p) u" by simp_all
     moreover from this(1) \<open>p \<noteq> 0\<close> have "d (pp_of_term (lt p)) \<le> m" by (rule dgrad_p_setD_lp)
     ultimately have "d (pp_of_term v) \<le> m" by (simp only: \<open>lt p = v\<close>)
     define Q2 where "Q2 = {tail p | p. p \<in> Q \<and> lt p = v}"
     from \<open>p \<in> Q\<close> \<open>lt p = v\<close> have "tail p \<in> Q2" unfolding Q2_def by auto
     have "\<forall>q\<in>Q2. q \<noteq> 0 \<longrightarrow> (q \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt q) (lt p))"
     proof (intro ballI impI)
       fix q
       assume "q \<in> Q2"
       then obtain q0 where q: "q = tail q0" and "lt q0 = lt p" and "q0 \<in> Q"
         using \<open>lt p = v\<close> by (auto simp add: Q2_def)
       assume "q \<noteq> 0"
       hence "tail q0 \<noteq> 0" using \<open>q = tail q0\<close> by simp
       hence "q0 \<noteq> 0" by auto
       with \<open>q0 \<in> Q\<close> have "q0 \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt q0) u" by (rule bounded)
       hence "q0 \<in> dgrad_p_set d m" and "dickson_less_v d m (lt q0) u" by simp_all
       from this(1) have "q \<in> dgrad_p_set d m" unfolding q by (rule dgrad_p_set_closed_tail)
       show "q \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt q) (lt p)"
       proof
         show "dickson_less_v d m (lt q) (lt p)"
         proof (rule dickson_less_vI)
           from \<open>q \<in> dgrad_p_set d m\<close> \<open>q \<noteq> 0\<close> show "d (pp_of_term (lt q)) \<le> m" by (rule dgrad_p_setD_lp)
         next
           from \<open>dickson_less_v d m (lt p) u\<close> show "d (pp_of_term (lt p)) \<le> m" by (rule dickson_less_vD1)
         next
           from lt_tail[OF \<open>tail q0 \<noteq> 0\<close>] \<open>q = tail q0\<close> \<open>lt q0 = lt p\<close> show "lt q \<prec>\<^sub>t lt p" by simp
         qed
       qed fact
     qed
     with hyp \<open>dickson_less_v d m (lt p) u\<close> \<open>tail p \<in> Q2\<close> have "\<exists>p\<in>Q2. \<forall>q\<in>Q2. \<not> dickson_less_p d m q p"
       by blast
     then obtain q where "q \<in> Q2" and q_min: "\<forall>r\<in>Q2. \<not> dickson_less_p d m r q" ..
     from \<open>q \<in> Q2\<close> obtain q0 where "q = tail q0" and "q0 \<in> Q" and "lt q0 = v" unfolding Q2_def by auto
     from q_min \<open>q = tail q0\<close> have q0_tail_min: "\<And>r. r \<in> Q2 \<Longrightarrow> \<not> dickson_less_p d m r (tail q0)" by simp
     from \<open>q0 \<in> Q\<close> show ?thesis
     proof
       show "\<forall>r\<in>Q. \<not> dickson_less_p d m r q0"
       proof (intro ballI notI)
         fix r
         assume "dickson_less_p d m r q0"
         hence "r \<in> dgrad_p_set d m" and "q0 \<in> dgrad_p_set d m" and "r \<prec>\<^sub>p q0"
           by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
         from this(3) have "lt r \<preceq>\<^sub>t lt q0" by (simp add: ord_p_lt)
         with \<open>lt q0 = v\<close> have "lt r \<preceq>\<^sub>t v" by simp
         assume "r \<in> Q"
         hence "\<not> dickson_less_v d m (lt r) v" by (rule v_min)
         from False \<open>r \<in> Q\<close> have "r \<noteq> 0" using False by blast
         with \<open>r \<in> dgrad_p_set d m\<close> have "d (pp_of_term (lt r)) \<le> m" by (rule dgrad_p_setD_lp)
         have "\<not> lt r \<prec>\<^sub>t v"
         proof
           assume "lt r \<prec>\<^sub>t v"
           with \<open>d (pp_of_term (lt r)) \<le> m\<close> \<open>d (pp_of_term v) \<le> m\<close> have "dickson_less_v d m (lt r) v"
             by (rule dickson_less_vI)
           with \<open>\<not> dickson_less_v d m (lt r) v\<close> show False ..
         qed
         with \<open>lt r \<preceq>\<^sub>t v\<close> have "lt r = v" by simp
         with \<open>r \<in> Q\<close> have "tail r \<in> Q2" by (auto simp add: Q2_def)
         have "dickson_less_p d m (tail r) (tail q0)"
         proof (rule dickson_less_pI)
           show "tail r \<in> dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
         next
           show "tail q0 \<in> dgrad_p_set d m" by (rule dgrad_p_set_closed_tail, fact)
         next
           have "lt r = lt q0" by (simp only: \<open>lt r = v\<close> \<open>lt q0 = v\<close>)
           from \<open>r \<noteq> 0\<close> this \<open>r \<prec>\<^sub>p q0\<close> show "tail r \<prec>\<^sub>p tail q0" by (rule ord_p_tail)
         qed
         with q0_tail_min[OF \<open>tail r \<in> Q2\<close>] show False ..
       qed
     qed
   qed
 qed
 
 theorem wf_dickson_less_p:
   assumes "dickson_grading d"
   shows "wfP (dickson_less_p d m)"
 proof (rule wfI_min[to_pred])
   fix Q::"('t \<Rightarrow>\<^sub>0 'b) set" and x
   assume "x \<in> Q"
   show "\<exists>z\<in>Q. \<forall>y. dickson_less_p d m y z \<longrightarrow> y \<notin> Q"
   proof (cases "0 \<in> Q")
     case True
     show ?thesis
     proof (rule, rule, rule)
       from True show "0 \<in> Q" .
     next
       fix q::"'t \<Rightarrow>\<^sub>0 'b"
       assume "dickson_less_p d m q 0"
       hence "q \<prec>\<^sub>p 0" by (rule dickson_less_pD3)
       thus "q \<notin> Q" using ord_p_zero_min[of q] by simp
     qed
   next
     case False
     show ?thesis
     proof (cases "Q \<subseteq> dgrad_p_set d m")
       case True
       let ?L = "lt ` Q"
       from \<open>x \<in> Q\<close> have "lt x \<in> ?L" by simp
       with wf_dickson_less_v[OF assms] obtain v where "v \<in> ?L"
         and v_min: "\<And>u. dickson_less_v d m u v \<Longrightarrow> u \<notin> ?L" by (rule wfE_min[to_pred], blast)
       from this(1) obtain x1 where "x1 \<in> Q" and "v = lt x1" ..
       from this(1) True False have "x1 \<in> dgrad_p_set d m" and "x1 \<noteq> 0" by auto
       hence "d (pp_of_term v) \<le> m" unfolding \<open>v = lt x1\<close> by (rule dgrad_p_setD_lp)
       define Q1 where "Q1 = {tail p | p. p \<in> Q \<and> lt p = v}"
       from \<open>x1 \<in> Q\<close> have "tail x1 \<in> Q1" by (auto simp add: Q1_def \<open>v = lt x1\<close>)
       with assms have "\<exists>p\<in>Q1. \<forall>q\<in>Q1. \<not> dickson_less_p d m q p"
       proof (rule wf_dickson_less_p_aux)
         show "\<forall>y\<in>Q1. y \<noteq> 0 \<longrightarrow> y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) v"
         proof (intro ballI impI)
           fix y
           assume "y \<in> Q1" and "y \<noteq> 0"
           from this(1) obtain y1 where "y1 \<in> Q" and "v = lt y1" and "y = tail y1" unfolding Q1_def
             by blast
           from this(1) True have "y1 \<in> dgrad_p_set d m" ..
           hence "y \<in> dgrad_p_set d m" unfolding \<open>y = tail y1\<close> by (rule dgrad_p_set_closed_tail)
           thus "y \<in> dgrad_p_set d m \<and> dickson_less_v d m (lt y) v"
           proof
             show "dickson_less_v d m (lt y) v"
             proof (rule dickson_less_vI)
               from \<open>y \<in> dgrad_p_set d m\<close> \<open>y \<noteq> 0\<close> show "d (pp_of_term (lt y)) \<le> m"
                 by (rule dgrad_p_setD_lp)
             next
               from \<open>y \<noteq> 0\<close> show "lt y \<prec>\<^sub>t v" unfolding \<open>v = lt y1\<close> \<open>y = tail y1\<close> by (rule lt_tail)
             qed fact
           qed
         qed
       qed
       then obtain p0 where "p0 \<in> Q1" and p0_min: "\<And>q. q \<in> Q1 \<Longrightarrow> \<not> dickson_less_p d m q p0" by blast
       from this(1) obtain p where "p \<in> Q" and "v = lt p" and "p0 = tail p" unfolding Q1_def
         by blast
       from this(1) False have "p \<noteq> 0" by blast
       show ?thesis
       proof (intro bexI allI impI notI)
         fix y
         assume "y \<in> Q"
         hence "y \<noteq> 0" using False by blast
         assume "dickson_less_p d m y p"
         hence "y \<in> dgrad_p_set d m" and "p \<in> dgrad_p_set d m" and "y \<prec>\<^sub>p p"
           by (rule dickson_less_pD1, rule dickson_less_pD2, rule dickson_less_pD3)
         from this(3) have "y \<preceq>\<^sub>p p" by simp
         hence "lt y \<preceq>\<^sub>t lt p" by (rule ord_p_lt)
         moreover have "\<not> lt y \<prec>\<^sub>t lt p"
         proof
           assume "lt y \<prec>\<^sub>t lt p"
           have "dickson_less_v d m (lt y) v" unfolding \<open>v = lt p\<close>
             by (rule dickson_less_vI, rule dgrad_p_setD_lp, fact+, rule dgrad_p_setD_lp, fact+)
           hence "lt y \<notin> ?L" by (rule v_min)
           hence "y \<notin> Q" by fastforce
           from this \<open>y \<in> Q\<close> show False ..
         qed
         ultimately have "lt y = lt p" by simp
         from \<open>y \<noteq> 0\<close> this \<open>y \<prec>\<^sub>p p\<close> have "tail y \<prec>\<^sub>p tail p" by (rule ord_p_tail)
         from \<open>y \<in> Q\<close> have "tail y \<in> Q1" by (auto simp add: Q1_def \<open>v = lt p\<close> \<open>lt y = lt p\<close>[symmetric])
         hence "\<not> dickson_less_p d m (tail y) p0" by (rule p0_min)
         moreover have "dickson_less_p d m (tail y) p0" unfolding \<open>p0 = tail p\<close>
           by (rule dickson_less_pI, rule dgrad_p_set_closed_tail, fact, rule dgrad_p_set_closed_tail, fact+)
         ultimately show False ..
       qed fact
     next
       case False
       then obtain q where "q \<in> Q" and "q \<notin> dgrad_p_set d m" by blast
       from this(1) show ?thesis
       proof
         show "\<forall>y. dickson_less_p d m y q \<longrightarrow> y \<notin> Q"
         proof (intro allI impI)
           fix y
           assume "dickson_less_p d m y q"
           hence "q \<in> dgrad_p_set d m" by (rule dickson_less_pD2)
           with \<open>q \<notin> dgrad_p_set d m\<close> show "y \<notin> Q" ..
         qed
       qed
     qed
   qed
 qed
 
 corollary ord_p_minimum_dgrad_p_set:
   assumes "dickson_grading d" and "x \<in> Q" and "Q \<subseteq> dgrad_p_set d m"
   obtains q where "q \<in> Q" and "\<And>y. y \<prec>\<^sub>p q \<Longrightarrow> y \<notin> Q"
 proof -
   from assms(1) have "wfP (dickson_less_p d m)" by (rule wf_dickson_less_p)
   from this assms(2) obtain q where "q \<in> Q" and *: "\<And>y. dickson_less_p d m y q \<Longrightarrow> y \<notin> Q"
     by (rule wfE_min[to_pred], auto)
   from assms(3) \<open>q \<in> Q\<close> have "q \<in> dgrad_p_set d m" ..
   from \<open>q \<in> Q\<close> show ?thesis
   proof
     fix y
     assume "y \<prec>\<^sub>p q"
     show "y \<notin> Q"
     proof
       assume "y \<in> Q"
       with assms(3) have "y \<in> dgrad_p_set d m" ..
       from this \<open>q \<in> dgrad_p_set d m\<close> \<open>y \<prec>\<^sub>p q\<close> have "dickson_less_p d m y q"
         by (rule dickson_less_pI)
       hence "y \<notin> Q" by (rule *)
       from this \<open>y \<in> Q\<close> show False ..
     qed
   qed
 qed
 
 lemma ord_term_minimum_dgrad_set:
   assumes "dickson_grading d" and "v \<in> V" and "pp_of_term ` V \<subseteq> dgrad_set d m"
   obtains u where "u \<in> V" and "\<And>w. w \<prec>\<^sub>t u \<Longrightarrow> w \<notin> V"
 proof -
   from assms(1) have "wfP (dickson_less_v d m)" by (rule wf_dickson_less_v)
   then obtain u where "u \<in> V" and *: "\<And>w. dickson_less_v d m w u \<Longrightarrow> w \<notin> V" using assms(2)
     by (rule wfE_min[to_pred]) blast
   from this(1) have "pp_of_term u \<in> pp_of_term ` V" by (rule imageI)
   with assms(3) have "pp_of_term u \<in> dgrad_set d m" ..
   hence "d (pp_of_term u) \<le> m" by (rule dgrad_setD)
   from \<open>u \<in> V\<close> show ?thesis
   proof
     fix w
     assume "w \<prec>\<^sub>t u"
     show "w \<notin> V"
     proof
       assume "w \<in> V"
       hence "pp_of_term w \<in> pp_of_term ` V" by (rule imageI)
       with assms(3) have "pp_of_term w \<in> dgrad_set d m" ..
       hence "d (pp_of_term w) \<le> m" by (rule dgrad_setD)
       from this \<open>d (pp_of_term u) \<le> m\<close> \<open>w \<prec>\<^sub>t u\<close> have "dickson_less_v d m w u"
         by (rule dickson_less_vI)
       hence "w \<notin> V" by (rule *)
       from this \<open>w \<in> V\<close> show False ..
     qed
   qed
 qed
 
 end (* gd_term *)
 
 subsection \<open>More Interpretations\<close>
 
 context gd_powerprod
 begin
 
 sublocale punit: gd_term to_pair_unit fst "(\<preceq>)" "(\<prec>)" "(\<preceq>)" "(\<prec>)" ..
 
 end
 
 locale od_term =
     ordered_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
       for pair_of_term::"'t \<Rightarrow> ('a::dickson_powerprod \<times> 'k::{the_min,wellorder})"
       and term_of_pair::"('a \<times> 'k) \<Rightarrow> 't"
       and ord::"'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<preceq>" 50)
       and ord_strict (infixl "\<prec>" 50)
       and ord_term::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<preceq>\<^sub>t" 50)
       and ord_term_strict::"'t \<Rightarrow> 't \<Rightarrow> bool" (infixl "\<prec>\<^sub>t" 50)
 begin
 
 sublocale gd_term ..
 
 lemma ord_p_wf: "wfP (\<prec>\<^sub>p)"
 proof -
   from dickson_grading_zero have "wfP (dickson_less_p (\<lambda>_. 0) 0)" by (rule wf_dickson_less_p)
   thus ?thesis by (simp only: dickson_less_p_zero)
 qed
 
 end (* od_term *)
 
 end (* theory *)
diff --git a/thys/Refine_Imperative_HOL/IICF/Impl/IICF_Sepl_Binding.thy b/thys/Refine_Imperative_HOL/IICF/Impl/IICF_Sepl_Binding.thy
--- a/thys/Refine_Imperative_HOL/IICF/Impl/IICF_Sepl_Binding.thy
+++ b/thys/Refine_Imperative_HOL/IICF/Impl/IICF_Sepl_Binding.thy
@@ -1,813 +1,813 @@
 section \<open>Sepref Bindings for Imp/HOL Collections\<close>
 theory IICF_Sepl_Binding
 imports 
   Separation_Logic_Imperative_HOL.Imp_Map_Spec
   Separation_Logic_Imperative_HOL.Imp_Set_Spec
   Separation_Logic_Imperative_HOL.Imp_List_Spec
 
   Separation_Logic_Imperative_HOL.Hash_Map_Impl
   Separation_Logic_Imperative_HOL.Array_Map_Impl
 
   Separation_Logic_Imperative_HOL.To_List_GA
   Separation_Logic_Imperative_HOL.Hash_Set_Impl
   Separation_Logic_Imperative_HOL.Array_Set_Impl
 
   Separation_Logic_Imperative_HOL.Open_List
   Separation_Logic_Imperative_HOL.Circ_List
 
   "../Intf/IICF_Map"
   "../Intf/IICF_Set"
   "../Intf/IICF_List"
 
   Collections.Locale_Code
 begin
   text \<open>This theory binds collection data structures from the 
     basic collection framework established in 
     \<open>AFP/Separation_Logic_Imperative_HOL\<close> for usage with Sepref.
   \<close>
   
   (* TODO: Move, addition to Imp_Map_Spec *)
   locale imp_map_contains_key = imp_map +
     constrains is_map :: "('k \<rightharpoonup> 'v) \<Rightarrow> 'm \<Rightarrow> assn"
     fixes contains_key :: "'k \<Rightarrow> 'm \<Rightarrow> bool Heap"
     assumes contains_key_rule[sep_heap_rules]: 
       "<is_map m p> contains_key k p <\<lambda>r. is_map m p * \<up>(r\<longleftrightarrow>k\<in>dom m)>\<^sub>t"
     
   (* TODO: Move to Imp_Map_Spec *)    
   locale gen_contains_key_by_lookup = imp_map_lookup
   begin   
     definition "contains_key k m \<equiv> do {r \<leftarrow> lookup k m; return (\<not>is_None r)}"
 
     sublocale imp_map_contains_key is_map contains_key
       apply unfold_locales
       unfolding contains_key_def
       apply (sep_auto split: option.splits)
       done
 
   end
 
   (* TODO: Move to Imp_List_Spec *)
   locale imp_list_tail = imp_list +
     constrains is_list :: "'a list \<Rightarrow> 'l \<Rightarrow> assn"
     fixes tail :: "'l \<Rightarrow> 'l Heap"
     assumes tail_rule[sep_heap_rules]: 
       "l\<noteq>[] \<Longrightarrow> <is_list l p> tail p <is_list (tl l)>\<^sub>t"
 
   (* TODO: Move to Open_List *)  
   definition os_head :: "'a::heap os_list \<Rightarrow> ('a) Heap" where
     "os_head p \<equiv> case p of 
       None \<Rightarrow> raise STR ''os_Head: Empty list''
     | Some p \<Rightarrow> do { m \<leftarrow>!p; return (val m) }"
 
   primrec os_tl :: "'a::heap os_list \<Rightarrow> ('a os_list) Heap" where
     "os_tl None = raise STR ''os_tl: Empty list''"
   | "os_tl (Some p) = do { m \<leftarrow>!p; return (next m) }"  
 
   interpretation os: imp_list_head os_list os_head
     by unfold_locales (sep_auto simp: os_head_def neq_Nil_conv)
 
   interpretation os: imp_list_tail os_list os_tl
     by unfold_locales (sep_auto simp: os_tl_def neq_Nil_conv)
 
 
   (* TODO: Move to Circ_List *)
   definition cs_is_empty :: "'a::heap cs_list \<Rightarrow> bool Heap" where
     "cs_is_empty p \<equiv> return (is_None p)"  
   interpretation cs: imp_list_is_empty cs_list cs_is_empty  
     by unfold_locales (sep_auto simp: cs_is_empty_def split: option.splits)
 
   definition cs_head :: "'a::heap cs_list \<Rightarrow> 'a Heap" where
     "cs_head p \<equiv> case p of 
       None \<Rightarrow> raise STR ''cs_head: Empty list''
     | Some p \<Rightarrow> do { n \<leftarrow> !p; return (val n)}"
   interpretation cs: imp_list_head cs_list cs_head
     by unfold_locales (sep_auto simp: neq_Nil_conv cs_head_def)
     
   definition cs_tail :: "'a::heap cs_list \<Rightarrow> 'a cs_list Heap" where
     "cs_tail p \<equiv> do { (_,r) \<leftarrow> cs_pop p; return r }"
   interpretation cs: imp_list_tail cs_list cs_tail
     by unfold_locales (sep_auto simp: cs_tail_def)
 
 
   (* TODO: Move to hashmap/hashset *)  
   lemma is_hashmap_finite[simp]: "h \<Turnstile> is_hashmap m mi \<Longrightarrow> finite (dom m)"
     unfolding is_hashmap_def is_hashmap'_def
     by auto
 
   lemma is_hashset_finite[simp]: "h \<Turnstile> is_hashset s si \<Longrightarrow> finite s"
     unfolding is_hashset_def
     by (auto dest: is_hashmap_finite)
 
 
   (* TODO: Move to array-map/ array-set *)  
   definition "ias_is_it s a si \<equiv> \<lambda>(a',i).
     \<exists>\<^sub>Al. a\<mapsto>\<^sub>al * \<up>(a'=a \<and> s=ias_of_list l \<and> (i=length l \<and> si={} \<or> i<length l \<and> i\<in>s \<and> si=s \<inter> {x. x\<ge>i} ))
   "
 
   context begin  
   private function first_memb where 
     "first_memb lmax a i = do {
       if i<lmax then do {
         x \<leftarrow> Array.nth a i;
         if x then return i else first_memb lmax a (Suc i)
       } else 
         return i
     }"
     by pat_completeness auto
   termination by (relation "measure (\<lambda>(l,_,i). l-i)") auto
   declare first_memb.simps[simp del]
      
   private lemma first_memb_rl_aux:
     assumes "lmax \<le> length l" "i\<le>lmax" 
     shows 
       "< a \<mapsto>\<^sub>a l > 
         first_memb lmax a i 
       <\<lambda>k. a\<mapsto>\<^sub>a l * \<up>(k\<le>lmax \<and> (\<forall>j. i\<le>j \<and> j<k \<longrightarrow> \<not>l!j) \<and> i\<le>k \<and> (k=lmax \<or> l!k)) >"
     using assms  
   proof (induction lmax a i rule: first_memb.induct)
     case (1 lmax a i)
     show ?case
       apply (subst first_memb.simps)
       using "1.prems"
       apply (sep_auto heap: "1.IH"; ((sep_auto;fail) | metis eq_iff not_less_eq_eq))
       done
   qed  
 
   private lemma first_memb_rl[sep_heap_rules]:
     assumes "lmax \<le> length l" "i\<le>lmax" 
     shows "< a \<mapsto>\<^sub>a l > 
       first_memb lmax a i 
     <\<lambda>k. a\<mapsto>\<^sub>a l * \<up>(ias_of_list l \<inter> {i..<k} = {} \<and> i\<le>k \<and> (k<lmax \<and> k\<in>ias_of_list l \<or> k=lmax) ) >"
     using assms
     by (sep_auto simp: ias_of_list_def heap: first_memb_rl_aux)
 
   definition "ias_it_init a = do {
     l \<leftarrow> Array.len a;
     i \<leftarrow> first_memb l a 0;
     return (a,i)
   }"
 
   definition "ias_it_has_next \<equiv> \<lambda>(a,i). do {
     l \<leftarrow> Array.len a;
     return (i<l)
   }"
 
   definition "ias_it_next \<equiv> \<lambda>(a,i). do {
     l \<leftarrow> Array.len a;
     i' \<leftarrow> first_memb l a (Suc i);
     return (i,(a,i'))
   }"
 
   (* TODO: Move *)
   lemma ias_of_list_bound: "ias_of_list l \<subseteq> {0..<length l}" by (auto simp: ias_of_list_def)
 
   end  
 
   interpretation ias: imp_set_iterate is_ias ias_is_it ias_it_init ias_it_has_next ias_it_next
     apply unfold_locales
     unfolding is_ias_def ias_is_it_def
     unfolding ias_it_init_def using ias_of_list_bound
     apply (sep_auto)
     unfolding ias_it_next_def using ias_of_list_bound
     apply (sep_auto; fastforce) (* Takes long *)
     unfolding ias_it_has_next_def 
     apply sep_auto
     apply sep_auto
     done
     
   lemma ias_of_list_finite[simp, intro!]: "finite (ias_of_list l)"
     using finite_subset[OF ias_of_list_bound] by auto
 
   lemma is_ias_finite[simp]: "h \<Turnstile> is_ias S x \<Longrightarrow> finite S"  
     unfolding is_ias_def by auto
 
 
   (* TODO: Move, replace original rules by this stronger var! *)
   lemma to_list_ga_rec_rule:
     assumes "imp_set_iterate is_set is_it it_init it_has_next it_next"
     assumes "imp_list_prepend is_list l_prepend"
     assumes FIN: "finite it"
     assumes DIS: "distinct l" "set l \<inter> it = {}"
     shows "
     < is_it s si it iti * is_list l li > 
       to_list_ga_rec it_has_next it_next l_prepend iti li
     < \<lambda>r. \<exists>\<^sub>Al'. is_set s si 
       * is_list l' r
       * \<up>(distinct l' \<and> set l' = set l \<union> it) >\<^sub>t"
   proof -
     interpret imp_set_iterate is_set is_it it_init it_has_next it_next
       + imp_list_prepend is_list l_prepend
       by fact+
 
     from FIN DIS show ?thesis
     proof (induction arbitrary: l li iti rule: finite_psubset_induct)
       case (psubset it)
       show ?case
         apply (subst to_list_ga_rec.simps)
         using psubset.prems apply (sep_auto heap: psubset.IH)
         apply (rule ent_frame_fwd[OF quit_iteration])
         apply frame_inference
         apply solve_entails
         done
     qed
   qed
   lemma to_list_ga_rule:
     assumes IT: "imp_set_iterate is_set is_it it_init it_has_next it_next"
     assumes EM: "imp_list_empty is_list l_empty"
     assumes PREP: "imp_list_prepend is_list l_prepend"
     assumes FIN: "finite s"
     shows "
     <is_set s si>
     to_list_ga it_init it_has_next it_next
       l_empty l_prepend si
     <\<lambda>r. \<exists>\<^sub>Al. is_set s si * is_list l r * true * \<up>(distinct l \<and> set l = s)>"
   proof -
     interpret imp_list_empty is_list l_empty +
       imp_set_iterate is_set is_it it_init it_has_next it_next
       by fact+
 
     note [sep_heap_rules] = to_list_ga_rec_rule[OF IT PREP]
     show ?thesis
       unfolding to_list_ga_def
       by (sep_auto simp: FIN)
   qed
 
 
 
 
   subsection \<open>Binding Locales\<close>
   
   method solve_sepl_binding = (
     unfold_locales;
     (unfold option_assn_pure_conv)?;
     sep_auto 
       intro!: hfrefI hn_refineI[THEN hn_refine_preI]
       simp: invalid_assn_def hn_ctxt_def pure_def
   )
 
 
   subsubsection \<open>Map\<close>
 
   locale bind_map = imp_map is_map for is_map :: "('ki \<rightharpoonup> 'vi) \<Rightarrow> 'm \<Rightarrow> assn"
   begin
     definition "assn K V \<equiv> hr_comp is_map (\<langle>the_pure K,the_pure V\<rangle>map_rel)"
     lemmas [fcomp_norm_unfold] = assn_def[symmetric]
     lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "assn K V" for K V]
 
   end
 
   locale bind_map_empty = imp_map_empty + bind_map
   begin
     lemma empty_hnr_aux: "(uncurry0 empty,uncurry0 (RETURN op_map_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_map"
       by solve_sepl_binding
 
     sepref_decl_impl (no_register) empty: empty_hnr_aux .
   end  
 
 
   locale bind_map_is_empty = imp_map_is_empty + bind_map
   begin
     lemma is_empty_hnr_aux: "(is_empty,RETURN o op_map_is_empty) \<in> is_map\<^sup>k \<rightarrow>\<^sub>a bool_assn"
       by solve_sepl_binding
       
     sepref_decl_impl is_empty: is_empty_hnr_aux .
   end
   
 
   locale bind_map_update = imp_map_update + bind_map
   begin
     lemma update_hnr_aux: "(uncurry2 update,uncurry2 (RETURN ooo op_map_update)) \<in> id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a is_map\<^sup>d \<rightarrow>\<^sub>a is_map"
       by solve_sepl_binding
 
     sepref_decl_impl update: update_hnr_aux .
   end
 
 
   locale bind_map_delete = imp_map_delete + bind_map
   begin
     lemma delete_hnr_aux: "(uncurry delete,uncurry (RETURN oo op_map_delete)) \<in> id_assn\<^sup>k *\<^sub>a is_map\<^sup>d \<rightarrow>\<^sub>a is_map"
       by solve_sepl_binding
 
     sepref_decl_impl delete: delete_hnr_aux .
   end
 
 
   locale bind_map_lookup = imp_map_lookup + bind_map
   begin
     lemma lookup_hnr_aux: "(uncurry lookup,uncurry (RETURN oo op_map_lookup)) \<in> id_assn\<^sup>k *\<^sub>a is_map\<^sup>k \<rightarrow>\<^sub>a id_assn"
       by solve_sepl_binding
 
     sepref_decl_impl lookup: lookup_hnr_aux .
   end
 
   locale bind_map_contains_key = imp_map_contains_key + bind_map
   begin
     lemma contains_key_hnr_aux: "(uncurry contains_key,uncurry (RETURN oo op_map_contains_key)) \<in> id_assn\<^sup>k *\<^sub>a is_map\<^sup>k \<rightarrow>\<^sub>a bool_assn"
       by solve_sepl_binding
 
     sepref_decl_impl contains_key: contains_key_hnr_aux .
   end
 
   subsubsection \<open>Set\<close>
 
   locale bind_set = imp_set is_set for is_set :: "('ai set) \<Rightarrow> 'm \<Rightarrow> assn" +
     fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
   begin
     definition "assn \<equiv> hr_comp is_set (\<langle>the_pure A\<rangle>set_rel)"
     lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "assn"]
   end
 
   locale bind_set_setup = bind_set 
   begin
     (* TODO: Use sepref_decl_impl (see map) *)
     lemmas [fcomp_norm_unfold] = assn_def[symmetric]
     lemma APA: "\<lbrakk>PROP Q; CONSTRAINT is_pure A\<rbrakk> \<Longrightarrow> PROP Q" .
     lemma APAlu: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
     lemma APAru: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
     lemma APAbu: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A; CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
 
 
   end  
 
   locale bind_set_empty = imp_set_empty + bind_set
   begin
     lemma hnr_empty_aux: "(uncurry0 empty,uncurry0 (RETURN op_set_empty))\<in>unit_assn\<^sup>k \<rightarrow>\<^sub>a is_set"
       by solve_sepl_binding
 
     interpretation bind_set_setup by standard  
 
     lemmas hnr_op_empty = hnr_empty_aux[FCOMP op_set_empty.fref[where A="the_pure A"]] 
     lemmas hnr_mop_empty = hnr_op_empty[FCOMP mk_mop_rl0_np[OF mop_set_empty_alt]]
   end  
 
   locale bind_set_is_empty = imp_set_is_empty + bind_set
   begin
     lemma hnr_is_empty_aux: "(is_empty, RETURN o op_set_is_empty)\<in>is_set\<^sup>k \<rightarrow>\<^sub>a bool_assn"
       by solve_sepl_binding
 
     interpretation bind_set_setup by standard  
     lemmas hnr_op_is_empty[sepref_fr_rules] = hnr_is_empty_aux[THEN APA,FCOMP op_set_is_empty.fref[where A="the_pure A"]] 
     lemmas hnr_mop_is_empty[sepref_fr_rules] = hnr_op_is_empty[FCOMP mk_mop_rl1_np[OF mop_set_is_empty_alt]]
   end  
 
   locale bind_set_member = imp_set_memb + bind_set
   begin
     lemma hnr_member_aux: "(uncurry memb, uncurry (RETURN oo op_set_member))\<in>id_assn\<^sup>k *\<^sub>a is_set\<^sup>k \<rightarrow>\<^sub>a bool_assn"
       by solve_sepl_binding
 
     interpretation bind_set_setup by standard  
     lemmas hnr_op_member[sepref_fr_rules] = hnr_member_aux[THEN APAbu,FCOMP op_set_member.fref[where A="the_pure A"]] 
     lemmas hnr_mop_member[sepref_fr_rules] = hnr_op_member[FCOMP mk_mop_rl2_np[OF mop_set_member_alt]]
   end  
 
   locale bind_set_insert = imp_set_ins + bind_set
   begin
     lemma hnr_insert_aux: "(uncurry ins, uncurry (RETURN oo op_set_insert))\<in>id_assn\<^sup>k *\<^sub>a is_set\<^sup>d \<rightarrow>\<^sub>a is_set"
       by solve_sepl_binding
 
     interpretation bind_set_setup by standard  
     lemmas hnr_op_insert[sepref_fr_rules] = hnr_insert_aux[THEN APAru,FCOMP op_set_insert.fref[where A="the_pure A"]] 
     lemmas hnr_mop_insert[sepref_fr_rules] = hnr_op_insert[FCOMP mk_mop_rl2_np[OF mop_set_insert_alt]]
   end  
 
   locale bind_set_delete = imp_set_delete + bind_set
   begin
     lemma hnr_delete_aux: "(uncurry delete, uncurry (RETURN oo op_set_delete))\<in>id_assn\<^sup>k *\<^sub>a is_set\<^sup>d \<rightarrow>\<^sub>a is_set"
       by solve_sepl_binding
 
     interpretation bind_set_setup by standard  
     lemmas hnr_op_delete[sepref_fr_rules] = hnr_delete_aux[THEN APAbu,FCOMP op_set_delete.fref[where A="the_pure A"]] 
     lemmas hnr_mop_delete[sepref_fr_rules] = hnr_op_delete[FCOMP mk_mop_rl2_np[OF mop_set_delete_alt]]
   end  
 
   primrec sorted_wrt' where
     "sorted_wrt' R [] \<longleftrightarrow> True"
   | "sorted_wrt' R (x#xs) \<longleftrightarrow> list_all (R x) xs \<and> sorted_wrt' R xs"  
 
   lemma sorted_wrt'_eq: "sorted_wrt' = sorted_wrt" 
   proof (intro ext iffI)
     fix R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and xs :: "'a list"
     {
       assume "sorted_wrt R xs"
       thus "sorted_wrt' R xs"
-        by (induction xs)(auto simp: list_all_iff sorted_sorted_wrt[symmetric])
+        by (induction xs)(auto simp: list_all_iff)
     }
     {
       assume "sorted_wrt' R xs"
       thus "sorted_wrt R xs"
         by (induction xs) (auto simp: list_all_iff)
     }
   qed    
 
   lemma param_sorted_wrt[param]: "(sorted_wrt, sorted_wrt) \<in> (A \<rightarrow> A \<rightarrow> bool_rel) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
     unfolding sorted_wrt'_eq[symmetric] sorted_wrt'_def 
     by parametricity
 
   lemma obtain_list_from_setrel:
     assumes SV: "single_valued A"
     assumes "(set l,s) \<in> \<langle>A\<rangle>set_rel"
     obtains m where "s=set m" "(l,m)\<in>\<langle>A\<rangle>list_rel"
     using assms(2)
   proof (induction l arbitrary: s thesis)
     case Nil
     show ?case
       apply (rule Nil(1)[where m="[]"])
       using Nil(2)
       by auto
   next
     case (Cons x l) 
     obtain s' y where "s=insert y s'" "(x,y)\<in>A" "(set l,s')\<in>\<langle>A\<rangle>set_rel"
     proof -
       from Cons.prems(2) obtain y where X0: "y\<in>s" "(x,y)\<in>A"
         unfolding set_rel_def by auto
       from Cons.prems(2) have 
         X1: "\<forall>a\<in>set l. \<exists>b\<in>s. (a,b)\<in>A" and
         X2: "\<forall>b\<in>s. \<exists>a\<in>insert x (set l). (a,b)\<in>A"
         unfolding set_rel_def by auto
       show ?thesis proof (cases "\<exists>a\<in>set l. (a,y)\<in>A")
         case True 
         show ?thesis
           apply (rule that[of y s])
           subgoal using X0 by auto
           subgoal by fact
           subgoal 
             apply (rule set_relI)    
             subgoal using X1 by blast  
             subgoal by (metis IS_RIGHT_UNIQUED SV True X0(2) X2 insert_iff)  
             done
           done
       next
         case False
         show ?thesis
           apply (rule that[of y "s-{y}"])
           subgoal using X0 by auto
           subgoal by fact
           subgoal 
             apply (rule set_relI)    
             subgoal using False X1 by fastforce  
             subgoal using IS_RIGHT_UNIQUED SV X0(2) X2 by fastforce
             done
           done
       qed
     qed    
     moreover from Cons.IH[OF _ \<open>(set l,s')\<in>\<langle>A\<rangle>set_rel\<close>] obtain m where "s'=set m" "(l,m)\<in>\<langle>A\<rangle>list_rel" .
     ultimately show thesis
       apply -
       apply (rule Cons.prems(1)[of "y#m"])
       by auto
   qed      
     
   lemma param_it_to_sorted_list[param]: "\<lbrakk>IS_LEFT_UNIQUE A; IS_RIGHT_UNIQUE A\<rbrakk> \<Longrightarrow> (it_to_sorted_list, it_to_sorted_list) \<in> (A \<rightarrow> A \<rightarrow> bool_rel) \<rightarrow> \<langle>A\<rangle>set_rel \<rightarrow> \<langle>\<langle>A\<rangle>list_rel\<rangle>nres_rel"
     unfolding it_to_sorted_list_def[abs_def]
     apply (auto simp: it_to_sorted_list_def pw_nres_rel_iff refine_pw_simps)
     apply (rule obtain_list_from_setrel; assumption?; clarsimp)
     apply (intro exI conjI; assumption?)
     using param_distinct[param_fo] apply blast
     apply simp
     using param_sorted_wrt[param_fo] apply blast
     done
 
 
 
   locale bind_set_iterate = imp_set_iterate + bind_set +
     assumes is_set_finite: "h \<Turnstile> is_set S x \<Longrightarrow> finite S"
   begin
     context begin
       private lemma is_imp_set_iterate: "imp_set_iterate is_set is_it it_init it_has_next it_next" by unfold_locales
       
       private lemma is_imp_list_empty: "imp_list_empty (list_assn id_assn) (return [])"
         apply unfold_locales
         apply solve_constraint
         apply sep_auto
         done
         
       private lemma is_imp_list_prepend: "imp_list_prepend (list_assn id_assn) (return oo List.Cons)"  
         apply unfold_locales
         apply solve_constraint
         apply (sep_auto simp: pure_def)
         done
 
       definition "to_list \<equiv> to_list_ga it_init it_has_next it_next (return []) (return oo List.Cons)"
       private lemmas tl_rl = to_list_ga_rule[OF is_imp_set_iterate is_imp_list_empty is_imp_list_prepend, folded to_list_def]
 
       private lemma to_list_sorted1: "(to_list,PR_CONST (it_to_sorted_list (\<lambda>_ _. True))) \<in> is_set\<^sup>k \<rightarrow>\<^sub>a list_assn id_assn"
         unfolding PR_CONST_def
         apply (intro hfrefI)
         apply (rule hn_refine_preI)
         apply (rule hn_refineI)
         unfolding it_to_sorted_list_def
         apply (sep_auto intro: hfrefI hn_refineI intro: is_set_finite heap: tl_rl)
         done
 
       private lemma to_list_sorted2: "\<lbrakk>
         CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A; 
         CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> \<Longrightarrow> 
         (PR_CONST (it_to_sorted_list (\<lambda>_ _. True)), PR_CONST (it_to_sorted_list (\<lambda>_ _. True))) \<in> \<langle>the_pure A\<rangle>set_rel \<rightarrow> \<langle>\<langle>the_pure A\<rangle>list_rel\<rangle>nres_rel"  
         unfolding PR_CONST_def CONSTRAINT_def IS_PURE_def 
         by clarify parametricity
           
       lemmas to_list_hnr = to_list_sorted1[FCOMP to_list_sorted2, folded assn_def]  
       lemmas to_list_is_to_sorted_list = IS_TO_SORTED_LISTI[OF to_list_hnr]
       lemma to_list_gen[sepref_gen_algo_rules]: "\<lbrakk>CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A; CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> 
         \<Longrightarrow> GEN_ALGO to_list (IS_TO_SORTED_LIST (\<lambda>_ _. True) (bind_set.assn is_set A) A)"
         by (simp add: GEN_ALGO_def to_list_is_to_sorted_list)
 
     end  
   end
 
   subsubsection \<open>List\<close>
   locale bind_list = imp_list is_list for is_list :: "('ai list) \<Rightarrow> 'm \<Rightarrow> assn" +
     fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn"
   begin
     (*abbreviation "Ap \<equiv> the_pure A"*)
     definition "assn \<equiv> hr_comp is_list (\<langle>the_pure A\<rangle>list_rel)"
     lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "assn"]
 
   end  
 
 
   locale bind_list_empty = imp_list_empty + bind_list
   begin
     lemma hnr_aux: "(uncurry0 empty,uncurry0 (RETURN op_list_empty))\<in>(pure unit_rel)\<^sup>k \<rightarrow>\<^sub>a is_list"
       apply rule apply rule apply (sep_auto simp: pure_def) done
 
     lemmas hnr 
       = hnr_aux[FCOMP op_list_empty.fref[of "the_pure A"], folded assn_def]
 
     lemmas hnr_mop = hnr[FCOMP mk_mop_rl0_np[OF mop_list_empty_alt]]
   end
 
   locale bind_list_is_empty = imp_list_is_empty + bind_list
   begin
     lemma hnr_aux: "(is_empty,RETURN o op_list_is_empty)\<in>(is_list)\<^sup>k \<rightarrow>\<^sub>a pure bool_rel"
       apply rule apply rule apply (sep_auto simp: pure_def) done
 
     lemmas hnr[sepref_fr_rules] 
       = hnr_aux[FCOMP op_list_is_empty.fref, of "the_pure A", folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl1_np[OF mop_list_is_empty_alt]]
   end
 
   locale bind_list_append = imp_list_append + bind_list
   begin
     lemma hnr_aux: "(uncurry (swap_args2 append),uncurry (RETURN oo op_list_append))
       \<in>(is_list)\<^sup>d *\<^sub>a (pure Id)\<^sup>k \<rightarrow>\<^sub>a is_list" by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] 
       = hnr_aux[FCOMP op_list_append.fref,of A, folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl2_np[OF mop_list_append_alt]]
   end
 
   locale bind_list_prepend = imp_list_prepend + bind_list
   begin
     lemma hnr_aux: "(uncurry prepend,uncurry (RETURN oo op_list_prepend))
       \<in>(pure Id)\<^sup>k *\<^sub>a (is_list)\<^sup>d \<rightarrow>\<^sub>a is_list" by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] 
       = hnr_aux[FCOMP op_list_prepend.fref,of A, folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl2_np[OF mop_list_prepend_alt]]
   end
 
   locale bind_list_hd = imp_list_head + bind_list
   begin
     lemma hnr_aux: "(head,RETURN o op_list_hd)
       \<in>[\<lambda>l. l\<noteq>[]]\<^sub>a (is_list)\<^sup>d \<rightarrow> pure Id"  by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] = hnr_aux[FCOMP op_list_hd.fref,of A, folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl1[OF mop_list_hd_alt]]
   end
 
   locale bind_list_tl = imp_list_tail + bind_list
   begin
     lemma hnr_aux: "(tail,RETURN o op_list_tl)
       \<in>[\<lambda>l. l\<noteq>[]]\<^sub>a (is_list)\<^sup>d \<rightarrow> is_list"
        by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] = hnr_aux[FCOMP op_list_tl.fref,of "the_pure A", folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl1[OF mop_list_tl_alt]]
   end
 
   locale bind_list_rotate1 = imp_list_rotate + bind_list
   begin
     lemma hnr_aux: "(rotate,RETURN o op_list_rotate1)
       \<in>(is_list)\<^sup>d \<rightarrow>\<^sub>a is_list"
        by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] = hnr_aux[FCOMP op_list_rotate1.fref,of "the_pure A", folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl1_np[OF mop_list_rotate1_alt]]
   end
 
   locale bind_list_rev = imp_list_reverse + bind_list
   begin
     lemma hnr_aux: "(reverse,RETURN o op_list_rev)
       \<in>(is_list)\<^sup>d \<rightarrow>\<^sub>a is_list"
        by solve_sepl_binding
 
     lemmas hnr[sepref_fr_rules] = hnr_aux[FCOMP op_list_rev.fref,of "the_pure A", folded assn_def]
     lemmas hnr_mop[sepref_fr_rules] = hnr[FCOMP mk_mop_rl1_np[OF mop_list_rev_alt]]
   end
 
   subsection \<open>Array Map (iam)\<close>
   definition "op_iam_empty \<equiv> IICF_Map.op_map_empty"
   interpretation iam: bind_map_empty is_iam iam_new
     by unfold_locales
 
   interpretation iam: map_custom_empty op_iam_empty
     by unfold_locales (simp add: op_iam_empty_def)
   lemmas [sepref_fr_rules] = iam.empty_hnr[folded op_iam_empty_def]
 
 
   definition [simp]: "op_iam_empty_sz (N::nat) \<equiv> IICF_Map.op_map_empty"
   lemma [def_pat_rules]: "op_iam_empty_sz$N \<equiv> UNPROTECT (op_iam_empty_sz N)"
     by simp
 
   interpretation iam_sz: map_custom_empty "PR_CONST (op_iam_empty_sz N)"
     apply unfold_locales 
     apply (simp)
     done
   lemma [sepref_fr_rules]: "(uncurry0 iam_new, uncurry0 (RETURN (PR_CONST (op_iam_empty_sz N)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a iam.assn K V"  
     using iam.empty_hnr[of K V] by simp
 
 
   interpretation iam: bind_map_update is_iam Array_Map_Impl.iam_update
     by unfold_locales
 
   interpretation iam: bind_map_delete is_iam Array_Map_Impl.iam_delete
     by unfold_locales
 
   interpretation iam: bind_map_lookup is_iam Array_Map_Impl.iam_lookup
     by unfold_locales
 
   setup Locale_Code.open_block
   interpretation iam: gen_contains_key_by_lookup is_iam Array_Map_Impl.iam_lookup
     by unfold_locales
   setup Locale_Code.close_block
 
   interpretation iam: bind_map_contains_key is_iam iam.contains_key
     by unfold_locales
 
   subsection \<open>Array Set (ias)\<close>
 
   definition [simp]: "op_ias_empty \<equiv> op_set_empty"
   interpretation ias: bind_set_empty is_ias ias_new for A
     by unfold_locales
 
   interpretation ias: set_custom_empty ias_new op_ias_empty
     by unfold_locales simp
   lemmas [sepref_fr_rules] = ias.hnr_op_empty[folded op_ias_empty_def]
 
 
   definition [simp]: "op_ias_empty_sz (N::nat) \<equiv> op_set_empty"
   lemma [def_pat_rules]: "op_ias_empty_sz$N \<equiv> UNPROTECT (op_ias_empty_sz N)"
     by simp
 
   interpretation ias_sz: bind_set_empty is_ias "ias_new_sz N" for N A
     by unfold_locales
 
   interpretation ias_sz: set_custom_empty "ias_new_sz N" "PR_CONST (op_ias_empty_sz N)" for A
     by unfold_locales simp
   lemma [sepref_fr_rules]: 
     "(uncurry0 (ias_new_sz N), uncurry0 (RETURN (PR_CONST (op_ias_empty_sz N)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a ias.assn A"
     using ias_sz.hnr_op_empty[of N A] by simp
 
   interpretation ias: bind_set_member is_ias Array_Set_Impl.ias_memb for A
     by unfold_locales
 
   interpretation ias: bind_set_insert is_ias Array_Set_Impl.ias_ins for A
     by unfold_locales
 
   interpretation ias: bind_set_delete is_ias Array_Set_Impl.ias_delete for A
     by unfold_locales
 
   setup Locale_Code.open_block  
   interpretation ias: bind_set_iterate is_ias ias_is_it ias_it_init ias_it_has_next ias_it_next for A
     by unfold_locales auto
   setup Locale_Code.close_block  
 
   subsection \<open>Hash Map (hm)\<close>
   interpretation hm: bind_map_empty is_hashmap hm_new
     by unfold_locales
 
   definition "op_hm_empty \<equiv> IICF_Map.op_map_empty"  
   interpretation hm: map_custom_empty op_hm_empty
     by unfold_locales (simp add: op_hm_empty_def)
   lemmas [sepref_fr_rules] = hm.empty_hnr[folded op_hm_empty_def]
 
   interpretation hm: bind_map_is_empty is_hashmap Hash_Map.hm_isEmpty
     by unfold_locales
 
   interpretation hm: bind_map_update is_hashmap Hash_Map.hm_update
     by unfold_locales
 
   interpretation hm: bind_map_delete is_hashmap Hash_Map.hm_delete
     by unfold_locales
 
   interpretation hm: bind_map_lookup is_hashmap Hash_Map.hm_lookup
     by unfold_locales
 
   setup Locale_Code.open_block
   interpretation hm: gen_contains_key_by_lookup is_hashmap Hash_Map.hm_lookup
     by unfold_locales
   setup Locale_Code.close_block
 
   interpretation hm: bind_map_contains_key is_hashmap hm.contains_key
     by unfold_locales
 
 
   subsection \<open>Hash Set (hs)\<close>
   interpretation hs: bind_set_empty is_hashset hs_new for A
     by unfold_locales
 
   definition "op_hs_empty \<equiv> IICF_Set.op_set_empty"  
   interpretation hs: set_custom_empty hs_new op_hs_empty for A
     by unfold_locales (simp add: op_hs_empty_def)
   lemmas [sepref_fr_rules] = hs.hnr_op_empty[folded op_hs_empty_def]
 
   interpretation hs: bind_set_is_empty is_hashset Hash_Set_Impl.hs_isEmpty for A
     by unfold_locales
 
   interpretation hs: bind_set_member is_hashset Hash_Set_Impl.hs_memb for A
     by unfold_locales
 
   interpretation hs: bind_set_insert is_hashset Hash_Set_Impl.hs_ins for A
     by unfold_locales
 
   interpretation hs: bind_set_delete is_hashset Hash_Set_Impl.hs_delete for A
     by unfold_locales
 
   setup Locale_Code.open_block  
   interpretation hs: bind_set_iterate is_hashset hs_is_it hs_it_init hs_it_has_next hs_it_next for A
     by unfold_locales simp
   setup Locale_Code.close_block  
 
 
   subsection \<open>Open Singly Linked List (osll)\<close>  
   interpretation osll: bind_list os_list for A by unfold_locales
   interpretation osll_empty: bind_list_empty os_list os_empty for A
     by unfold_locales
 
   definition "osll_empty \<equiv> op_list_empty"
   interpretation osll: list_custom_empty "osll.assn A" os_empty osll_empty
     apply unfold_locales
     apply (rule osll_empty.hnr)
     by (simp add: osll_empty_def)
 
   interpretation osll_is_empty: bind_list_is_empty os_list os_is_empty for A
     by unfold_locales
 
   interpretation osll_prepend: bind_list_prepend os_list os_prepend for A
     by unfold_locales
   
   interpretation osll_hd: bind_list_hd os_list os_head for A
     by unfold_locales
 
   interpretation osll_tl: bind_list_tl os_list os_tl for A
     by unfold_locales
     
   interpretation osll_rev: bind_list_rev os_list os_reverse for A
     by unfold_locales
 
 
   subsection \<open>Circular Singly Linked List (csll)\<close>  
 
 
   (* TODO: In-place reversal of circular list! *)  
 
   interpretation csll: bind_list cs_list for A by unfold_locales
 
   interpretation csll_empty: bind_list_empty cs_list cs_empty for A 
     by unfold_locales
 
   definition "csll_empty \<equiv> op_list_empty"
   interpretation csll: list_custom_empty "csll.assn A" cs_empty csll_empty
     apply unfold_locales
     apply (rule csll_empty.hnr)
     by (simp add: csll_empty_def)
 
   interpretation csll_is_empty: bind_list_is_empty cs_list cs_is_empty for A 
     by unfold_locales
 
   interpretation csll_prepend: bind_list_prepend cs_list cs_prepend for A 
     by unfold_locales
     
   interpretation csll_append: bind_list_append cs_list cs_append for A 
     by unfold_locales
 
   interpretation csll_hd: bind_list_hd cs_list cs_head for A 
     by unfold_locales
     
   interpretation csll_tl: bind_list_tl cs_list cs_tail for A 
     by unfold_locales
 
   interpretation csll_rotate1: bind_list_rotate1 cs_list cs_rotate for A 
     by unfold_locales
 
   schematic_goal "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
     x \<leftarrow> mop_list_empty;
     RETURN (1 \<in> dom [1::nat \<mapsto> True, 2\<mapsto>False], {1,2::nat}, 1#(2::nat)#x)
   })"  
     apply (subst iam_sz.fold_custom_empty[where N=10])
     apply (subst hs.fold_custom_empty)
     apply (subst osll.fold_custom_empty)
     by sepref
 
 end
diff --git a/thys/Smith_Normal_Form/Cauchy_Binet.thy b/thys/Smith_Normal_Form/Cauchy_Binet.thy
--- a/thys/Smith_Normal_Form/Cauchy_Binet.thy
+++ b/thys/Smith_Normal_Form/Cauchy_Binet.thy
@@ -1,1425 +1,1425 @@
 (*
     Author:      Jose Divasón
     Email:       jose.divason@unirioja.es
 *)
 
 section \<open>The Cauchy--Binet formula\<close>
 
 theory Cauchy_Binet
   imports
   Diagonal_To_Smith
   SNF_Missing_Lemmas
 begin
 
 subsection \<open>Previous missing results about @{text "pick"} and @{text "insert"}\<close>
 
 lemma pick_insert:
   assumes a_notin_I: "a \<notin> I" and i2: "i < card I"
     and a_def: "pick (insert a I) a' = a" (*Alternative: index (insort a (sorted_list_of_set I)) a = a'*)
     and ia': "i < a'" (*Case 1*)
     and a'_card: "a' < card I + 1"
   shows "pick (insert a I) i = pick I i"
 proof -
   have finI: "finite I"
     using i2
     using card.infinite by force
   have "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
   proof (rule sorted_list_of_set_eq_pick[symmetric])
     have "finite (insert a I)"
       using card.infinite i2 by force
     thus "i < length (sorted_list_of_set (insert a I))"
       by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
           i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
   qed
   also have "... = insort a (sorted_list_of_set I) ! i"
     using sorted_list_of_set.insert
     by (metis a_notin_I card.infinite i2 not_less0)
   also have "... = (sorted_list_of_set I) ! i"
   proof (rule insort_nth[OF])
      show "sorted (sorted_list_of_set I)" by auto
      show "a \<notin> set (sorted_list_of_set I)" using a_notin_I
        by (metis card.infinite i2 not_less_zero set_sorted_list_of_set)
      have "index (sorted_list_of_set (insert a I)) a = a'"
        using pick_index a_def
        using a'_card a_notin_I finI by auto
      hence "index (insort a (sorted_list_of_set I)) a = a'"
        by (simp add: a_notin_I finI)
      thus "i < index (insort a (sorted_list_of_set I)) a" using ia' by auto
      show "sorted_list_of_set I \<noteq> []" using finI i2 by fastforce
    qed
   also have "... = pick I i"
   proof (rule sorted_list_of_set_eq_pick)
     have "finite I" using card.infinite i2 by fastforce
     thus "i < length (sorted_list_of_set I)"
       by (metis distinct_card distinct_sorted_list_of_set i2 set_sorted_list_of_set)
   qed
   finally show ?thesis .
 qed
 
 
 lemma pick_insert2:
   assumes a_notin_I: "a \<notin> I" and i2: "i < card I"
     and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'*)
     and ia': "i \<ge> a'" (*Case 2*)
     and a'_card: "a' < card I + 1"
   shows "pick (insert a I) i < pick I i"
 proof (cases "i = 0")
   case True
   then show ?thesis
     by (auto, metis (mono_tags, lifting) DL_Missing_Sublist.pick.simps(1) Least_le a_def a_notin_I
         dual_order.order_iff_strict i2 ia' insertCI le_zero_eq not_less_Least pick_in_set_le)
 next
   case False
   hence i0: "i = Suc (i - 1)" using a'_card ia' by auto
   have finI: "finite I"
     using i2 card.infinite by force
   have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
     using pick_index
     using a'_card a_def a_notin_I finI by auto
   hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
     by (simp add: a_notin_I finI)
   have i1_length: "i - 1 < length (sorted_list_of_set I)" using i2
     by (metis distinct_card distinct_sorted_list_of_set finI
         less_imp_diff_less set_sorted_list_of_set)
   have 1: "pick (insert a I) i = sorted_list_of_set (insert a I) ! i"
   proof (rule sorted_list_of_set_eq_pick[symmetric])
     have "finite (insert a I)"
       using card.infinite i2 by force
     thus "i < length (sorted_list_of_set (insert a I))"
       by (metis a_notin_I card_insert_disjoint distinct_card finite_insert
           i2 less_Suc_eq sorted_list_of_set(1) sorted_list_of_set(3))
   qed
   also have 2: "... = insort a (sorted_list_of_set I) ! i"
     using sorted_list_of_set.insert
     by (metis a_notin_I card.infinite i2 not_less0)
   also have "... = insort a (sorted_list_of_set I) ! Suc (i-1)" using i0 by auto
   also have "... < pick I i"
   proof (cases "i = a'")
     case True
     have "(sorted_list_of_set I) ! i > a"
       by (smt "1" Suc_less_eq True a_def a_notin_I distinct_card distinct_sorted_list_of_set finI i2
           ia' index_a' insort_nth2 length_insort lessI list.size(3) nat_less_le not_less_zero
           pick_in_set_le set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set.insert
-          sorted_list_of_set_eq_pick sorted_sorted_wrt sorted_wrt_nth_less)
+          sorted_list_of_set_eq_pick sorted_wrt_nth_less)
     moreover have "a = insort a (sorted_list_of_set I) ! i" using True 1 2 a_def by auto
     ultimately show ?thesis using 1 2
       by (metis distinct_card finI i0 i2 set_sorted_list_of_set
           sorted_list_of_set(3) sorted_list_of_set_eq_pick)
   next
     case False
     have "insort a (sorted_list_of_set I) ! Suc (i-1) = (sorted_list_of_set I) ! (i-1)"
       by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
     also have "... = pick I (i-1)"
       by (rule sorted_list_of_set_eq_pick[OF i1_length])
     also have "... < pick I i" using i0 i2 pick_mono_le by auto
     finally show ?thesis .
   qed
   finally show ?thesis .
 qed
 
 lemma pick_insert3:
   assumes a_notin_I: "a \<notin> I" and i2: "i < card I"
     and a_def: "pick (insert a I) a' = a" (*Alternative: index (sorted_list_of_set (insert a I)) a = a'.*)
     and ia': "i \<ge> a'" (*Case 2*)
     and a'_card: "a' < card I + 1"
   shows "pick (insert a I) (Suc i) = pick I i"
 proof (cases "i = 0")
   case True
   have a_LEAST: "a < (LEAST aa. aa\<in>I)"
     using True a_def a_notin_I i2 ia' pick_insert2 by fastforce
   have Least_rw: "(LEAST aa. aa = a \<or> aa \<in> I) = a"
     by (rule Least_equality, insert a_notin_I, auto,
         metis a_LEAST le_less_trans nat_le_linear not_less_Least)
   let ?P = "\<lambda>aa. (aa = a \<or> aa \<in> I) \<and> (LEAST aa. aa = a \<or> aa \<in> I) < aa"
   let ?Q = "\<lambda>aa. aa \<in> I"
   have "?P = ?Q" unfolding Least_rw fun_eq_iff
     by (auto, metis a_LEAST le_less_trans not_le not_less_Least)
   thus ?thesis using True by auto
 next
   case False
   have finI: "finite I"
     using i2 card.infinite by force
   have index_a'1: "index (sorted_list_of_set (insert a I)) a = a'"
     using pick_index
     using a'_card a_def a_notin_I finI by auto
   hence index_a': "index (insort a (sorted_list_of_set I)) a = a'"
     by (simp add: a_notin_I finI)
   have i1_length: "i < length (sorted_list_of_set I)" using i2
     by (metis distinct_card distinct_sorted_list_of_set finI set_sorted_list_of_set)
   have 1: "pick (insert a I) (Suc i) = sorted_list_of_set (insert a I) ! (Suc i)"
   proof (rule sorted_list_of_set_eq_pick[symmetric])
     have "finite (insert a I)"
       using card.infinite i2 by force
     thus "Suc i < length (sorted_list_of_set (insert a I))"
       by (metis Suc_mono a_notin_I card_insert_disjoint distinct_card distinct_sorted_list_of_set
           finI i2 set_sorted_list_of_set)
   qed
   also have 2: "... = insort a (sorted_list_of_set I) ! Suc i"
     using sorted_list_of_set.insert
     by (metis a_notin_I card.infinite i2 not_less0)
   also have "... = pick I i"
   proof (cases "i = a'")
     case True
     show ?thesis
       by (metis True a_notin_I finI i1_length index_a' insort_nth2 le_refl list.size(3) not_less0
           set_sorted_list_of_set sorted_list_of_set(2) sorted_list_of_set_eq_pick)
   next
     case False
     have "insort a (sorted_list_of_set I) ! Suc i = (sorted_list_of_set I) ! i"
       by (rule insort_nth2, insert i1_length False ia' index_a', auto simp add: a_notin_I finI)
     also have "... = pick I i"
       by (rule sorted_list_of_set_eq_pick[OF i1_length])
     finally show ?thesis .
   qed
   finally show ?thesis .
 qed
 
 
 lemma pick_insert_index:
   assumes Ik: "card I = k"
   and a_notin_I: "a \<notin> I"
   and ik: "i < k"
   and a_def: "pick (insert a I) a' = a"
   and a'k: "a' < card I + 1"
 shows "pick (insert a I) (insert_index a' i) = pick I i"
 proof (cases "i<a'")
   case True
   have "pick (insert a I) i = pick I i"
     by (rule pick_insert[OF a_notin_I _ a_def _ a'k], auto simp add: Ik ik True)
   thus ?thesis using True unfolding insert_index_def by auto
 next
   case False note i_ge_a' = False
   have fin_aI: "finite (insert a I)"
     using Ik finite_insert ik by fastforce
   let ?P = "\<lambda>aa. (aa = a \<or> aa \<in> I) \<and> pick (insert a I) i < aa"
   let ?Q = "\<lambda>aa. aa \<in> I \<and> pick (insert a I) i < aa"
   have "?P = ?Q" using a_notin_I unfolding fun_eq_iff
     by (auto, metis False Ik a_def card.infinite card_insert_disjoint ik less_SucI
         linorder_neqE_nat not_less_zero order.asym pick_mono_le)
   hence "Least ?P = Least ?Q" by simp
   also have "... = pick I i"
   proof (rule Least_equality, rule conjI)
     show "pick I i \<in> I"
       by (simp add: Ik ik pick_in_set_le)
     show "pick (insert a I) i < pick I i"
       by (rule pick_insert2[OF a_notin_I _ a_def _ a'k], insert False, auto simp add: Ik ik)
     fix y assume y: "y \<in> I \<and> pick (insert a I) i < y"
     let ?xs = "sorted_list_of_set (insert a I)"
     have "y \<in> set ?xs" using y by (metis fin_aI insertI2 set_sorted_list_of_set y)
     from this obtain j where xs_j_y: "?xs ! j = y" and j: "j < length ?xs"
       using in_set_conv_nth by metis
     have ij: "i<j"
       by (metis (no_types, lifting) Ik a_notin_I card.infinite card_insert_disjoint ik j less_SucI
           linorder_neqE_nat not_less_zero order.asym pick_mono_le sorted_list_of_set_eq_pick xs_j_y y)
     have "pick I i = pick (insert a I) (Suc i)"
       by (rule pick_insert3[symmetric, OF a_notin_I _ a_def _ a'k], insert False Ik ik, auto)
     also have "... \<le> pick (insert a I) j"
       by (metis Ik Suc_lessI card.infinite distinct_card distinct_sorted_list_of_set eq_iff
           finite_insert ij ik j less_imp_le_nat not_less_zero pick_mono_le set_sorted_list_of_set)
     also have "... = ?xs ! j" by (rule sorted_list_of_set_eq_pick[symmetric, OF j])
     also have "... = y" by (rule xs_j_y)
     finally show "pick I i \<le> y" .
   qed
   finally show ?thesis unfolding insert_index_def using False by auto
 qed
 
 
 subsection\<open>Start of the proof\<close>
 
 definition "strict_from_inj n f = (\<lambda>i. if i\<in>{0..<n} then (sorted_list_of_set (f`{0..<n})) ! i else i)"
 
 lemma strict_strict_from_inj:
   fixes f::"nat \<Rightarrow> nat"
   assumes "inj_on f {0..<n}" shows "strict_mono_on (strict_from_inj n f) {0..<n}"
 proof -
   let ?I="f`{0..<n}"
   have "strict_from_inj n f x < strict_from_inj n f y"
     if xy: "x < y" and x: "x \<in> {0..<n}" and y: "y \<in> {0..<n}" for x y
   proof -
     let ?xs = "(sorted_list_of_set ?I)"
     have sorted_xs: "sorted ?xs" by (rule sorted_sorted_list_of_set)
     have "strict_from_inj n f x = (sorted_list_of_set ?I) ! x"
       unfolding strict_from_inj_def using x by auto
     also have "... < (sorted_list_of_set ?I) ! y"
     proof (rule sorted_nth_strict_mono; clarsimp?)
       show "y < card (f ` {0..<n})"
         by (metis assms atLeastLessThan_iff card_atLeastLessThan card_image diff_zero y)
     qed (simp add: xy)
     also have "... = strict_from_inj n f y" using y unfolding strict_from_inj_def by simp
     finally show ?thesis .
   qed
   thus ?thesis unfolding strict_mono_on_def by simp
 qed
 
 
 
 
 lemma strict_from_inj_image':
   assumes f: "inj_on f {0..<n}"
   shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
 proof (auto)
   let ?I = "f ` {0..<n}"
   fix xa assume xa: "xa < n"
   have inj_on: "inj_on f {0..<n}" using f  by auto
   have length_I: "length (sorted_list_of_set ?I) = n"
     by (metis card_atLeastLessThan card_image diff_zero distinct_card distinct_sorted_list_of_set
         finite_atLeastLessThan finite_imageI inj_on sorted_list_of_set(1))
 
   have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
     using xa unfolding strict_from_inj_def by auto
   also have "... = pick ?I xa"
     by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
   also have "... \<in> f ` {0..<n}" by (rule pick_in_set_le, simp add: card_image inj_on xa)
   finally show "strict_from_inj n f xa \<in> f ` {0..<n}" .
   obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
     by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
         in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
   thus "f xa \<in> strict_from_inj n f ` {0..<n}"
     by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
 qed
 
 
 
 definition "Z (n::nat) (m::nat) = {(f,\<pi>)|f \<pi>. f \<in> {0..<n} \<rightarrow> {0..<m}
   \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> \<pi> permutes {0..<n}}"
 
 lemma Z_alt_def: "Z n m = {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} \<times> {\<pi>. \<pi> permutes {0..<n}}"
   unfolding Z_def by auto
 
 lemma det_mul_finsum_alt:
   assumes A: "A \<in> carrier_mat n m"
     and B: "B \<in> carrier_mat m n"
   shows "det (A*B) = det (mat\<^sub>r n n (\<lambda>i. finsum_vec TYPE('a::comm_ring_1) n
   (\<lambda>k. B $$ (k, i) \<cdot>\<^sub>v Matrix.col A k) {0..<m}))"
 proof -
   have AT: "A\<^sup>T \<in> carrier_mat m n" using A by auto
   have BT: "B\<^sup>T \<in> carrier_mat n m" using B by auto
   let ?f = "(\<lambda>i. finsum_vec TYPE('a) n (\<lambda>k. B\<^sup>T $$ (i, k) \<cdot>\<^sub>v Matrix.row A\<^sup>T k) {0..<m})"
   let ?g = "(\<lambda>i. finsum_vec TYPE('a) n (\<lambda>k. B $$ (k, i) \<cdot>\<^sub>v Matrix.col A k) {0..<m})"
   let ?lhs = "mat\<^sub>r n n ?f"
   let ?rhs = "mat\<^sub>r n n ?g"
   have lhs_rhs: "?lhs = ?rhs"
   proof (rule eq_matI)
     show "dim_row ?lhs = dim_row ?rhs" by auto
     show "dim_col ?lhs = dim_col ?rhs" by auto
     fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
     have j_n: "j<n" using j by auto
     have "?lhs $$ (i, j) = ?f i $v j" by (rule index_mat, insert i j, auto)
     also have "... = (\<Sum>k\<in>{0..<m}. (B\<^sup>T $$ (i, k) \<cdot>\<^sub>v row A\<^sup>T k) $ j)"
       by (rule index_finsum_vec[OF _ j_n], auto simp add: A)
     also have "... = (\<Sum>k\<in>{0..<m}. (B $$ (k, i) \<cdot>\<^sub>v col A k) $ j)"
     proof (rule sum.cong, auto)
       fix x assume x: "x<m"
       have row_rw: "Matrix.row A\<^sup>T x = col A x" by (rule row_transpose, insert A x, auto)
       have B_rw: "B\<^sup>T $$ (i,x) = B $$ (x, i)"
         by (rule index_transpose_mat, insert x i B, auto)
       have "(B\<^sup>T $$ (i, x) \<cdot>\<^sub>v Matrix.row A\<^sup>T x) $v j = B\<^sup>T $$ (i, x) * Matrix.row A\<^sup>T x $v j"
         by (rule index_smult_vec, insert A j_n, auto)
       also have "... = B $$ (x, i) * col A x $v j" unfolding row_rw B_rw by simp
       also have "... = (B $$ (x, i) \<cdot>\<^sub>v col A x) $v j"
         by (rule index_smult_vec[symmetric], insert A j_n, auto)
       finally show " (B\<^sup>T $$ (i, x) \<cdot>\<^sub>v Matrix.row A\<^sup>T x) $v j = (B $$ (x, i) \<cdot>\<^sub>v col A x) $v j" .
     qed
     also have "... = ?g i $v j"
       by (rule index_finsum_vec[symmetric, OF _ j_n], auto simp add: A)
     also have "... = ?rhs $$ (i, j)" by (rule index_mat[symmetric], insert i j, auto)
     finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
   qed
   have "det (A*B) = det (B\<^sup>T*A\<^sup>T)"
     using det_transpose
     by (metis A B Matrix.transpose_mult mult_carrier_mat)
   also have "... =  det (mat\<^sub>r n n (\<lambda>i. finsum_vec TYPE('a) n (\<lambda>k. B\<^sup>T $$ (i, k) \<cdot>\<^sub>v Matrix.row A\<^sup>T k) {0..<m}))"
     using mat_mul_finsum_alt[OF BT AT] by auto
   also have "... = det (mat\<^sub>r n n (\<lambda>i. finsum_vec TYPE('a) n (\<lambda>k. B $$ (k, i) \<cdot>\<^sub>v Matrix.col A k) {0..<m}))"
     by (rule arg_cong[of _ _ det], rule lhs_rhs)
   finally show ?thesis .
 qed
 
 
 lemma det_cols_mul:
   assumes A: "A \<in> carrier_mat n m"
     and B: "B \<in> carrier_mat m n"
   shows "det (A*B) = (\<Sum>f | (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i).
        (\<Prod>i = 0..<n. B $$ (f i, i)) * Determinant.det (mat\<^sub>r n n (\<lambda>i. col A (f i))))"
 proof -
   let ?V="{0..<n}"
   let ?U = "{0..<m}"
   let ?F = " {f. (\<forall>i\<in> {0..<n}. f i \<in> ?U) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   let ?g = "\<lambda>f. det (mat\<^sub>r n n (\<lambda> i. B $$ (f i, i) \<cdot>\<^sub>v col A (f i)))"
   have fm: "finite {0..<m}" by auto
   have fn: "finite {0..<n}" by auto
   have det_rw: "det (mat\<^sub>r n n (\<lambda>i. B $$ (f i, i) \<cdot>\<^sub>v col A (f i))) =
     (prod (\<lambda>i. B $$ (f i, i)) {0..<n}) * det (mat\<^sub>r n n (\<lambda>i. col A (f i)))"
     if  f: "(\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)" for f
     by (rule det_rows_mul, insert A col_dim, auto)
   have "det (A*B) = det (mat\<^sub>r n n (\<lambda>i. finsum_vec TYPE('a::comm_ring_1) n (\<lambda>k. B $$ (k, i) \<cdot>\<^sub>v Matrix.col A k) ?U))"
     by (rule det_mul_finsum_alt[OF A B])
   also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
   also have "... = (\<Sum>f\<in>?F. prod (\<lambda>i. B $$ (f i, i)) {0..<n} * det (mat\<^sub>r n n (\<lambda>i. col A (f i))))"
     using det_rw by auto
   finally show ?thesis .
 qed
 
 lemma det_cols_mul':
   assumes A: "A \<in> carrier_mat n m"
     and B: "B \<in> carrier_mat m n"
   shows "det (A*B) = (\<Sum>f | (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i).
        (\<Prod>i = 0..<n. A $$ (i, f i)) * det (mat\<^sub>r n n (\<lambda>i. row B (f i))))"
 proof -
   let ?F="{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have t: "A * B = (B\<^sup>T*A\<^sup>T)\<^sup>T" using transpose_mult[OF A B] transpose_transpose by metis
   have "det (B\<^sup>T*A\<^sup>T) = (\<Sum>f\<in>?F. (\<Prod>i = 0..<n. A\<^sup>T $$ (f i, i)) * det (mat\<^sub>r n n (\<lambda>i. col B\<^sup>T (f i))))"
     by (rule det_cols_mul, auto simp add: A B)
   also have "... = (\<Sum>f \<in>?F. (\<Prod>i = 0..<n. A $$ (i, f i)) * det (mat\<^sub>r n n (\<lambda>i. row B (f i))))"
   proof (rule sum.cong, rule refl)
     fix f assume f: "f \<in> ?F"
     have "(\<Prod>i = 0..<n. A\<^sup>T $$ (f i, i)) = (\<Prod>i = 0..<n. A $$ (i, f i))"
     proof (rule prod.cong, rule refl)
       fix x assume x: "x \<in> {0..<n}"
       show "A\<^sup>T $$ (f x, x) = A $$ (x, f x)"
         by (rule index_transpose_mat(1), insert f A x, auto)
     qed
     moreover have "det (mat\<^sub>r n n (\<lambda>i. col B\<^sup>T (f i))) = det (mat\<^sub>r n n (\<lambda>i. row B (f i)))"
     proof -
       have row_eq_colT: "row B (f i) $v j = col B\<^sup>T (f i) $v j" if i: "i < n" and j: "j < n" for i j
       proof -
         have fi_m: "f i < m" using f i by auto
         have "col B\<^sup>T (f i) $v j = B\<^sup>T $$(j, f i)" by (rule index_col, insert B fi_m j, auto)
         also have "... = B $$ (f i, j)" using B fi_m j by auto
         also have "... = row B (f i) $v j" by (rule index_row[symmetric], insert B fi_m j, auto)
         finally show ?thesis ..
       qed
       show ?thesis by (rule arg_cong[of _ _ det], rule eq_matI, insert row_eq_colT, auto)
     qed
     ultimately show "(\<Prod>i = 0..<n. A\<^sup>T $$ (f i, i)) * det (mat\<^sub>r n n (\<lambda>i. col B\<^sup>T (f i))) =
          (\<Prod>i = 0..<n. A $$ (i, f i)) * det (mat\<^sub>r n n (\<lambda>i. row B (f i)))" by simp
   qed
   finally show ?thesis
     by (metis (no_types, lifting) A B det_transpose transpose_mult mult_carrier_mat)
 qed
 
 (*We need a more general version of this lemma*)
 lemma
   assumes F: "F= {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   and p: " \<pi> permutes {0..<n}"
   shows " (\<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))) = (\<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f i, i)))"
 proof -
   let ?h = "(\<lambda>f. f \<circ> \<pi>)"
   have inj_on_F: "inj_on ?h F"
   proof (rule inj_onI)
     fix f g assume fop: "f \<circ> \<pi> = g \<circ> \<pi>"
     have "f x = g x" for x
     proof (cases "x \<in> {0..<n}")
       case True
       then show ?thesis
         by (metis fop comp_apply p permutes_def)
     next
       case False
       then show ?thesis
         by (metis fop comp_eq_elim p permutes_def)
     qed
     thus "f = g" by auto
   qed
   have hF: "?h` F = F"
     unfolding image_def
   proof auto
     fix xa assume xa: "xa \<in> F" show "xa \<circ> \<pi> \<in> F"
       unfolding o_def F
       using F PiE p xa
       by (auto, smt F atLeastLessThan_iff mem_Collect_eq p permutes_def xa)
     show "\<exists>x\<in>F. xa = x \<circ> \<pi>"
     proof (rule bexI[of _ "xa \<circ> Hilbert_Choice.inv \<pi>"])
       show "xa = xa \<circ> Hilbert_Choice.inv \<pi> \<circ> \<pi>"
         using p by auto
       show "xa \<circ> Hilbert_Choice.inv \<pi> \<in> F"
         unfolding o_def F
         using F PiE p xa
         by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
     qed
   qed
   have prod_rw: "(\<Prod>i = 0..<n. B $$ (f i, i)) = (\<Prod>i = 0..<n. B $$ (f (\<pi> i), \<pi> i))" if "f\<in>F" for f
   using prod.permute[OF p] by auto
   let ?g = "\<lambda>f. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))"
   have "(\<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f i, i))) = (\<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f (\<pi> i), \<pi> i)))"
     using prod_rw by auto
   also have "... = (\<Sum>f\<in>(?h`F). \<Prod>i = 0..<n. B $$ (f i, \<pi> i))"
     using sum.reindex[OF inj_on_F, of ?g] unfolding hF by auto
   also have "... = (\<Sum>f\<in>F. \<Prod>i = 0..<n. B $$ (f i, \<pi> i))" unfolding hF by auto
   finally show ?thesis ..
 qed
 
 
 lemma detAB_Znm_aux:
   assumes F: "F= {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   shows"(\<Sum>\<pi> | \<pi> permutes {0..<n}. (\<Sum>f\<in>F. prod (\<lambda>i. B $$ (f i, i)) {0..<n}
         * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f i)))))
     = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))
         * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i))))"
 proof -
   have "(\<Sum>\<pi> | \<pi> permutes {0..<n}. (\<Sum>f\<in>F. prod (\<lambda>i. B $$ (f i, i)) {0..<n}
       * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f i))))) =
     (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f i, i) * A $$ (\<pi> i, f i)))"
     by (smt mult.left_commute prod.cong prod.distrib sum.cong)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. signof (Hilbert_Choice.inv \<pi>)
     * (\<Prod>i = 0..<n. B $$ (f i, i) * A $$ (Hilbert_Choice.inv \<pi> i, f i)))"
     by (rule sum_permutations_inverse)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. signof (Hilbert_Choice.inv \<pi>)
     * (\<Prod>i = 0..<n. B $$ (f (\<pi> i), (\<pi> i)) * A $$ (Hilbert_Choice.inv \<pi> (\<pi> i), f (\<pi> i))))"
   proof (rule sum.cong)
     fix x assume x: "x \<in> {\<pi>. \<pi> permutes {0..<n}}"
     let ?inv_x = "Hilbert_Choice.inv x"
     have p: "x permutes {0..<n}" using x by simp
     have prod_rw: "(\<Prod>i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))
         = (\<Prod>i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i)))" if "f \<in> F" for f
       using prod.permute[OF p] by auto
     then show "(\<Sum>f\<in>F. signof ?inv_x * (\<Prod>i = 0..<n. B $$ (f i, i) * A $$ (?inv_x i, f i))) =
          (\<Sum>f\<in>F. signof ?inv_x * (\<Prod>i = 0..<n. B $$ (f (x i), x i) * A $$ (?inv_x (x i), f (x i))))"
       by auto
   qed (simp)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. signof \<pi>
     * (\<Prod>i = 0..<n. B $$ (f (\<pi> i), (\<pi> i)) * A $$ (i, f (\<pi> i))))"
     by (rule sum.cong, auto, rule sum.cong, auto)
         (metis (no_types, lifting) finite_atLeastLessThan signof_inv)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. signof \<pi>
     * (\<Prod>i = 0..<n. B $$ (f i, (\<pi> i)) * A $$ (i, f i)))"
   proof (rule sum.cong)
     fix \<pi> assume p: "\<pi> \<in> {\<pi>. \<pi> permutes {0..<n}}"
     hence p: "\<pi> permutes {0..<n}" by auto
     let ?inv_pi = "(Hilbert_Choice.inv \<pi>)"
     let ?h = "(\<lambda>f. f \<circ> (Hilbert_Choice.inv \<pi>))"
   have inj_on_F: "inj_on ?h F"
   proof (rule inj_onI)
     fix f g assume fop: "f \<circ> ?inv_pi = g \<circ> ?inv_pi"
     have "f x = g x" for x
     proof (cases "x \<in> {0..<n}")
       case True
       then show ?thesis
         by (metis fop o_inv_o_cancel p permutes_inj)
     next
       case False
       then show ?thesis
         by (metis fop o_inv_o_cancel p permutes_inj)
     qed
     thus "f = g" by auto
   qed
   have hF: "?h` F = F"
     unfolding image_def
   proof auto
     fix xa assume xa: "xa \<in> F" show "xa \<circ> ?inv_pi \<in> F"
       unfolding o_def F
       using F PiE p xa
       by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
     show "\<exists>x\<in>F. xa = x \<circ> ?inv_pi"
     proof (rule bexI[of _ "xa \<circ> \<pi>"])
       show "xa = xa \<circ> \<pi> \<circ> Hilbert_Choice.inv \<pi> "
         using p by auto
       show "xa \<circ> \<pi> \<in> F"
         unfolding o_def F
         using F PiE p xa
         by (auto, smt atLeastLessThan_iff permutes_def permutes_less(3))
     qed
   qed
   let ?g = "\<lambda>f. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f (\<pi> i), \<pi> i) * A $$ (i, f (\<pi> i)))"
     show "(\<Sum>f\<in>F. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f (\<pi> i), \<pi> i) * A $$ (i, f (\<pi> i)))) =
          (\<Sum>f\<in>F. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f i, \<pi> i) * A $$ (i, f i)))"
       using sum.reindex[OF inj_on_F, of "?g"] p unfolding hF unfolding o_def by auto
   qed (simp)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>F. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))
   * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i))))"
     by (smt mult.left_commute prod.cong prod.distrib sum.cong)
   finally show ?thesis .
 qed
 
 
 lemma detAB_Znm:
   assumes A: "A \<in> carrier_mat n m"
     and B: "B \<in> carrier_mat m n"
   shows "det (A*B) = (\<Sum>(f, \<pi>)\<in>Z n m. signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i) * B $$ (f i, \<pi> i)))"
 proof -
   let ?V="{0..<n}"
   let ?U = "{0..<m}"
   let ?PU = "{p. p permutes ?U}"
   let ?F = " {f. (\<forall>i\<in> {0..<n}. f i \<in> ?U) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   let ?f = "\<lambda>f. det (mat\<^sub>r n n (\<lambda> i. A $$ (i, f i) \<cdot>\<^sub>v row B (f i)))"
   let ?g = "\<lambda>f. det (mat\<^sub>r n n (\<lambda> i. B $$ (f i, i) \<cdot>\<^sub>v col A (f i)))"
   have fm: "finite {0..<m}" by auto
   have fn: "finite {0..<n}" by auto
   have F: "?F= {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}" by auto
   have det_rw: "det (mat\<^sub>r n n (\<lambda>i. B $$ (f i, i) \<cdot>\<^sub>v col A (f i))) =
     (prod (\<lambda>i. B $$ (f i, i)) {0..<n}) * det (mat\<^sub>r n n (\<lambda>i. col A (f i)))"
     if  f: "(\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)" for f
     by (rule det_rows_mul, insert A col_dim, auto)
   have det_rw2: "det (mat\<^sub>r n n (\<lambda>i. col A (f i)))
   = (\<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f i)))"
     if f: "f \<in> ?F" for f
   proof (unfold Determinant.det_def, auto, rule sum.cong, auto)
     fix x assume x: "x permutes {0..<n}"
     have "(\<Prod>i = 0..<n. col A (f i) $v x i) = (\<Prod>i = 0..<n. A $$ (x i, f i))"
     proof (rule prod.cong)
       fix xa assume xa: "xa \<in> {0..<n}" show "col A (f xa) $v x xa = A $$ (x xa, f  xa)"
         by (metis A atLeastLessThan_iff carrier_matD(1) col_def index_vec permutes_less(1) x xa)
     qed (auto)
     then show "signof x * (\<Prod>i = 0..<n. col A (f i) $v x i)
       = signof x * (\<Prod>i = 0..<n. A $$ (x i, f i))" by auto
   qed
   have fin_n: "finite {0..<n}" and fin_m: "finite {0..<m}" by auto
   have "det (A*B) = det (mat\<^sub>r n n (\<lambda>i. finsum_vec TYPE('a::comm_ring_1) n
     (\<lambda>k. B $$ (k, i) \<cdot>\<^sub>v Matrix.col A k) {0..<m}))"
     by (rule det_mul_finsum_alt[OF A B])
   also have "... = sum ?g ?F" by (rule det_linear_rows_sum[OF fm], auto simp add: A)
   also have "... = (\<Sum>f\<in>?F. prod (\<lambda>i. B $$ (f i, i)) {0..<n} * det (mat\<^sub>r n n (\<lambda>i. col A (f i))))"
     using det_rw by auto
   also have "... = (\<Sum>f\<in>?F. prod (\<lambda>i. B $$ (f i, i)) {0..<n} *
   (\<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f (i)))))"
     by (rule sum.cong, auto simp add: det_rw2)
   also have "... =
   (\<Sum>f\<in>?F. \<Sum>\<pi> | \<pi> permutes {0..<n}. prod (\<lambda>i. B $$ (f i, i)) {0..<n}
     * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f (i)))))"
     by (simp add: mult_hom.hom_sum)
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>?F.prod (\<lambda>i. B $$ (f i, i)) {0..<n}
     * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (\<pi> i, f i))))"
     by (rule VS_Connect.class_semiring.finsum_finsum_swap,
       insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
   thm detAB_Znm_aux
   also have "... = (\<Sum>\<pi> | \<pi> permutes {0..<n}. \<Sum>f\<in>?F. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))
   * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i))))" by (rule detAB_Znm_aux, auto)
   also have "... = (\<Sum>f\<in>?F.\<Sum>\<pi> | \<pi> permutes {0..<n}. (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))
   * (signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i))))"
     by (rule VS_Connect.class_semiring.finsum_finsum_swap,
       insert finite_permutations finite_bounded_functions[OF fin_m fin_n], auto)
   also have "... =  (\<Sum>f\<in>?F.\<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi>
     * (\<Prod>i = 0..<n. A $$ (i, f i) * B $$ (f i, \<pi> i)))"
     unfolding prod.distrib by (rule sum.cong, auto, rule sum.cong, auto)
   also have "... = sum (\<lambda>(f,\<pi>). (signof \<pi>)
     * (prod (\<lambda>i. A$$(i,f i) * B $$ (f i, \<pi> i)) {0..<n})) (Z n m)"
     unfolding Z_alt_def unfolding sum.cartesian_product[symmetric] F by auto
   finally show ?thesis .
 qed
 
 (*Several lemmas here can be moved outside the context*)
 context
   fixes n m and A B::"'a::comm_ring_1 mat"
   assumes A: "A \<in> carrier_mat n m"
     and B: "B \<in> carrier_mat m n"
 begin
 
 private definition "Z_inj = ({f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> inj_on f {0..<n}} \<times> {\<pi>. \<pi> permutes {0..<n}})"
 
 private definition "Z_not_inj = ({f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> \<not> inj_on f {0..<n}} \<times> {\<pi>. \<pi> permutes {0..<n}})"
 
 private definition "Z_strict = ({f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> strict_mono_on f {0..<n}} \<times> {\<pi>. \<pi> permutes {0..<n}})"
 
 private definition "Z_not_strict = ({f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> \<not> strict_mono_on f {0..<n}} \<times> {\<pi>. \<pi> permutes {0..<n}})"
 
 private definition "weight f \<pi>
   = (signof \<pi>) * (prod (\<lambda>i. A$$(i,f i) * B $$ (f i, \<pi> i)) {0..<n})"
 
 private definition "Z_good g = ({f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> inj_on f {0..<n} \<and> (f`{0..<n} = g`{0..<n})} \<times> {\<pi>. \<pi> permutes {0..<n}})"
 
 private definition "F_strict = {f. f \<in> {0..<n} \<rightarrow> {0..<m}
   \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> strict_mono_on f {0..<n}}"
 
 private definition "F_inj = {f. f \<in> {0..<n} \<rightarrow> {0..<m}
   \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> inj_on f {0..<n}}"
 
 private definition "F_not_inj = {f. f \<in> {0..<n} \<rightarrow> {0..<m}
   \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> \<not> inj_on f {0..<n}}"
 
 private definition "F = {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
 
 text\<open>The Cauchy--Binet formula is proven in \url{https://core.ac.uk/download/pdf/82475020.pdf}
   In that work, they define @{text "\<sigma> \<equiv> inv \<phi> \<circ> \<pi>"}. I had problems following this proof
   in Isabelle, since I was demanded to show that such permutations commute, which is false.
   It is a notation problem of the  @{text "\<circ>"} operator, the author means @{text "\<sigma> \<equiv> \<pi> \<circ> inv \<phi>"} using
   the Isabelle notation (i.e., @{text "\<sigma> x = \<pi> ((inv \<phi>) x)"}).
 \<close>
 
 lemma step_weight:
   fixes \<phi> \<pi>
   defines "\<sigma> \<equiv> \<pi> \<circ> Hilbert_Choice.inv \<phi>"
   assumes f_inj: "f \<in> F_inj" and gF: "g \<in> F" and pi: "\<pi> permutes {0..<n}"
   and phi: "\<phi> permutes {0..<n}" and fg_phi: "\<forall>x \<in> {0..<n}. f x = g (\<phi> x)"
 shows "weight f \<pi> = (signof \<phi>) * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i)))
   * (signof \<sigma>) * (\<Prod>i = 0..<n. B $$ (g i, \<sigma> i))"
 proof -
   let ?A = "(\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))) "
   let ?B = "(\<Prod>i = 0..<n. B $$ (g i, \<sigma> i))"
   have sigma: "\<sigma> permutes {0..<n}" unfolding \<sigma>_def
     by (rule permutes_compose[OF permutes_inv[OF phi] pi])
   have A_rw: "?A = (\<Prod>i = 0..<n. A $$ (i, f i))" using fg_phi by auto
   have "?B = (\<Prod>i = 0..<n. B $$ (g (\<phi> i), \<sigma> (\<phi> i)))"
     by (rule prod.permute[unfolded o_def, OF phi])
   also have "... = (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))"
     using fg_phi
     unfolding \<sigma>_def unfolding o_def unfolding permutes_inverses(2)[OF phi] by auto
   finally have B_rw: "?B = (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))" .
   have "(signof \<phi>) * ?A * (signof \<sigma>) * ?B = (signof \<phi>) * (signof \<sigma>) * ?A * ?B" by auto
   also have "... = signof (\<phi> \<circ> \<sigma>) * ?A * ?B" unfolding signof_compose[OF phi sigma] by simp
   also have "... = signof \<pi> * ?A * ?B"
     by (metis (no_types, lifting) \<sigma>_def mult.commute o_inv_o_cancel permutes_inj
         phi sigma signof_compose)
   also have "... = signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i)) * (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))"
     using A_rw B_rw by auto
   also have "... = signof \<pi> * (\<Prod>i = 0..<n. A $$ (i, f i) * B $$ (f i, \<pi> i))" by auto
   also have "... = weight f \<pi>" unfolding weight_def by simp
   finally show ?thesis ..
 qed
 
 
 lemma Z_good_fun_alt_sum:
   fixes g
   defines "Z_good_fun \<equiv> {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
     \<and> inj_on f {0..<n} \<and> (f`{0..<n} = g`{0..<n})}"
   assumes g: "g \<in> F_inj"
   shows "(\<Sum>f\<in>Z_good_fun. P f)= (\<Sum>\<pi>\<in>{\<pi>. \<pi> permutes {0..<n}}. P (g \<circ> \<pi>))"
 proof -
   let ?f = "\<lambda>\<pi>. g \<circ> \<pi>"
   let ?P = "{\<pi>. \<pi> permutes {0..<n}}"
   have fP: "?f`?P = Z_good_fun"
   proof (unfold Z_good_fun_def, auto)
     fix xa xb assume "xa permutes {0..<n}" and "xb < n"
     hence "xa xb < n" by auto
     thus "g (xa xb) < m" using g unfolding F_inj_def by fastforce
   next
     fix xa i assume "xa permutes {0..<n}" and i_ge_n: "\<not> i < n"
     hence "xa i = i" unfolding permutes_def by auto
     thus "g (xa i) = i" using g i_ge_n unfolding F_inj_def by auto
   next
     fix xa assume "xa permutes {0..<n}" thus "inj_on (g \<circ> xa) {0..<n}"
       by (metis (mono_tags, lifting) F_inj_def atLeast0LessThan comp_inj_on g
           mem_Collect_eq permutes_image permutes_inj_on)
   next
     fix \<pi> xb assume "\<pi> permutes {0..<n}" and "xb < n" thus " g xb \<in> (\<lambda>x. g (\<pi> x)) ` {0..<n}"
       by (metis (full_types) atLeast0LessThan imageI image_image lessThan_iff permutes_image)
   next
    fix x assume x1: "x \<in> {0..<n} \<rightarrow> {0..<m}" and x2: "\<forall>i. \<not> i < n \<longrightarrow> x i = i"
      and inj_on_x: "inj_on x {0..<n}" and xg: "x ` {0..<n} = g ` {0..<n}"
    let ?\<tau> = "\<lambda>i. if i<n then (THE j. j<n \<and> x i = g j) else i"
    show "x \<in> (\<circ>) g ` {\<pi>. \<pi> permutes {0..<n}}"
    proof (unfold image_def, auto, rule exI[of _ ?\<tau>], rule conjI)
      have "?\<tau> i = i" if i: "i \<notin> {0..<n}" for i
        using i by auto
      moreover have "\<exists>!j. ?\<tau> j = i" for i
      proof (cases "i<n")
        case True
        obtain a where xa_gi: "x a = g i" and a: "a < n" using xg True
          by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
        show ?thesis
        proof (rule ex1I[of _ a])
          have the_ai: "(THE j. j < n \<and> x a = g j) = i"
          proof (rule theI2)
            show "i < n \<and> x a = g i" using xa_gi True by auto
            fix xa assume "xa < n \<and> x a = g xa" thus "xa = i"
              by (metis (mono_tags, lifting) F_inj_def True atLeast0LessThan
                 g inj_onD lessThan_iff mem_Collect_eq xa_gi)
            thus "xa = i" .
          qed
          thus ta: "?\<tau> a = i" using a by auto
          fix j assume tj: "?\<tau> j = i"
          show "j = a"
          proof (cases "j<n")
            case True
            obtain b where xj_gb: "x j = g b" and b: "b < n" using xg True
              by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
            let ?P = "\<lambda>ja. ja < n \<and> x j = g ja"
            have the_ji: "(THE ja. ja < n \<and> x j = g ja) = i" using tj True by auto
            have "?P (THE ja. ?P ja)"
            proof (rule theI)
             show "b < n \<and> x j = g b" using xj_gb b by auto
             fix xa assume "xa < n \<and> x j = g xa" thus "xa = b"
               by (metis (mono_tags, lifting) F_inj_def b atLeast0LessThan
                   g inj_onD lessThan_iff mem_Collect_eq xj_gb)
            qed
            hence "x j = g i" unfolding the_ji by auto
            hence "x j = x a" using xa_gi by auto
            then show ?thesis using inj_on_x a True unfolding inj_on_def by auto
          next
            case False
            then show ?thesis using tj True by auto
          qed
        qed
      next
        case False note i_ge_n = False
        show ?thesis
        proof (rule ex1I[of _ i])
          show "?\<tau> i = i" using False by simp
          fix j assume tj: "?\<tau> j = i"
          show "j = i"
          proof (cases "j<n")
            case True
            obtain a where xj_ga: "x j = g a" and a: "a < n" using xg True
              by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff)
            have "(THE ja. ja < n \<and> x j = g ja) < n"
            proof (rule theI2)
              show "a < n \<and> x j = g a" using xj_ga a by auto
              fix xa assume a1: "xa < n \<and> x j = g xa" thus "xa = a"
                using F_inj_def  a atLeast0LessThan g inj_on_eq_iff xj_ga by fastforce
              show "xa < n" by (simp add: a1)
            qed
             then show ?thesis using tj i_ge_n by auto
           next
             case False
             then show ?thesis using tj  by auto
           qed
        qed
      qed
      ultimately show "?\<tau> permutes {0..<n}" unfolding permutes_def by auto
      show "x = g \<circ> ?\<tau>"
      proof -
        have "x xa = g (THE j. j < n \<and> x xa = g j)" if xa: "xa < n" for xa
        proof -
          obtain c where c: "c < n" and xxa_gc: "x xa = g c"
            by (metis (mono_tags, hide_lams) atLeast0LessThan imageE imageI lessThan_iff xa xg)
          show ?thesis
          proof (rule theI2)
            show c1: "c < n \<and> x xa = g c" using c xxa_gc by auto
            fix xb assume c2: "xb < n \<and> x xa = g xb" thus "xb = c"
              by (metis (mono_tags, lifting) F_inj_def c1 atLeast0LessThan
                  g inj_onD lessThan_iff mem_Collect_eq)
            show "x xa = g xb" using c1 c2 by simp
          qed
        qed
        moreover have "x xa = g xa" if xa: "\<not> xa < n" for xa
          using g x1 x2 xa unfolding F_inj_def by simp
        ultimately show ?thesis unfolding o_def fun_eq_iff by auto
      qed
    qed
  qed
   have inj: "inj_on ?f ?P"
   proof (rule inj_onI)
     fix x y assume x: "x \<in> ?P" and y: "y \<in> ?P" and gx_gy: "g \<circ> x = g \<circ> y"
     have "x i = y i" for i
     proof (cases "i<n")
       case True
       hence xi: "x i \<in> {0..<n}" and yi: "y i \<in> {0..<n}" using x y by auto
       have "g (x i) = g (y i)" using gx_gy unfolding o_def by meson
       thus ?thesis using xi yi using g unfolding F_inj_def inj_on_def by blast
     next
       case False
       then show ?thesis using x y unfolding permutes_def by auto
     qed
     thus "x = y" unfolding fun_eq_iff by auto
   qed
   have "(\<Sum>f\<in>Z_good_fun. P f) = (\<Sum>f\<in>?f`?P. P f)" using fP by simp
   also have "... =  sum (P \<circ> (\<circ>) g) {\<pi>. \<pi> permutes {0..<n}}"
     by (rule sum.reindex[OF inj])
   also have "... =  (\<Sum>\<pi> | \<pi> permutes {0..<n}. P (g \<circ> \<pi>))" by auto
   finally show ?thesis .
 qed
 
 
 lemma F_injI:
   assumes "f \<in> {0..<n} \<rightarrow> {0..<m}"
   and "(\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)" and "inj_on f {0..<n}"
   shows "f \<in> F_inj" using assms unfolding F_inj_def by simp
 
 lemma F_inj_composition_permutation:
   assumes phi: "\<phi> permutes {0..<n}"
   and g: "g \<in> F_inj"
   shows "g \<circ> \<phi> \<in> F_inj"
 proof (rule F_injI)
   show "g \<circ> \<phi> \<in> {0..<n} \<rightarrow> {0..<m}"
     using g unfolding permutes_def F_inj_def
     by (simp add: Pi_iff phi)
   show "\<forall>i. i \<notin> {0..<n} \<longrightarrow> (g \<circ> \<phi>) i = i"
     using g phi unfolding permutes_def F_inj_def by simp
   show "inj_on (g \<circ> \<phi>) {0..<n}"
     by (rule comp_inj_on, insert g permutes_inj_on[OF phi] permutes_image[OF phi])
        (auto simp add: F_inj_def)
 qed
 
 
 lemma F_strict_imp_F_inj:
   assumes f: "f \<in> F_strict"
   shows "f \<in> F_inj"
   using f strict_mono_on_imp_inj_on
   unfolding F_strict_def F_inj_def by auto
 
 
 lemma one_step:
   assumes g1: "g \<in> F_strict"
   shows "det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)
     = (\<Sum>(x, y) \<in> Z_good g. weight x y)" (is "?lhs = ?rhs")
 proof -
   define Z_good_fun where "Z_good_fun = {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
     \<and> inj_on f {0..<n} \<and> (f`{0..<n} = g`{0..<n})}"
   let ?Perm = "{\<pi>. \<pi> permutes {0..<n}}"
   let ?P = "(\<lambda>f. \<Sum>\<pi> \<in> ?Perm. weight f \<pi>)"
   let ?inv = "Hilbert_Choice.inv"
   have g: "g \<in> F_inj" by (rule F_strict_imp_F_inj[OF g1])
   have detA: "(\<Sum>\<phi>\<in>{\<pi>. \<pi> permutes {0..<n}}. signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))))
     = det (submatrix A UNIV (g`{0..<n}))"
   proof -
     have "{j. j < dim_col A \<and> j \<in> g ` {0..<n}} = {j. j \<in> g ` {0..<n}}"
       using g A unfolding F_inj_def by fastforce
     also have "card ... = n" using F_inj_def card_image g by force
     finally have card_J: "card {j. j < dim_col A \<and> j \<in> g ` {0..<n}} = n" by simp
     have subA_carrier: "submatrix A UNIV (g ` {0..<n}) \<in> carrier_mat n n"
       unfolding submatrix_def card_J using A by auto
     have "det (submatrix A UNIV (g`{0..<n})) = (\<Sum>p | p permutes {0..<n}.
             signof p * (\<Prod>i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, p i)))"
       using subA_carrier unfolding Determinant.det_def by auto
     also have "... = (\<Sum>\<phi>\<in>{\<pi>. \<pi> permutes {0..<n}}. signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))))"
     proof (rule sum.cong)
       fix x assume x: "x \<in> {\<pi>. \<pi> permutes {0..<n}}"
       have "(\<Prod>i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
           = (\<Prod>i = 0..<n. A $$ (i, g (x i)))"
       proof (rule prod.cong, rule refl)
         fix i assume i: "i \<in> {0..<n}"
         have pick_rw: "pick (g ` {0..<n}) (x i) = g (x i)"
         proof -
           have "index (sorted_list_of_set (g ` {0..<n})) (g (x i)) = x i"
           proof -
             have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
               by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
             have "index (sorted_list_of_set (g`{0..<n})) (g (x i)) = index (map g [0..<n]) (g (x i))"
               unfolding rw by auto
             also have "... = index [0..<n] (x i)"
               by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
             also have "... = x i" using x i by auto
             finally show ?thesis .
           qed
           moreover have "(g (x i))  \<in> (g ` {0..<n})" using x g i unfolding F_inj_def by auto
           moreover have "x i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
           ultimately show ?thesis using pick_index by auto
         qed
         have "submatrix A UNIV (g`{0..<n}) $$ (i, x i) = A $$ (pick UNIV i, pick (g`{0..<n}) (x i))"
           by (rule submatrix_index, insert i A card_J x, auto)
         also have "... = A $$ (i, g (x i))" using pick_rw pick_UNIV by auto
         finally show "submatrix A UNIV (g ` {0..<n}) $$ (i, x i) = A $$ (i, g (x i))" .
       qed
       thus "signof x * (\<Prod>i = 0..<n. submatrix A UNIV (g ` {0..<n}) $$ (i, x i))
         = signof x * (\<Prod>i = 0..<n. A $$ (i, g (x i)))" by auto
     qed (simp)
     finally show ?thesis by simp
   qed
   have detB_rw: "(\<Sum>\<pi> \<in> ?Perm. signof (\<pi> \<circ> ?inv \<phi>) * (\<Prod>i = 0..<n. B $$ (g i, (\<pi> \<circ> ?inv \<phi>) i)))
    = (\<Sum>\<pi> \<in> ?Perm. signof (\<pi>) * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i)))"
     if phi: "\<phi> permutes {0..<n}" for \<phi>
   proof -
     let ?h="\<lambda>\<pi>. \<pi> \<circ> ?inv \<phi>"
     let ?g = "\<lambda>\<pi>. signof (\<pi>) * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i))"
     have "?h`?Perm = ?Perm"
     proof -
       have "\<pi> \<circ> ?inv \<phi> permutes {0..<n}" if pi: "\<pi> permutes {0..<n}" for \<pi>
         using permutes_compose permutes_inv phi that by blast
       moreover have "x \<in> (\<lambda>\<pi>. \<pi> \<circ> ?inv \<phi>) ` ?Perm" if "x permutes {0..<n}" for x
       proof -
         have "x \<circ> \<phi> permutes {0..<n}"
           using permutes_compose phi that by blast
         moreover have "x = x \<circ> \<phi> \<circ> ?inv \<phi>" using phi by auto
         ultimately show ?thesis unfolding image_def by auto
       qed
       ultimately show ?thesis by auto
     qed
     hence "(\<Sum>\<pi> \<in> ?Perm. ?g \<pi>) = (\<Sum>\<pi> \<in> ?h`?Perm. ?g \<pi>)" by simp
     also have "... = sum (?g \<circ> ?h) ?Perm"
     proof (rule sum.reindex)
       show "inj_on (\<lambda>\<pi>. \<pi> \<circ> ?inv \<phi>) {\<pi>. \<pi> permutes {0..<n}}"
         by (metis (no_types, lifting) inj_onI o_inv_o_cancel permutes_inj phi)
     qed
     also have "... = (\<Sum>\<pi> \<in> ?Perm. signof (\<pi> \<circ> ?inv \<phi>) * (\<Prod>i = 0..<n. B $$ (g i, (\<pi> \<circ> ?inv \<phi>) i)))"
       unfolding o_def by auto
     finally show ?thesis by simp
   qed
 
   have detB: "det (submatrix B (g`{0..<n}) UNIV)
     = (\<Sum>\<pi> \<in> ?Perm. signof \<pi> * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i)))"
   proof -
     have "{i. i < dim_row B \<and> i \<in> g ` {0..<n}} = {i. i \<in> g ` {0..<n}}"
      using g B unfolding F_inj_def by fastforce
     also have "card ... = n" using F_inj_def card_image g by force
     finally have card_I: "card {j. j < dim_row B \<and> j \<in> g ` {0..<n}} = n" by simp
     have subB_carrier: "submatrix B (g ` {0..<n}) UNIV \<in> carrier_mat n n"
       unfolding submatrix_def using card_I B by auto
     have "det (submatrix B (g`{0..<n}) UNIV) = (\<Sum>p \<in> ?Perm. signof p
       * (\<Prod>i=0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, p i)))"
       unfolding Determinant.det_def using subB_carrier by auto
     also have "... = (\<Sum>\<pi> \<in> ?Perm. signof \<pi> * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i)))"
     proof (rule sum.cong, rule refl)
       fix x assume x: "x \<in> {\<pi>. \<pi> permutes {0..<n}}"
       have "(\<Prod>i=0..<n. submatrix B (g`{0..<n}) UNIV $$ (i, x i)) = (\<Prod>i=0..<n. B $$ (g i, x i))"
       proof (rule prod.cong, rule refl)
         fix i assume i: "i \<in> {0..<n}"
         have pick_rw: "pick (g ` {0..<n}) i = g i"
         proof -
           have "index (sorted_list_of_set (g ` {0..<n})) (g i) = i"
           proof -
             have rw: "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
               by (rule sorted_list_of_set_map_strict, insert g1, simp add: F_strict_def)
             have "index (sorted_list_of_set (g`{0..<n})) (g i) = index (map g [0..<n]) (g i)"
               unfolding rw by auto
             also have "... = index [0..<n] (i)"
               by (rule index_map_inj_on[of _ "{0..<n}"], insert x i g, auto simp add: F_inj_def)
             also have "... = i" using i by auto
             finally show ?thesis .
           qed
           moreover have "(g i)  \<in> (g ` {0..<n})" using x g i unfolding F_inj_def by auto
           moreover have "i < card (g ` {0..<n})" using x i g by (simp add: F_inj_def card_image)
           ultimately show ?thesis using pick_index by auto
         qed
         have "submatrix B (g`{0..<n}) UNIV $$ (i, x i) = B $$ (pick (g`{0..<n}) i, pick UNIV (x i))"
           by (rule submatrix_index, insert i B card_I x, auto)
         also have "... = B $$ (g i, x i)" using pick_rw pick_UNIV by auto
         finally show "submatrix B (g ` {0..<n}) UNIV $$ (i, x i) = B $$ (g i, x i)" .
       qed
       thus "signof x * (\<Prod>i = 0..<n. submatrix B (g ` {0..<n}) UNIV $$ (i, x i))
           = signof x * (\<Prod>i = 0..<n. B $$ (g i, x i))" by simp
     qed
     finally show ?thesis .
   qed
 
   have "?rhs = (\<Sum>f\<in>Z_good_fun. \<Sum>\<pi>\<in>?Perm. weight f \<pi>)"
     unfolding Z_good_def sum.cartesian_product Z_good_fun_def by blast
   also have "... = (\<Sum>\<phi>\<in>{\<pi>. \<pi> permutes {0..<n}}. ?P (g \<circ> \<phi>))" unfolding Z_good_fun_def
     by (rule Z_good_fun_alt_sum[OF g])
   also have "... = (\<Sum>\<phi>\<in>{\<pi>. \<pi> permutes {0..<n}}. \<Sum>\<pi>\<in>{\<pi>. \<pi> permutes {0..<n}}.
     signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))) * signof (\<pi> \<circ> ?inv \<phi>)
     * (\<Prod>i = 0..<n. B $$ (g i, (\<pi> \<circ> ?inv \<phi>) i)))"
   proof (rule sum.cong, simp, rule sum.cong, simp)
     fix \<phi> \<pi> assume phi: "\<phi> \<in> ?Perm" and pi: "\<pi> \<in> ?Perm"
     show "weight (g \<circ> \<phi>) \<pi> = signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))) *
       signof (\<pi> \<circ> ?inv \<phi>) * (\<Prod>i = 0..<n. B $$ (g i, (\<pi> \<circ> ?inv \<phi>) i))"
     proof (rule step_weight)
       show "g \<circ> \<phi> \<in> F_inj" by (rule F_inj_composition_permutation[OF _ g], insert phi, auto)
       show "g \<in> F" using g unfolding F_def F_inj_def by simp
     qed (insert phi pi, auto)
   qed
   also have "... = (\<Sum>\<phi>\<in>{\<pi>. \<pi> permutes {0..<n}}. signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))) *
      (\<Sum>\<pi> | \<pi> permutes {0..<n}. signof (\<pi> \<circ> ?inv \<phi>) * (\<Prod>i = 0..<n. B $$ (g i, (\<pi> \<circ> ?inv \<phi>) i))))"
     by (metis (mono_tags, lifting) Groups.mult_ac(1) semiring_0_class.sum_distrib_left sum.cong)
   also have "... = (\<Sum>\<phi> \<in> ?Perm. signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i))) *
     (\<Sum>\<pi> \<in> ?Perm. signof \<pi> * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i))))" using detB_rw by auto
   also have "... = (\<Sum>\<phi> \<in> ?Perm. signof \<phi> * (\<Prod>i = 0..<n. A $$ (i, g (\<phi> i)))) *
     (\<Sum>\<pi> \<in> ?Perm. signof \<pi> * (\<Prod>i = 0..<n. B $$ (g i, \<pi> i)))"
     by (simp add: semiring_0_class.sum_distrib_right)
   also have "... = ?lhs" unfolding detA detB ..
   finally show ?thesis ..
 qed
 
 
 lemma gather_by_strictness:
 "sum (\<lambda>g. sum (\<lambda>(f,\<pi>). weight f \<pi>) (Z_good g)) F_strict
   = sum (\<lambda>g. det (submatrix A UNIV (g`{0..<n})) * det (submatrix B (g`{0..<n}) UNIV)) F_strict"
 proof (rule sum.cong)
   fix f assume f: "f \<in> F_strict"
   show "(\<Sum>(x, y)\<in>Z_good f. weight x y)
     = det (submatrix A UNIV (f ` {0..<n})) * det (submatrix B (f ` {0..<n}) UNIV)"
     by (rule one_step[symmetric], rule f)
 qed (simp)
 
 lemma finite_Z_strict[simp]: "finite Z_strict"
 proof (unfold Z_strict_def, rule finite_cartesian_product)
   have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
   let ?A="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> strict_mono_on f {0..<n}}"
   let ?B="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have B: "{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} = ?B" by auto
   have "?A\<subseteq>?B" by auto
   moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
   ultimately show "finite ?A" using rev_finite_subset by blast
   show "finite {\<pi>. \<pi> permutes {0..<n}}" using finite_permutations by blast
 qed
 
 lemma finite_Z_not_strict[simp]: "finite Z_not_strict"
 proof (unfold Z_not_strict_def, rule finite_cartesian_product)
   have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
   let ?A="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> \<not> strict_mono_on f {0..<n}}"
   let ?B="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have B: "{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} = ?B" by auto
   have "?A\<subseteq>?B" by auto
   moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
   ultimately show "finite ?A" using rev_finite_subset by blast
   show "finite {\<pi>. \<pi> permutes {0..<n}}" using finite_permutations by blast
 qed
 
 lemma finite_Znm[simp]: "finite (Z n m)"
 proof (unfold Z_alt_def, rule finite_cartesian_product)
   have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
   let ?A="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) }"
   let ?B="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have B: "{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} = ?B" by auto
   have "?A\<subseteq>?B" by auto
   moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
   ultimately show "finite ?A" using rev_finite_subset by blast
   show "finite {\<pi>. \<pi> permutes {0..<n}}" using finite_permutations by blast
 qed
 
 lemma finite_F_inj[simp]: "finite F_inj"
 proof -
   have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
   let ?A="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> inj_on f {0..<n}}"
   let ?B="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have B: "{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} = ?B" by auto
   have "?A\<subseteq>?B" by auto
   moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
   ultimately show "finite F_inj" unfolding F_inj_def using rev_finite_subset by blast
 qed
 
 lemma finite_F_strict[simp]: "finite F_strict"
 proof -
  have finN: "finite {0..<n}" and finM: "finite {0..<m}" by auto
   let ?A="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i) \<and> strict_mono_on f {0..<n}}"
   let ?B="{f \<in> {0..<n} \<rightarrow> {0..<m}. (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   have B: "{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)} = ?B" by auto
   have "?A\<subseteq>?B" by auto
   moreover have "finite ?B" using B finite_bounded_functions[OF finM finN] by auto
   ultimately show "finite F_strict" unfolding F_strict_def using rev_finite_subset by blast
 qed
 
 lemma nth_strict_mono:
   fixes f::"nat \<Rightarrow> nat"
   assumes  strictf: "strict_mono f" and i: "i<n"
 shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
 proof -
   let ?I = "f`{0..<n}"
   have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
     by (metis distinct_card finite_atLeastLessThan finite_imageI
         sorted_list_of_set(1) sorted_list_of_set(3))
   also have "... = n"
     by (simp add: card_image strict_mono_imp_inj_on strictf)
   finally have length_I: "length (sorted_list_of_set ?I) = n" .
   have card_eq: "card {a \<in> ?I. a < f i} = i"
     using i
   proof (induct i)
     case 0
     then show ?case
       by (auto simp add: strict_mono_less strictf)
   next
     case (Suc i)
     have i: "i < n" using Suc.prems by auto
     let ?J'="{a \<in> f ` {0..<n}. a < f i}"
     let ?J = "{a \<in> f ` {0..<n}. a < f (Suc i)}"
     have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
     have J: "?J = insert (f i) ?J'"
     proof (auto)
       fix xa assume 1: "f xa \<noteq> f i" and 2: "f xa < f (Suc i)"
       show "f xa < f i"
         using 1 2 not_less_less_Suc_eq strict_mono_less strictf by fastforce
     next
       fix xa assume "f xa < f i" thus "f xa < f (Suc i)"
         using less_SucI strict_mono_less strictf by blast
     next
       show "f i \<in> f ` {0..<n}" using i by auto
       show "f i < f (Suc i)" using strictf strict_mono_less by auto
     qed
     have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
     then show ?case using cardJ' by auto
   qed
   have "sorted_list_of_set ?I ! i = pick ?I i"
     by (rule sorted_list_of_set_eq_pick, simp add: \<open>card (f ` {0..<n}) = n\<close> i)
   also have "... =  pick ?I (card {a \<in> ?I. a < f i})" unfolding card_eq by simp
   also have "... = f i" by (rule pick_card_in_set, simp add: i)
   finally show ?thesis ..
 qed
 
 lemma nth_strict_mono_on:
   fixes f::"nat \<Rightarrow> nat"
   assumes  strictf: "strict_mono_on f {0..<n}" and i: "i<n"
 shows "f i = (sorted_list_of_set (f`{0..<n})) ! i"
 proof -
   let ?I = "f`{0..<n}"
   have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
     by (metis distinct_card finite_atLeastLessThan finite_imageI
         sorted_list_of_set(1) sorted_list_of_set(3))
   also have "... = n"
     by (metis (mono_tags, lifting) card_atLeastLessThan card_image diff_zero
         inj_on_def strict_mono_on_eqD strictf)
   finally have length_I: "length (sorted_list_of_set ?I) = n" .
   have card_eq: "card {a \<in> ?I. a < f i} = i"
     using i
   proof (induct i)
     case 0
     then show ?case
       by (auto, metis (no_types, lifting) atLeast0LessThan lessThan_iff less_Suc_eq
           not_less0 not_less_eq strict_mono_on_def strictf)
   next
     case (Suc i)
     have i: "i < n" using Suc.prems by auto
     let ?J'="{a \<in> f ` {0..<n}. a < f i}"
     let ?J = "{a \<in> f ` {0..<n}. a < f (Suc i)}"
     have cardJ': "card ?J' = i" by (rule Suc.hyps[OF i])
     have J: "?J = insert (f i) ?J'"
     proof (auto)
       fix xa assume 1: "f xa \<noteq> f i" and 2: "f xa < f (Suc i)" and 3: "xa < n"
       show "f xa < f i"
         by (metis (full_types) 1 2 3 antisym_conv3 atLeast0LessThan i lessThan_iff
             less_SucE order.asym strict_mono_onD strictf)
     next
       fix xa assume "f xa < f i" and "xa < n" thus "f xa < f (Suc i)"
         using less_SucI strictf
         by (metis (no_types, lifting) Suc.prems atLeast0LessThan
             lessI lessThan_iff less_trans strict_mono_onD)
     next
       show "f i \<in> f ` {0..<n}" using i by auto
       show "f i < f (Suc i)"
         using Suc.prems strict_mono_onD strictf by fastforce
     qed
     have "card ?J = Suc (card ?J')" by (unfold J, rule card_insert_disjoint, auto)
     then show ?case using cardJ' by auto
   qed
   have "sorted_list_of_set ?I ! i = pick ?I i"
     by (rule sorted_list_of_set_eq_pick, simp add: \<open>card (f ` {0..<n}) = n\<close> i)
   also have "... =  pick ?I (card {a \<in> ?I. a < f i})" unfolding card_eq by simp
   also have "... = f i" by (rule pick_card_in_set, simp add: i)
   finally show ?thesis ..
 qed
 
 lemma strict_fun_eq:
   assumes f: "f \<in> F_strict" and g: "g \<in> F_strict" and fg: "f`{0..<n} = g`{0..<n}"
   shows "f = g"
 proof (unfold fun_eq_iff, auto)
   fix x
   show "f x = g x"
   proof (cases "x<n")
     case True
     have strictf: "strict_mono_on f {0..<n}" and strictg: "strict_mono_on g {0..<n}"
       using f g unfolding F_strict_def by auto
     have "f x = (sorted_list_of_set (f`{0..<n})) ! x" by (rule nth_strict_mono_on[OF strictf True])
     also have "... = (sorted_list_of_set (g`{0..<n})) ! x" unfolding fg by simp
     also have "... = g x" by (rule nth_strict_mono_on[symmetric, OF strictg True])
     finally show ?thesis .
   next
     case False
     then show ?thesis using f g unfolding F_strict_def by auto
   qed
 qed
 
 
 lemma strict_from_inj_preserves_F:
   assumes f: "f \<in> F_inj"
   shows "strict_from_inj n f \<in> F"
 proof -
   {
     fix x assume x: "x < n"
     have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
     have "{a. a < m \<and> a \<in> f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
     hence card_eq: "card {a. a < m \<and> a \<in> f ` {0..<n}} = n"
       by (simp add: card_image inj_on)
     let ?I = "f`{0..<n}"
     have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
       by (metis distinct_card finite_atLeastLessThan finite_imageI
           sorted_list_of_set(1) sorted_list_of_set(3))
     also have "... = n"
       by (simp add: card_image strict_mono_imp_inj_on inj_on)
     finally have length_I: "length (sorted_list_of_set ?I) = n" .
     have "sorted_list_of_set (f ` {0..<n}) ! x = pick (f ` {0..<n}) x"
       by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: x)
     also have "... < m" by (rule pick_le, unfold card_eq, rule x)
     finally have "sorted_list_of_set (f ` {0..<n}) ! x < m" .
   }
   thus ?thesis unfolding strict_from_inj_def F_def by auto
 qed
 
 lemma strict_from_inj_F_strict: "strict_from_inj n xa \<in> F_strict"
   if xa: "xa \<in> F_inj" for xa
 proof -
   have "strict_mono_on (strict_from_inj n xa) {0..<n}"
     by (rule strict_strict_from_inj, insert xa, simp add: F_inj_def)
   thus ?thesis using strict_from_inj_preserves_F[OF xa] unfolding F_def F_strict_def by auto
 qed
 
 lemma strict_from_inj_image:
   assumes f: "f\<in> F_inj"
   shows "strict_from_inj n f ` {0..<n} = f`{0..<n}"
 proof (auto)
   let ?I = "f ` {0..<n}"
   fix xa assume xa: "xa < n"
   have inj_on: "inj_on f {0..<n}" using f unfolding F_inj_def by auto
     have "{a. a < m \<and> a \<in> f ` {0..<n}} = f`{0..<n}" using f unfolding F_inj_def by auto
     hence card_eq: "card {a. a < m \<and> a \<in> f ` {0..<n}} = n"
       by (simp add: card_image inj_on)
     let ?I = "f`{0..<n}"
     have "length (sorted_list_of_set (f ` {0..<n})) = card ?I"
       by (metis distinct_card finite_atLeastLessThan finite_imageI
           sorted_list_of_set(1) sorted_list_of_set(3))
     also have "... = n"
       by (simp add: card_image strict_mono_imp_inj_on inj_on)
     finally have length_I: "length (sorted_list_of_set ?I) = n" .
   have "strict_from_inj n f xa = sorted_list_of_set ?I ! xa"
     using xa unfolding strict_from_inj_def by auto
   also have "... = pick ?I xa"
     by (rule sorted_list_of_set_eq_pick, unfold length_I, auto simp add: xa)
   also have "... \<in> f ` {0..<n}" by (rule pick_in_set_le, simp add: \<open>card (f ` {0..<n}) = n\<close> xa)
   finally show "strict_from_inj n f xa \<in> f ` {0..<n}" .
   obtain i where "sorted_list_of_set (f`{0..<n}) ! i = f xa" and "i<n"
     by (metis atLeast0LessThan finite_atLeastLessThan finite_imageI imageI
         in_set_conv_nth length_I lessThan_iff sorted_list_of_set(1) xa)
   thus "f xa \<in> strict_from_inj n f ` {0..<n}"
     by (metis atLeast0LessThan imageI lessThan_iff strict_from_inj_def)
 qed
 
 
 lemma Z_good_alt:
   assumes g: "g \<in> F_strict"
   shows "Z_good g = {x \<in> F_inj. strict_from_inj n x = g} \<times> {\<pi>. \<pi> permutes {0..<n}}"
 proof -
   define Z_good_fun where "Z_good_fun = {f. f \<in> {0..<n} \<rightarrow> {0..<m} \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)
   \<and> inj_on f {0..<n} \<and> (f`{0..<n} = g`{0..<n})}"
   have "Z_good_fun = {x \<in> F_inj. strict_from_inj n x = g}"
   proof (auto)
     fix f assume f: "f \<in> Z_good_fun" thus f_inj: "f \<in> F_inj" unfolding F_inj_def Z_good_fun_def by auto
     show "strict_from_inj n f = g"
     proof (rule strict_fun_eq[OF _ g])
       show "strict_from_inj n f ` {0..<n} = g ` {0..<n}"
         using f_inj f strict_from_inj_image
         unfolding Z_good_fun_def F_inj_def by auto
       show "strict_from_inj n f \<in> F_strict"
         using F_strict_def f_inj strict_from_inj_F_strict by blast
     qed
   next
     fix f assume f_inj: "f \<in> F_inj" and g_strict_f: "g = strict_from_inj n f"
     have "f xa \<in> g ` {0..<n}" if "xa < n" for xa
       using f_inj g_strict_f strict_from_inj_image that by auto
     moreover have "g xa \<in> f ` {0..<n}" if "xa < n" for xa
       by (metis f_inj g_strict_f imageI lessThan_atLeast0 lessThan_iff strict_from_inj_image that)
     ultimately show "f \<in> Z_good_fun"
       using f_inj g_strict_f unfolding Z_good_fun_def F_inj_def
       by auto
   qed
   thus ?thesis unfolding Z_good_fun_def Z_good_def by simp
 qed
 
 
 lemma weight_0: "(\<Sum>(f, \<pi>) \<in> Z_not_inj. weight f \<pi>) = 0"
 proof -
   let ?F="{f. (\<forall>i\<in>{0..<n}. f i \<in> {0..<m}) \<and> (\<forall>i. i \<notin> {0..<n} \<longrightarrow> f i = i)}"
   let ?Perm = "{\<pi>. \<pi> permutes {0..<n}}"
   have "(\<Sum>(f, \<pi>)\<in>Z_not_inj. weight f \<pi>)
     = (\<Sum>f \<in> F_not_inj. (\<Prod>i = 0..<n. A $$ (i, f i)) * det (mat\<^sub>r n n (\<lambda>i. row B (f i))))"
   proof -
     have dim_row_rw: "dim_row (mat\<^sub>r n n (\<lambda>i. col A (f i))) = n" for f by auto
     have dim_row_rw2: "dim_row (mat\<^sub>r n n (\<lambda>i. Matrix.row B (f i))) = n" for f by auto
     have prod_rw: "(\<Prod>i = 0..<n. B $$ (f i, \<pi> i)) =  (\<Prod>i = 0..<n. row B (f i) $v \<pi> i)"
       if f: "f \<in> F_not_inj" and pi: "\<pi> \<in> ?Perm" for f \<pi>
     proof (rule prod.cong, rule refl)
       fix x assume x: "x \<in> {0..<n}"
       have "f x < dim_row B" using f B x unfolding F_not_inj_def by fastforce
       moreover have "\<pi> x < dim_col B" using x pi B by auto
       ultimately show "B $$ (f x, \<pi> x) = Matrix.row B (f x) $v \<pi> x" by (rule index_row[symmetric])
     qed
     have sum_rw: "(\<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f i, \<pi> i)))
       = det (mat\<^sub>r n n (\<lambda>i. row B (f i)))" if f: "f \<in> F_not_inj" for f
       unfolding Determinant.det_def using dim_row_rw2 prod_rw f by auto
     have "(\<Sum>(f, \<pi>)\<in>Z_not_inj. weight f \<pi>) = (\<Sum>f\<in>F_not_inj.\<Sum>\<pi> \<in> ?Perm. weight f \<pi>)"
       unfolding Z_not_inj_def unfolding sum.cartesian_product
       unfolding F_not_inj_def by simp
     also have "... = (\<Sum>f\<in>F_not_inj. \<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi>
       * (\<Prod>i = 0..<n. A $$ (i, f i) * B $$ (f i, \<pi> i)))"
       unfolding weight_def by simp
     also have "... = (\<Sum>f\<in>F_not_inj. (\<Prod>i = 0..<n. A $$ (i, f i))
       * (\<Sum>\<pi> | \<pi> permutes {0..<n}. signof \<pi> * (\<Prod>i = 0..<n. B $$ (f i, \<pi> i))))"
       by (rule sum.cong, rule refl, auto)
          (metis (no_types, lifting) mult.left_commute mult_hom.hom_sum sum.cong)
     also have "... = (\<Sum>f \<in> F_not_inj. (\<Prod>i = 0..<n. A $$ (i, f i))
       * det (mat\<^sub>r n n (\<lambda>i. row B (f i))))" using sum_rw by auto
     finally show ?thesis by auto
   qed
   also have "... = 0"
     by (rule sum.neutral, insert det_not_inj_on[of _ n B], auto simp add: F_not_inj_def)
   finally show ?thesis .
 qed
 
 subsection \<open>Final theorem\<close>
 
 lemma Cauchy_Binet1:
   shows "det (A*B) =
   sum (\<lambda>f. det (submatrix A UNIV (f`{0..<n})) * det (submatrix B (f`{0..<n}) UNIV)) F_strict"
 (is "?lhs = ?rhs")
 proof -
   have sum0: "(\<Sum>(f, \<pi>) \<in> Z_not_inj. weight f \<pi>) = 0" by (rule weight_0)
   let ?f = "strict_from_inj n"
   have sum_rw: "sum g F_inj = (\<Sum>y \<in> F_strict. sum g {x \<in> F_inj. ?f x = y})" for g
     by (rule sum.group[symmetric], insert strict_from_inj_F_strict, auto)
   have Z_Union: "Z_inj \<union> Z_not_inj = Z n m"
     unfolding Z_def Z_not_inj_def Z_inj_def by auto
   have Z_Inter: "Z_inj \<inter> Z_not_inj = {}"
     unfolding Z_def Z_not_inj_def Z_inj_def by auto
   have "det (A*B) = (\<Sum>(f, \<pi>)\<in>Z n m. weight f \<pi>)"
     using detAB_Znm[OF A B] unfolding weight_def by auto
   also have "... = (\<Sum>(f, \<pi>)\<in>Z_inj. weight f \<pi>) + (\<Sum>(f, \<pi>)\<in>Z_not_inj. weight f \<pi>)"
     by (metis Z_Inter Z_Union finite_Un finite_Znm sum.union_disjoint)
   also have "... = (\<Sum>(f, \<pi>)\<in>Z_inj. weight f \<pi>)" using sum0 by force
   also have "... = (\<Sum>f \<in> F_inj. \<Sum>\<pi>\<in>{\<pi>. \<pi> permutes {0..<n}}. weight f \<pi>)"
     unfolding Z_inj_def unfolding F_inj_def sum.cartesian_product ..
   also have "... =  (\<Sum>y\<in>F_strict. \<Sum>f\<in>{x \<in> F_inj. strict_from_inj n x = y}.
     sum (weight f) {\<pi>. \<pi> permutes {0..<n}})" unfolding sum_rw ..
   also have "... =  (\<Sum>y\<in>F_strict. \<Sum>(f,\<pi>)\<in>({x \<in> F_inj. strict_from_inj n x = y}
   \<times> {\<pi>. \<pi> permutes {0..<n}}). weight f \<pi>)"
     unfolding F_inj_def sum.cartesian_product ..
   also have "... = sum (\<lambda>g. sum (\<lambda>(f,\<pi>). weight f \<pi>) (Z_good g)) F_strict"
     using Z_good_alt by auto
   also have "... = ?rhs" unfolding gather_by_strictness by simp
   finally show ?thesis .
 qed
 
 
 lemma Cauchy_Binet:
   "det (A*B) = (\<Sum>I\<in>{I. I\<subseteq>{0..<m} \<and> card I=n}. det (submatrix A UNIV I) * det (submatrix B I UNIV))"
 proof -
   let ?f="(\<lambda>I. (\<lambda>i. if i<n then sorted_list_of_set I ! i else i))"
   let ?setI = "{I. I \<subseteq> {0..<m} \<and> card I = n}"
   have inj_on: "inj_on ?f ?setI"
   proof (rule inj_onI)
     fix I J assume I: "I \<in> ?setI" and J: "J \<in> ?setI" and fI_fJ: "?f I = ?f J"
     have "x \<in> J" if x: "x \<in> I" for x
       by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
           sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
     moreover have "x \<in> I" if x: "x \<in> J" for x
       by (metis (mono_tags) fI_fJ I J distinct_card in_set_conv_nth mem_Collect_eq
           sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite x)
     ultimately show "I = J" by auto
   qed
   have rw: "?f I ` {0..<n} = I" if I: "I \<in> ?setI" for I
   proof -
     have "sorted_list_of_set I ! xa \<in> I" if "xa < n" for xa
       by (metis (mono_tags, lifting) I distinct_card distinct_sorted_list_of_set mem_Collect_eq
           nth_mem set_sorted_list_of_set subset_eq_atLeast0_lessThan_finite that)
     moreover have "\<exists>xa\<in>{0..<n}. x = sorted_list_of_set I ! xa" if x: "x\<in>I" for x
       by (metis (full_types) x I atLeast0LessThan distinct_card in_set_conv_nth mem_Collect_eq
          lessThan_iff sorted_list_of_set(1) sorted_list_of_set(3) subset_eq_atLeast0_lessThan_finite)
     ultimately show ?thesis unfolding image_def by auto
   qed
   have f_setI: "?f` ?setI = F_strict"
   proof -
     have "sorted_list_of_set I ! xa < m" if I: "I \<subseteq> {0..<m}" and "n = card I" and "xa < card I"
         for I xa
       by (metis I \<open>xa < card I\<close> atLeast0LessThan distinct_card finite_atLeastLessThan lessThan_iff
           pick_in_set_le rev_finite_subset sorted_list_of_set(1)
           sorted_list_of_set(3) sorted_list_of_set_eq_pick subsetCE)
     moreover have "strict_mono_on (\<lambda>i. if i < card I then sorted_list_of_set I ! i else i) {0..<card I}"
       if "I \<subseteq> {0..<m}" and "n = card I" for I
       by (smt \<open>I \<subseteq> {0..<m}\<close> atLeastLessThan_iff distinct_card finite_atLeastLessThan pick_mono_le
           rev_finite_subset sorted_list_of_set(1) sorted_list_of_set(3)
           sorted_list_of_set_eq_pick strict_mono_on_def)
     moreover have "x \<in> ?f ` {I. I \<subseteq> {0..<m} \<and> card I = n}"
       if x1: "x \<in> {0..<n} \<rightarrow> {0..<m}" and x2: "\<forall>i. \<not> i < n \<longrightarrow> x i = i"
       and s: "strict_mono_on x {0..<n}" for x
     proof -
       have inj_x: "inj_on x {0..<n}"
         using s strict_mono_on_imp_inj_on by blast
       hence card_xn: "card (x ` {0..<n}) = n" by (simp add: card_image)
       have x_eq: "x = (\<lambda>i. if i < n then sorted_list_of_set (x ` {0..<n}) ! i else i)"
         unfolding fun_eq_iff
         using nth_strict_mono_on s using x2 by auto
       show ?thesis
         unfolding image_def by (auto, rule exI[of _"x`{0..<n}"], insert card_xn x1 x_eq, auto)
     qed
     ultimately show ?thesis unfolding F_strict_def by auto
   qed
   let ?g = "(\<lambda>f. det (submatrix A UNIV (f`{0..<n})) * det(submatrix B (f`{0..<n}) UNIV))"
   have "det (A*B) = sum ((\<lambda>f. det (submatrix A UNIV (f ` {0..<n}))
     * det (submatrix B (f ` {0..<n}) UNIV)) \<circ> ?f) {I. I \<subseteq> {0..<m} \<and> card I = n}"
     unfolding Cauchy_Binet1 f_setI[symmetric] by (rule sum.reindex[OF inj_on])
   also have "... = (\<Sum>I\<in>{I. I\<subseteq>{0..<m} \<and> card I=n}.det(submatrix A UNIV I)*det(submatrix B I UNIV))"
     by (rule sum.cong, insert rw, auto)
   finally show ?thesis .
 qed
 end
 
 end
diff --git a/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy b/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy
--- a/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy
+++ b/thys/Smith_Normal_Form/SNF_Missing_Lemmas.thy
@@ -1,1168 +1,1168 @@
 (*
   Author: Jose Divasón
   Email:  jose.divason@unirioja.es
 *)
 
 section \<open>Missing results\<close>
 
 theory SNF_Missing_Lemmas
   imports
     Hermite.Hermite
     Mod_Type_Connect
     Jordan_Normal_Form.DL_Rank_Submatrix
     "List-Index.List_Index"
 begin
 
 text \<open>This theory presents some missing lemmas that are required for the Smith normal form
 development. Some of them could be added to different AFP entries, such as the Jordan Normal
 Form AFP entry by Ren\'e Thiemann and Akihisa Yamada.
 
 However, not all the lemmas can be added directly, since some imports are required.\<close>
 
 hide_const (open) C
 hide_const (open) measure
 
 subsection \<open>Miscellaneous lemmas\<close>
 
 lemma sum_two_rw: "(\<Sum>i = 0..<2. f i) = (\<Sum>i \<in> {0,1::nat}. f i)"
   by (rule sum.cong, auto)
 
 lemma sum_common_left:
   fixes f::"'a \<Rightarrow> 'b::comm_ring_1"
   assumes "finite A"
   shows "sum (\<lambda>i. c * f i) A = c * sum f A"
   by (simp add: mult_hom.hom_sum)
 
 lemma prod3_intro:
   assumes "fst A = a" and "fst (snd A) = b" and "snd (snd A) = c"
   shows "A = (a,b,c)" using assms by auto
 
 
 subsection \<open>Transfer rules for the HMA\_Connect file of the Perron-Frobenius development\<close>
 
 hide_const (open) HMA_M HMA_I to_hma\<^sub>m from_hma\<^sub>m
 hide_fact (open) from_hma\<^sub>m_def from_hma_to_hma\<^sub>m HMA_M_def HMA_I_def dim_row_transfer_rule
                   dim_col_transfer_rule
 
 context
   includes lifting_syntax
 begin
 
 lemma HMA_invertible_matrix[transfer_rule]:
   "((HMA_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'n ^ 'n \<Rightarrow> _) ===> (=)) invertible_mat invertible"
 proof (intro rel_funI, goal_cases)
   case (1 x y)
   note rel_xy[transfer_rule] = "1"
   have eq_dim: "dim_col x = dim_row x"
     using HMA_Connect.dim_col_transfer_rule HMA_Connect.dim_row_transfer_rule rel_xy
     by fastforce
   moreover have "\<exists>A'. y ** A' = Finite_Cartesian_Product.mat 1 \<and> A' ** y = Finite_Cartesian_Product.mat 1"
     if xB: "x * B = 1\<^sub>m (dim_row x)" and Bx: "B * x = 1\<^sub>m (dim_row B)" for B
   proof -
     let ?A' = "HMA_Connect.to_hma\<^sub>m B:: 'a :: comm_ring_1 ^ 'n ^ 'n"
     have rel_BA[transfer_rule]: "HMA_M B ?A'"
       by (metis (no_types, lifting) Bx HMA_M_def eq_dim carrier_mat_triv dim_col_mat(1)
           from_hma\<^sub>m_def from_hma_to_hma\<^sub>m index_mult_mat(3) index_one_mat(3) rel_xy xB)
     have [simp]: "dim_row B = CARD('n)" using dim_row_transfer_rule rel_BA by blast
     have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
     have "y ** ?A' = Finite_Cartesian_Product.mat 1" using xB by (transfer, simp)
     moreover have "?A' ** y  = Finite_Cartesian_Product.mat 1" using Bx by (transfer, simp)
     ultimately show ?thesis by blast
   qed
   moreover have "\<exists>B. x * B = 1\<^sub>m (dim_row x) \<and> B * x = 1\<^sub>m (dim_row B)"
     if yA: "y ** A' = Finite_Cartesian_Product.mat 1" and Ay: "A' ** y = Finite_Cartesian_Product.mat 1" for A'
   proof -
     let ?B = "(from_hma\<^sub>m A')"
     have [simp]: "dim_row x = CARD('n)" using dim_row_transfer_rule rel_xy by blast
     have [transfer_rule]: "HMA_M ?B A'" by (simp add: HMA_M_def)
     hence [simp]: "dim_row ?B = CARD('n)" using dim_row_transfer_rule by auto
     have "x * ?B = 1\<^sub>m (dim_row x)" using yA by (transfer', auto)
     moreover have "?B * x = 1\<^sub>m (dim_row ?B)" using Ay by (transfer', auto)
     ultimately show ?thesis by auto
   qed
   ultimately show ?case unfolding invertible_mat_def invertible_def inverts_mat_def by auto
 qed
 end
 
 subsection \<open>Lemmas obtained from HOL Analysis using local type definitions\<close>
 
 thm Cartesian_Space.invertible_mult (*In HOL Analysis*)
 thm invertible_iff_is_unit (*In HOL Analysis*)
 thm det_non_zero_imp_unit (*In JNF, but only for fields*)
 thm mat_mult_left_right_inverse (*In JNF, but only for fields*)
 
 lemma invertible_mat_zero:
   assumes A: "A \<in> carrier_mat 0 0"
   shows "invertible_mat A"
   using A unfolding invertible_mat_def inverts_mat_def one_mat_def times_mat_def scalar_prod_def
     Matrix.row_def col_def carrier_mat_def
   by (auto, metis (no_types, lifting) cong_mat not_less_zero)
 
 lemma invertible_mult_JNF:
   fixes A::"'a::comm_ring_1 mat"
   assumes A: "A\<in>carrier_mat n n" and B: "B\<in>carrier_mat n n"
     and inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
 shows "invertible_mat (A*B)"
 proof (cases "n = 0")
   case True
   then show ?thesis using assms
     by (simp add: invertible_mat_zero)
 next
   case False
   then show ?thesis using
       invertible_mult[where ?'a="'a::comm_ring_1", where ?'b="'n::finite", where ?'c="'n::finite",
       where ?'d="'n::finite", untransferred, cancel_card_constraint, OF assms] by auto
 qed
 
 lemma invertible_iff_is_unit_JNF:
   assumes A: "A \<in> carrier_mat n n"
   shows "invertible_mat A \<longleftrightarrow> (Determinant.det A) dvd 1"
 proof (cases "n=0")
   case True
   then show ?thesis using det_dim_zero invertible_mat_zero A by auto
 next
   case False
   then show ?thesis using invertible_iff_is_unit[untransferred, cancel_card_constraint] A by auto
 qed
 
 
 subsection \<open>Lemmas about matrices, submatrices and determinants\<close>
 
 (*This is a generalization of thm mat_mult_left_right_inverse*)
 thm mat_mult_left_right_inverse
 lemma mat_mult_left_right_inverse:
   fixes A :: "'a::comm_ring_1 mat"
   assumes A: "A \<in> carrier_mat n n"
     and B: "B \<in> carrier_mat n n" and AB: "A * B = 1\<^sub>m n"
   shows "B * A = 1\<^sub>m n"
 proof -
   have "Determinant.det (A * B) = Determinant.det (1\<^sub>m n)" using AB by auto
   hence "Determinant.det A * Determinant.det B = 1"
     using Determinant.det_mult[OF A B] det_one by auto
   hence det_A: "(Determinant.det A) dvd 1" and det_B: "(Determinant.det B) dvd 1"
     using dvd_triv_left dvd_triv_right by metis+
   hence inv_A: "invertible_mat A" and inv_B: "invertible_mat B"
     using A B invertible_iff_is_unit_JNF by blast+
   obtain B' where inv_BB': "inverts_mat B B'" and inv_B'B: "inverts_mat B' B"
     using inv_B unfolding invertible_mat_def by auto
   have B'_carrier: "B' \<in> carrier_mat n n"
     by (metis B inv_B'B inv_BB' carrier_matD(1) carrier_matD(2) carrier_mat_triv
         index_mult_mat(3) index_one_mat(3) inverts_mat_def)
   have "B * A * B = B" using A AB B by auto
   hence "B * A * (B * B') = B * B'"
     by (smt A AB B B'_carrier assoc_mult_mat carrier_matD(1) inv_BB' inverts_mat_def one_carrier_mat)
   thus ?thesis
     by (metis A B carrier_matD(1) carrier_matD(2) index_mult_mat(3) inv_BB'
         inverts_mat_def right_mult_one_mat')
 qed
 
 context comm_ring_1
 begin
 
 lemma col_submatrix_UNIV:
 assumes "j < card {i. i < dim_col A \<and> i \<in> J}"
 shows "col (submatrix A UNIV J) j = col A (pick J j)"
 proof (rule eq_vecI)
   show dim_eq:"dim_vec (col (submatrix A UNIV J) j) = dim_vec (col A (pick J j))"
     by (simp add: dim_submatrix(1))
   fix i assume "i < dim_vec (col A (pick J j))"
   show "col (submatrix A UNIV J) j $v i = col A (pick J j) $v i"
     by (smt Collect_cong assms col_def dim_col dim_eq dim_submatrix(1)
         eq_vecI index_vec pick_UNIV submatrix_index)
 qed
 
 lemma submatrix_split2: "submatrix A I J = submatrix (submatrix A I UNIV) UNIV J" (is "?lhs = ?rhs")
 proof (rule eq_matI)
   show dr: "dim_row ?lhs = dim_row ?rhs"
     by (simp add: dim_submatrix(1))
   show dc: "dim_col ?lhs = dim_col ?rhs"
     by (simp add: dim_submatrix(2))
   fix i j assume i: "i < dim_row ?rhs"
     and j: "j < dim_col ?rhs"
   have "?rhs $$ (i, j) = (submatrix A I UNIV) $$ (pick UNIV i, pick J j)"
   proof (rule submatrix_index)
     show "i < card {i. i < dim_row (submatrix A I UNIV) \<and> i \<in> UNIV}"
       by (metis (full_types) dim_submatrix(1) i)
     show "j < card {j. j < dim_col (submatrix A I UNIV) \<and> j \<in> J}"
       by (metis (full_types) dim_submatrix(2) j)
   qed
   also have "... = A $$ (pick I (pick UNIV i), pick UNIV (pick J j))"
   proof (rule submatrix_index)
     show "pick UNIV i < card {i. i < dim_row A \<and> i \<in> I}"
       by (metis (full_types) dr dim_submatrix(1) i pick_UNIV)
     show "pick J j < card {j. j < dim_col A \<and> j \<in> UNIV}"
       by (metis (full_types) dim_submatrix(2) j pick_le)
   qed
   also have "... = ?lhs $$ (i,j)"
   proof (unfold pick_UNIV, rule submatrix_index[symmetric])
     show "i < card {i. i < dim_row A \<and> i \<in> I}"
       by (metis (full_types) dim_submatrix(1) dr i)
     show "j < card {j. j < dim_col A \<and> j \<in> J}"
       by (metis (full_types) dim_submatrix(2) dc j)
   qed
   finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" ..
 qed
 
 lemma submatrix_mult:
   "submatrix (A*B) I J = submatrix A I UNIV * submatrix B UNIV J" (is "?lhs = ?rhs")
 proof (rule eq_matI)
   show "dim_row ?lhs = dim_row ?rhs" unfolding submatrix_def by auto
   show "dim_col ?lhs = dim_col ?rhs" unfolding submatrix_def by auto
   fix i j assume i: "i < dim_row ?rhs" and j: "j < dim_col ?rhs"
   have i1: "i < card {i. i < dim_row (A * B) \<and> i \<in> I}"
     by (metis (full_types) dim_submatrix(1) i index_mult_mat(2))
   have j1: "j < card {j. j < dim_col (A * B) \<and> j \<in> J}"
     by (metis dim_submatrix(2) index_mult_mat(3) j)
   have pi: "pick I i < dim_row A" using i1 pick_le by auto
   have pj: "pick J j < dim_col B" using j1 pick_le by auto
   have row_rw: "Matrix.row (submatrix A I UNIV) i = Matrix.row A (pick I i)"
     using i1 row_submatrix_UNIV by auto
   have col_rw: "col (submatrix B UNIV J) j = col B (pick J j)" using j1 col_submatrix_UNIV by auto
   have "?lhs $$ (i,j) =  (A*B) $$ (pick I i, pick J j)" by (rule submatrix_index[OF i1 j1])
   also have "... = Matrix.row A (pick I i) \<bullet> col B (pick J j)" by (rule index_mult_mat(1)[OF pi pj])
   also have "... = Matrix.row (submatrix A I UNIV) i \<bullet> col (submatrix B UNIV J) j"
     using row_rw col_rw by simp
   also have "... = (?rhs) $$ (i,j)" by (rule index_mult_mat[symmetric], insert i j, auto)
   finally show "?lhs $$ (i, j) = ?rhs $$ (i, j)" .
 qed
 
 lemma det_singleton:
   assumes A: "A \<in> carrier_mat 1 1"
   shows "det A = A $$ (0,0)"
   using A unfolding carrier_mat_def Determinant.det_def by auto
 
 lemma submatrix_singleton_index:
   assumes A: "A \<in> carrier_mat n m"
     and an: "a < n" and bm: "b < m"
     shows "submatrix A {a} {b} $$ (0,0) = A $$ (a,b)"
 proof -
   have a: "{i. i = a \<and> i < dim_row A} = {a}" using an A unfolding carrier_mat_def by auto
   have b: "{i. i = b \<and> i < dim_col A} = {b}" using bm A unfolding carrier_mat_def by auto
   have "submatrix A {a} {b} $$ (0,0) = A $$ (pick {a} 0,pick {b} 0)"
     by (rule submatrix_index, insert a b, auto)
   moreover have "pick {a} 0 = a" by (auto, metis (full_types) LeastI)
   moreover have "pick {b} 0 = b" by (auto, metis (full_types) LeastI)
   ultimately show ?thesis by simp
 qed
 end
 
 lemma det_not_inj_on:
   assumes not_inj_on: "\<not> inj_on f {0..<n}"
   shows "det (mat\<^sub>r n n (\<lambda>i. Matrix.row B (f i))) = 0"
 proof -
   obtain i j where i: "i<n" and j: "j<n" and fi_fj: "f i = f j" and ij: "i\<noteq>j"
     using not_inj_on unfolding inj_on_def by auto
   show ?thesis
   proof (rule det_identical_rows[OF _ ij i j])
     let ?B="(mat\<^sub>r n n (\<lambda>i. row B (f i)))"
     show "row ?B i = row ?B j"
     proof (rule eq_vecI, auto)
       fix ia assume ia: "ia < n"
       have "row ?B i $ ia = ?B $$ (i, ia)" by (rule index_row(1), insert i ia, auto)
       also have "... = ?B $$ (j, ia)" by (simp add: fi_fj i ia j)
       also have "... = row ?B j $ ia" by (rule index_row(1)[symmetric], insert j ia, auto)
       finally show "row ?B i $ ia = row (mat\<^sub>r n n (\<lambda>i. row B (f i))) j $ ia" by simp
     qed
     show "mat\<^sub>r n n (\<lambda>i. Matrix.row B (f i)) \<in> carrier_mat n n" by auto
   qed
 qed
 
 
 
 lemma mat_row_transpose: "(mat\<^sub>r nr nc f)\<^sup>T = mat nc nr (\<lambda>(i,j). vec_index (f j) i)"
   by (rule eq_matI, auto)
 
 
 lemma obtain_inverse_matrix:
   assumes A: "A \<in> carrier_mat n n" and i: "invertible_mat A"
   obtains B where "inverts_mat A B" and "inverts_mat B A" and "B \<in> carrier_mat n n"
 proof -
   have "(\<exists>B. inverts_mat A B \<and> inverts_mat B A)" using i unfolding invertible_mat_def by auto
   from this obtain B where AB: "inverts_mat A B" and BA: "inverts_mat B A" by auto
   moreover have "B \<in> carrier_mat n n" using A AB BA unfolding carrier_mat_def inverts_mat_def
     by (auto, metis index_mult_mat(3) index_one_mat(3))+
   ultimately show ?thesis using that by blast
 qed
 
 
 lemma invertible_mat_smult_mat:
   fixes A :: "'a::comm_ring_1 mat"
   assumes inv_A: "invertible_mat A" and k: "k dvd 1"
   shows "invertible_mat (k \<cdot>\<^sub>m A)"
 proof -
   obtain n where A: "A \<in> carrier_mat n n" using inv_A unfolding invertible_mat_def by auto
   have det_dvd_1: "Determinant.det A dvd 1" using inv_A invertible_iff_is_unit_JNF[OF A] by auto
   have "Determinant.det (k \<cdot>\<^sub>m A) = k ^ dim_col A * Determinant.det A" by simp
   also have "... dvd 1" by (rule unit_prod, insert k det_dvd_1 dvd_power_same, force+)
   finally show ?thesis using invertible_iff_is_unit_JNF by (metis A smult_carrier_mat)
 qed
 
 lemma invertible_mat_one[simp]: "invertible_mat (1\<^sub>m n)"
   unfolding invertible_mat_def using inverts_mat_def by fastforce
 
 lemma four_block_mat_dim0:
   assumes A: "A \<in> carrier_mat n n"
   and B: "B \<in> carrier_mat n 0"
   and C: "C \<in> carrier_mat 0 n"
   and D: "D \<in> carrier_mat 0 0"
 shows "four_block_mat A B C D = A"
   unfolding four_block_mat_def using assms by auto
 
 
 lemma det_four_block_mat_lower_right_id:
   assumes A: "A \<in> carrier_mat m m"
 and B: "B = 0\<^sub>m m (n-m)"
 and C: "C = 0\<^sub>m (n-m) m"
 and D: "D = 1\<^sub>m (n-m)"
 and "n>m"
 shows "Determinant.det (four_block_mat A B C D) = Determinant.det A"
   using assms
 proof (induct n arbitrary: A B C D)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   let ?block = "(four_block_mat A B C D)"
   let ?B = "Matrix.mat m (n-m) (\<lambda>(i,j). 0)"
   let ?C = "Matrix.mat (n-m) m (\<lambda>(i,j). 0)"
   let ?D = "1\<^sub>m (n-m)"
   have mat_eq: "(mat_delete ?block n n) = four_block_mat A ?B ?C ?D" (is "?lhs = ?rhs")
   proof (rule eq_matI)
     fix i j assume i: "i < dim_row (four_block_mat A ?B ?C ?D)"
       and j: "j < dim_col (four_block_mat A ?B ?C ?D)"
     let ?f = " (if i < dim_row A then if j < dim_col A then A $$ (i, j) else B $$ (i, j - dim_col A)
      else if j < dim_col A then C $$ (i - dim_row A, j) else D $$ (i - dim_row A, j - dim_col A))"
     let ?g = "(if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?B $$ (i, j - dim_col A)
      else if j < dim_col A then ?C $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
     have "(mat_delete ?block n n) $$ (i,j) = ?block $$ (i,j)"
       using i j Suc.prems unfolding mat_delete_def by auto
     also have "... = ?f"
       by (rule index_mat_four_block, insert Suc.prems i j, auto)
     also have "... = ?g" using i j Suc.prems by auto
     also have "... = four_block_mat A ?B ?C ?D $$ (i,j)"
       by (rule index_mat_four_block[symmetric], insert Suc.prems i j, auto)
     finally show "?lhs $$ (i,j) = ?rhs $$ (i,j)" .
   qed (insert Suc.prems, auto)
   have nn_1: "?block $$ (n, n) = 1" using Suc.prems by auto
   have rw0: "(\<Sum>i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n) = 0"
   proof (rule sum.neutral, rule)
     fix x assume x: "x \<in> {..<n}"
     have block_index: "?block $$ (x,n) = (if x < dim_row A then if n < dim_col A then A $$ (x, n)
       else B $$ (x, n - dim_col A) else if n < dim_col A then C $$ (x - dim_row A, n)
       else D $$ (x - dim_row A, n - dim_col A))"
       by (rule index_mat_four_block, insert Suc.prems x, auto)
     have "four_block_mat A B C D $$ (x,n) = 0" using x Suc.prems by auto
     thus "four_block_mat A B C D $$ (x, n) * Determinant.cofactor (four_block_mat A B C D) x n = 0"
       by simp
   qed
   have "Determinant.det ?block = (\<Sum>i<Suc n. ?block $$ (i, n) * Determinant.cofactor ?block i n)"
     by (rule laplace_expansion_column, insert Suc.prems, auto)
   also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n
     + (\<Sum>i<n. ?block $$ (i,n) * Determinant.cofactor ?block i n)"
     by simp
   also have "... = ?block $$ (n, n) * Determinant.cofactor ?block n n" using rw0 by auto
   also have "... = Determinant.cofactor ?block n n" using nn_1 by simp
   also have "... = Determinant.det (mat_delete ?block n n)" unfolding cofactor_def by auto
   also have "... = Determinant.det (four_block_mat A ?B ?C ?D)" using mat_eq by simp
   also have "... = Determinant.det A" (is "Determinant.det ?lhs = Determinant.det ?rhs")
   proof (cases "n = m")
     case True
     have "?lhs = ?rhs" by (rule four_block_mat_dim0, insert Suc.prems True, auto)
     then show ?thesis by simp
   next
     case False
     show ?thesis by (rule Suc.hyps, insert Suc.prems False, auto)
   qed
   finally show ?case .
 qed
 
 
 lemma mult_eq_first_row:
   assumes A: "A \<in> carrier_mat 1 n"
   and B: "B \<in> carrier_mat m n"
   and m0: "m \<noteq> 0"
   and r: "Matrix.row A 0 = Matrix.row B 0"
 shows "Matrix.row (A * V) 0 = Matrix.row (B * V) 0"
 proof (rule eq_vecI)
   show "dim_vec (Matrix.row (A * V) 0) = dim_vec (Matrix.row (B * V) 0)" using A B r by auto
   fix i assume i: "i < dim_vec (Matrix.row (B * V) 0)"
   have "Matrix.row (A * V) 0 $v i = (A * V) $$ (0,i)" by (rule index_row, insert i A, auto)
   also have "... = Matrix.row A 0 \<bullet> col V i" by (rule index_mult_mat, insert A i, auto)
   also have "... = Matrix.row B 0 \<bullet> col V i" using r by auto
   also have "... = (B * V) $$ (0,i)" by (rule index_mult_mat[symmetric], insert m0 B i, auto)
   also have "... = Matrix.row (B * V) 0 $v i" by (rule index_row[symmetric], insert i B m0, auto)
   finally show "Matrix.row (A * V) 0 $v i = Matrix.row (B * V) 0 $v i" .
 qed
 
 
 lemma smult_mat_mat_one_element:
   assumes A: "A \<in> carrier_mat 1 1" and B: "B \<in> carrier_mat 1 n"
   shows "A * B = A $$ (0,0) \<cdot>\<^sub>m B"
 proof (rule eq_matI)
   fix i j assume i: "i < dim_row (A $$ (0, 0) \<cdot>\<^sub>m B)" and j: "j < dim_col (A $$ (0, 0) \<cdot>\<^sub>m B)"
   have i0: "i = 0" using A B i by auto
   have "(A * B) $$ (i, j) =  Matrix.row A i \<bullet> col B j"
     by (rule index_mult_mat, insert i j A B, auto)
   also have "... =  Matrix.row A i $v 0 * col B j $v 0" unfolding scalar_prod_def using B by auto
   also have "... = A$$(i,i) * B$$(i,j)" using A i i0 j by auto
   also have "... = (A $$ (i, i) \<cdot>\<^sub>m B) $$ (i, j)"
     unfolding i by (rule index_smult_mat[symmetric], insert i j B, auto)
   finally show "(A * B) $$ (i, j) = (A $$ (0, 0) \<cdot>\<^sub>m B) $$ (i, j)" using i0 by simp
 qed (insert A B, auto)
 
 lemma determinant_one_element:
   assumes A: "A \<in> carrier_mat 1 1" shows "Determinant.det A = A $$ (0,0)"
 proof -
   have "Determinant.det A = prod_list (diag_mat A)"
     by (rule det_upper_triangular[OF _ A], insert A, unfold upper_triangular_def, auto)
   also have "... = A $$ (0,0)" using A unfolding diag_mat_def by auto
   finally show ?thesis .
 qed
 
 
 
 lemma invertible_mat_transpose:
   assumes inv_A: "invertible_mat (A::'a::comm_ring_1 mat)"
   shows "invertible_mat A\<^sup>T"
 proof -
   obtain n where A: "A \<in> carrier_mat n n"
     using inv_A unfolding invertible_mat_def square_mat.simps by auto
   hence At: "A\<^sup>T \<in> carrier_mat n n" by simp
   have "Determinant.det A\<^sup>T = Determinant.det A"
     by (metis Determinant.det_def Determinant.det_transpose carrier_matI
         index_transpose_mat(2) index_transpose_mat(3))
   also have "... dvd 1" using invertible_iff_is_unit_JNF[OF A] inv_A by simp
   finally show ?thesis  using invertible_iff_is_unit_JNF[OF At] by auto
 qed
 
 lemma dvd_elements_mult_matrix_left:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
   and P: "P \<in> carrier_mat m m"
   and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
   shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (P*A)$$(i,j))"
 proof -
   have "x dvd (P * A) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
   proof -
     have "(P * A) $$ (i, j) =  (\<Sum>ia = 0..<m. Matrix.row P i $v ia * col A j $v ia)"
       unfolding times_mat_def scalar_prod_def using A P j i by auto
     also have "... = (\<Sum>ia = 0..<m. Matrix.row P i $v ia *  A $$ (ia,j))"
       by (rule sum.cong, insert A j, auto)
     also have "x dvd ..." using x by (meson atLeastLessThan_iff dvd_mult dvd_sum j)
     finally show ?thesis .
   qed
   thus ?thesis by auto
 qed
 
 
 lemma dvd_elements_mult_matrix_right:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
   and Q: "Q \<in> carrier_mat n n"
   and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
   shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (A*Q)$$(i,j))"
 proof -
   have "x dvd (A*Q) $$ (i, j)" if i: "i < m" and j: "j < n" for i j
   proof -
     have "(A*Q) $$ (i, j) =  (\<Sum>ia = 0..<n. Matrix.row A i $v ia * col Q j $v ia)"
       unfolding times_mat_def scalar_prod_def using A Q j i by auto
     also have "... = (\<Sum>ia = 0..<n. A $$ (i, ia) * col Q j $v ia)"
       by (rule sum.cong, insert A Q i, auto)
     also have "x dvd ..." using x
       by (meson atLeastLessThan_iff dvd_mult2 dvd_sum i)
     finally show ?thesis .
   qed
   thus ?thesis by auto
 qed
 
 
 lemma dvd_elements_mult_matrix_left_right:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m n"
   and P: "P \<in> carrier_mat m m"
   and Q: "Q \<in> carrier_mat n n"
   and x: "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd A$$(i,j))"
 shows "(\<forall>i j. i<m \<and> j<n \<longrightarrow> x dvd (P*A*Q)$$(i,j))"
   using dvd_elements_mult_matrix_left[OF A P x]
   by (meson P A Q dvd_elements_mult_matrix_right mult_carrier_mat)
 
 
 definition append_cols :: "'a :: zero mat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" (infixr "@\<^sub>c" 65)where
   "A @\<^sub>c B = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B))"
 
 lemma append_cols_carrier[simp,intro]:
   "A \<in> carrier_mat n a \<Longrightarrow> B \<in> carrier_mat n b \<Longrightarrow> (A @\<^sub>c B) \<in> carrier_mat n (a+b)"
   unfolding append_cols_def by auto
 
 lemma append_cols_mult_left:
   assumes A: "A \<in> carrier_mat n a"
   and B: "B \<in> carrier_mat n b"
   and P: "P \<in> carrier_mat n n"
 shows "P * (A @\<^sub>c B) = (P*A) @\<^sub>c (P*B)"
 proof -
   let ?P = "four_block_mat P (0\<^sub>m n 0) (0\<^sub>m 0 n) (0\<^sub>m 0 0)"
   have "P = ?P" by (rule eq_matI, auto)
   hence "P * (A @\<^sub>c B) = ?P * (A @\<^sub>c B)" by simp
   also have "?P * (A @\<^sub>c B) = four_block_mat (P * A + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col A))
   (P * B + 0\<^sub>m n 0 * 0\<^sub>m 0 (dim_col B)) (0\<^sub>m 0 n * A + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col A))
   (0\<^sub>m 0 n * B + 0\<^sub>m 0 0 * 0\<^sub>m 0 (dim_col B))" unfolding append_cols_def
     by (rule mult_four_block_mat, insert A B P, auto)
   also have "... = four_block_mat (P * A) (P * B) (0\<^sub>m 0 (dim_col (P*A))) (0\<^sub>m 0 (dim_col (P*B)))"
     by (rule cong_four_block_mat, insert P, auto)
   also have "... = (P*A) @\<^sub>c (P*B)" unfolding append_cols_def by auto
   finally show ?thesis .
 qed
 
 lemma append_cols_mult_right_id:
   assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n 1"
   and B: "B \<in> carrier_mat n (m-1)"
   and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
   and D: "D \<in> carrier_mat (m-1) (m-1)"
 shows "(A @\<^sub>c B) * C = A @\<^sub>c (B * D)"
 proof -
   let ?C = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
   have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto
   also have "... = four_block_mat A B (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col B)) * ?C"
     unfolding append_cols_def by auto
   also have "... = four_block_mat (A * 1\<^sub>m 1 + B * 0\<^sub>m (m - 1) 1) (A * 0\<^sub>m 1 (m - 1) + B * D)
     (0\<^sub>m 0 (dim_col A) * 1\<^sub>m 1 + 0\<^sub>m 0 (dim_col B) * 0\<^sub>m (m - 1) 1)
     (0\<^sub>m 0 (dim_col A) * 0\<^sub>m 1 (m - 1) + 0\<^sub>m 0 (dim_col B) * D)"
     by (rule mult_four_block_mat, insert assms, auto)
   also have "... = four_block_mat A (B * D) (0\<^sub>m 0 (dim_col A)) (0\<^sub>m 0 (dim_col (B*D)))"
     by (rule cong_four_block_mat, insert assms, auto)
   also have "... = A @\<^sub>c (B * D)" unfolding append_cols_def by auto
   finally show ?thesis .
 qed
 
 
 lemma append_cols_mult_right_id2:
  assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n a"
    and B: "B \<in> carrier_mat n b"
    and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
    and D: "D \<in> carrier_mat a a"
 shows "(A @\<^sub>c B) * C = (A * D) @\<^sub>c B"
 proof -
   let ?C = "four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
   have "(A @\<^sub>c B) * C = (A @\<^sub>c B) * ?C" unfolding C by auto
   also have "... = four_block_mat A B (0\<^sub>m 0 a) (0\<^sub>m 0 b) * ?C"
     unfolding append_cols_def using A B by auto
   also have "... = four_block_mat (A * D + B * 0\<^sub>m b a) (A * 0\<^sub>m a b + B * 1\<^sub>m b)
     (0\<^sub>m 0 a * D + 0\<^sub>m 0 b * 0\<^sub>m b a) (0\<^sub>m 0 a * 0\<^sub>m a b + 0\<^sub>m 0 b * 1\<^sub>m b)"
     by (rule mult_four_block_mat, insert A B C D, auto)
   also have "... = four_block_mat (A * D) B (0\<^sub>m 0 (dim_col (A*D))) (0\<^sub>m 0 (dim_col B))"
     by (rule cong_four_block_mat, insert assms, auto)
   also have "... = (A * D) @\<^sub>c B" unfolding append_cols_def by auto
   finally show ?thesis .
 qed
 
 
 lemma append_cols_nth:
   assumes A: "A \<in> carrier_mat n a"
   and B: "B \<in> carrier_mat n b"
   and i: "i<n" and j: "j < a + b"
 shows "(A @\<^sub>c B) $$ (i, j) = (if j < dim_col A then A $$(i,j) else B$$(i,j-a))" (is "?lhs = ?rhs")
 proof -
   let ?C = "(0\<^sub>m 0 (dim_col A))"
   let ?D = "(0\<^sub>m 0 (dim_col B))"
   have i2: "i < dim_row A + dim_row ?D" using i A by auto
   have j2: "j < dim_col A + dim_col (0\<^sub>m 0 (dim_col B))" using j B A by auto
   have "(A @\<^sub>c B) $$ (i, j) = four_block_mat A B ?C ?D $$ (i, j)"
     unfolding append_cols_def by auto
   also have "... = (if i < dim_row A then if j < dim_col A then A $$ (i, j)
   else B $$ (i, j - dim_col A) else if j < dim_col A then ?C $$ (i - dim_row A, j)
   else 0\<^sub>m 0 (dim_col B) $$ (i - dim_row A, j - dim_col A))"
     by (rule index_mat_four_block(1)[OF i2 j2])
   also have "... = ?rhs" using i A by auto
   finally show ?thesis .
 qed
 
 lemma append_cols_split:
   assumes d: "dim_col A > 0"
   shows "A = mat_of_cols (dim_row A) [col A 0] @\<^sub>c
              mat_of_cols (dim_row A) (map (col A) [1..<dim_col A])" (is "?lhs = ?A1 @\<^sub>c ?A2")
 proof (rule eq_matI)
   fix i j assume i: "i < dim_row (?A1 @\<^sub>c ?A2)" and j: "j < dim_col (?A1 @\<^sub>c ?A2)"
   have "(?A1 @\<^sub>c ?A2) $$ (i, j) = (if j < dim_col ?A1 then ?A1 $$(i,j) else ?A2$$(i,j-(dim_col ?A1)))"
     by (rule append_cols_nth, insert i j, auto simp add: append_cols_def)
   also have "... = A $$ (i,j)"
   proof (cases "j< dim_col ?A1")
     case True
     then show ?thesis
       by (metis One_nat_def Suc_eq_plus1 add.right_neutral append_cols_def col_def i
           index_mat_four_block(2) index_vec index_zero_mat(2) less_one list.size(3) list.size(4)
           mat_of_cols_Cons_index_0 mat_of_cols_carrier(2) mat_of_cols_carrier(3))
   next
     case False
     then show ?thesis
       by (metis (no_types, lifting) Suc_eq_plus1 Suc_less_eq Suc_pred add_diff_cancel_right' append_cols_def
           diff_zero i index_col index_mat_four_block(2) index_mat_four_block(3) index_zero_mat(2)
           index_zero_mat(3) j length_map length_upt linordered_semidom_class.add_diff_inverse list.size(3)
           list.size(4) mat_of_cols_carrier(2) mat_of_cols_carrier(3) mat_of_cols_index nth_map_upt
           plus_1_eq_Suc upt_0)
   qed
   finally show "A $$ (i, j) = (?A1 @\<^sub>c ?A2) $$ (i, j)" ..
 qed (auto simp add: append_cols_def d)
 
 
 lemma append_rows_nth:
   assumes A: "A \<in> carrier_mat a n"
   and B: "B \<in> carrier_mat b n"
   and i: "i<a+b" and j: "j < n"
 shows "(A @\<^sub>r B) $$ (i, j) = (if i < dim_row A then A $$(i,j) else B$$(i-a,j))" (is "?lhs = ?rhs")
 proof -
   let ?C = "(0\<^sub>m (dim_row A) 0)"
   let ?D = "(0\<^sub>m (dim_row B) 0)"
   have i2: "i < dim_row A + dim_row ?D" using i j A B by auto
   have j2: "j < dim_col A + dim_col ?D" using i j A B by auto
   have "(A @\<^sub>r B) $$ (i, j) = four_block_mat A ?C B ?D $$ (i, j)"
     unfolding append_rows_def by auto
   also have "... =  (if i < dim_row A then if j < dim_col A then A $$ (i, j) else ?C $$ (i, j - dim_col A)
    else if j < dim_col A then B $$ (i - dim_row A, j) else ?D $$ (i - dim_row A, j - dim_col A))"
     by (rule index_mat_four_block(1)[OF i2 j2])
   also have "... = ?rhs" using i A j B by auto
   finally show ?thesis .
 qed
 
 lemma append_rows_split:
   assumes k: "k\<le>dim_row A"
   shows "A = (mat_of_rows (dim_col A) [Matrix.row A i. i \<leftarrow> [0..<k]]) @\<^sub>r
              (mat_of_rows (dim_col A) [Matrix.row A i. i \<leftarrow> [k..<dim_row A]])" (is "?lhs = ?A1 @\<^sub>r ?A2")
 proof (rule eq_matI)
   have "(?A1 @\<^sub>r ?A2) \<in> carrier_mat (k + (dim_row A-k)) (dim_col A)"
     by (rule carrier_append_rows, insert k, auto)
   hence A1_A2: "(?A1 @\<^sub>r ?A2) \<in> carrier_mat (dim_row A) (dim_col A)" using k by simp
   thus "dim_row A = dim_row (?A1 @\<^sub>r ?A2)" and "dim_col A = dim_col (?A1 @\<^sub>r ?A2)" by auto
   fix i j assume i: "i < dim_row (?A1 @\<^sub>r ?A2)" and j: "j < dim_col (?A1 @\<^sub>r ?A2)"
   have "(?A1 @\<^sub>r ?A2) $$ (i, j) = (if i < dim_row ?A1 then ?A1 $$(i,j) else ?A2$$(i-(dim_row ?A1),j))"
     by (rule append_rows_nth, insert k i j, auto simp add: append_rows_def)
   also have "... = A $$ (i,j)"
   proof (cases "i<dim_row ?A1")
     case True
     then show ?thesis
       by (metis (no_types, lifting) Matrix.row_def add.left_neutral add.right_neutral append_rows_def
           index_mat(1) index_mat_four_block(3) index_vec index_zero_mat(3) j length_map length_upt
           mat_of_rows_carrier(2,3) mat_of_rows_def nth_map_upt prod.simps(2))
   next
     case False
     let ?xs = "(map (Matrix.row A) [k..<dim_row A])"
     have dim_row_A1: "dim_row ?A1 = k" by auto
     have "?A2 $$ (i-k,j) = ?xs ! (i-k) $v j"
       by (rule mat_of_rows_index, insert i k False A1_A2 j, auto)
     also have "... = A $$ (i,j)" using A1_A2 False i j by auto
     finally show ?thesis using A1_A2 False i j by auto
   qed
   finally show " A $$ (i, j) = (?A1 @\<^sub>r ?A2) $$ (i,j)" by simp
 qed
 
 
 
 lemma transpose_mat_append_rows:
  assumes A: "A \<in> carrier_mat a n" and B: "B \<in> carrier_mat b n"
  shows "(A @\<^sub>r B)\<^sup>T = A\<^sup>T @\<^sub>c B\<^sup>T"
   by (smt append_cols_def append_rows_def A B carrier_matD(1) index_transpose_mat(3)
       transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
 
 lemma transpose_mat_append_cols:
  assumes A: "A \<in> carrier_mat n a" and B: "B \<in> carrier_mat n b"
  shows "(A @\<^sub>c B)\<^sup>T = A\<^sup>T @\<^sub>r B\<^sup>T"
   by (metis Matrix.transpose_transpose A B carrier_matD(1) carrier_mat_triv
       index_transpose_mat(3) transpose_mat_append_rows)
 
 
 lemma append_rows_mult_right:
   assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat a n" and B: "B \<in> carrier_mat b n"
     and Q: "Q\<in> carrier_mat n n"
   shows "(A @\<^sub>r B) * Q = (A * Q) @\<^sub>r (B*Q)"
 proof -
   have "transpose_mat ((A @\<^sub>r B) * Q) = Q\<^sup>T * (A @\<^sub>r B)\<^sup>T"
     by (rule transpose_mult, insert A B Q, auto)
   also have "... = Q\<^sup>T * (A\<^sup>T @\<^sub>c B\<^sup>T)" using transpose_mat_append_rows assms by metis
   also have "... = Q\<^sup>T * A\<^sup>T @\<^sub>c Q\<^sup>T * B\<^sup>T"
     using append_cols_mult_left assms by (metis transpose_carrier_mat)
   also have "transpose_mat ... = (A * Q) @\<^sub>r (B*Q)"
     by (smt A B Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def Q
         carrier_mat_triv index_mult_mat(2) index_transpose_mat(2) transpose_four_block_mat
         zero_carrier_mat zero_transpose_mat)
   finally show ?thesis by simp
 qed
 
 lemma append_rows_mult_left_id:
   assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat 1 n"
   and B: "B \<in> carrier_mat (m-1) n"
   and C: "C = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) D"
   and D: "D \<in> carrier_mat (m-1) (m-1)"
 shows "C * (A @\<^sub>r B) = A @\<^sub>r (D * B)"
 proof -
   have "transpose_mat (C * (A @\<^sub>r B)) = (A @\<^sub>r B)\<^sup>T * C\<^sup>T"
     by (metis (no_types, lifting) B C D Matrix.transpose_mult append_rows_def A carrier_matD
         carrier_mat_triv index_mat_four_block(2,3) index_zero_mat(2) one_carrier_mat)
   also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" using transpose_mat_append_rows[OF A B] by auto
   also have "... = A\<^sup>T @\<^sub>c (B\<^sup>T * D\<^sup>T)" by (rule append_cols_mult_right_id, insert A B C D, auto)
   also have "transpose_mat ... = A @\<^sub>r (D * B)"
     by (smt B D Matrix.transpose_mult Matrix.transpose_transpose append_cols_def append_rows_def A
         carrier_matD(2) carrier_mat_triv index_mult_mat(3) index_transpose_mat(3)
         transpose_four_block_mat zero_carrier_mat zero_transpose_mat)
   finally show ?thesis by auto
 qed
 
 lemma append_rows_mult_left_id2:
  assumes A: "(A::'a::comm_semiring_1 mat) \<in> carrier_mat a n"
    and B: "B \<in> carrier_mat b n"
    and C: "C = four_block_mat D (0\<^sub>m a b) (0\<^sub>m b a) (1\<^sub>m b)"
    and D: "D \<in> carrier_mat a a"
  shows "C * (A @\<^sub>r B) = (D * A) @\<^sub>r B"
 proof -
   have "(C * (A @\<^sub>r B))\<^sup>T = (A @\<^sub>r B)\<^sup>T * C\<^sup>T" by (rule transpose_mult, insert assms, auto)
   also have "... = (A\<^sup>T @\<^sub>c B\<^sup>T) * C\<^sup>T" by (metis A B transpose_mat_append_rows)
   also have "... = (A\<^sup>T * D\<^sup>T @\<^sub>c B\<^sup>T)" by (rule append_cols_mult_right_id2, insert assms, auto)
   also have "...\<^sup>T = (D * A) @\<^sub>r B"
     by (metis A B D transpose_mult transpose_transpose mult_carrier_mat transpose_mat_append_rows)
   finally show ?thesis by simp
 qed
 
 lemma four_block_mat_preserves_column:
   assumes A: "(A::'a::semiring_1 mat) \<in> carrier_mat n m"
     and B: "B = four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 (m - 1)) (0\<^sub>m (m - 1) 1) C"
   and C: "C \<in> carrier_mat (m-1) (m-1)"
   and i: "i<n" and m: "0<m"
 shows "(A*B) $$ (i,0) = A $$ (i,0)"
 proof -
   let ?A1 = "mat_of_cols n [col A 0]"
   let ?A2 = "mat_of_cols n (map (col A) [1..<dim_col A])"
   have n2: "dim_row A = n" using A by auto
   have "A = ?A1 @\<^sub>c ?A2" by (rule append_cols_split[of A, unfolded n2], insert m A, auto)
   hence "A * B = (?A1 @\<^sub>c ?A2) * B" by simp
   also have "... = ?A1 @\<^sub>c (?A2 * C)" by (rule append_cols_mult_right_id[OF _ _ B C], insert A, auto)
   also have "... $$ (i,0) = ?A1 $$ (i,0)" using append_cols_nth by (simp add: append_cols_def i)
   also have "... = A $$ (i,0)"
     by (metis A i carrier_matD(1) col_def index_vec mat_of_cols_Cons_index_0)
   finally show ?thesis .
 qed
 
 
 definition "lower_triangular A = (\<forall>i j. i < j \<and> i < dim_row A \<and> j < dim_col A \<longrightarrow> A $$ (i,j) = 0)"
 
 lemma lower_triangular_index:
   assumes "lower_triangular A" "i<j" "i < dim_row A" "j < dim_col A"
   shows "A $$ (i,j) = 0"
   using assms unfolding lower_triangular_def by auto
 
 lemma commute_multiples_identity:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat n n"
   shows "A * (k \<cdot>\<^sub>m (1\<^sub>m n)) = (k \<cdot>\<^sub>m (1\<^sub>m n)) * A"
 proof -
   have "(\<Sum>ia = 0..<n. A $$ (i, ia) * (k * (if ia = j then 1 else 0)))
     = (\<Sum>ia = 0..<n. k * (if i = ia then 1 else 0) * A $$ (ia, j))" (is "?lhs=?rhs")
     if i: "i<n" and j: "j<n" for i j
   proof -
     let ?f = "\<lambda>ia. A $$ (i, ia) * (k * (if ia = j then 1 else 0))"
     let ?g = "\<lambda>ia. k * (if i = ia then 1 else 0) * A $$ (ia, j)"
     have rw0: "(\<Sum>ia \<in> ({0..<n}-{j}). ?f ia) = 0" by (rule sum.neutral, auto)
     have rw0': "(\<Sum>ia \<in> ({0..<n}-{i}). ?g ia) = 0" by (rule sum.neutral, auto)
     have "?lhs = ?f j + (\<Sum>ia \<in> ({0..<n}-{j}). ?f ia)"
       by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove j)
     also have "... = A $$ (i, j) * k" using rw0 by auto
     also have "... = ?g i + (\<Sum>ia \<in> ({0..<n}-{i}). ?g ia)" using rw0' by auto
     also have "... = ?rhs"
       by (smt atLeast0LessThan finite_atLeastLessThan lessThan_iff sum.remove i)
     finally show ?thesis .
   qed
   thus ?thesis using A
   unfolding times_mat_def scalar_prod_def
   by auto (rule eq_matI, auto, smt sum.cong)
 qed
 
 (*This lemma is obtained using Mod_Type_Connect, otherwise we cannot prove HMA_I 0 0.
 The lelma could also be obtained with no use of transfer rules, proving it directly.*)
 lemma det_2:
   assumes A: "A \<in> carrier_mat 2 2"
   shows "Determinant.det A = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
 proof -
   let ?A = "(Mod_Type_Connect.to_hma\<^sub>m A)::'a^2^2"
   have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
     unfolding Mod_Type_Connect.HMA_M_def using from_hma_to_hma\<^sub>m A by auto
   have [transfer_rule]: "Mod_Type_Connect.HMA_I 0 0"
     unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_0)
   have [transfer_rule]: "Mod_Type_Connect.HMA_I 1 1"
     unfolding Mod_Type_Connect.HMA_I_def by (simp add: to_nat_1)
   have "Determinant.det A = Determinants.det ?A" by (transfer, simp)
   also have "... = ?A $h 1 $h 1 * ?A $h 2 $h 2 - ?A $h 1 $h 2 * ?A $h 2 $h 1" unfolding det_2 by simp
   also have "... = ?A $h 0 $h 0 * ?A $h 1 $h 1 - ?A $h 0 $h 1 * ?A $h 1 $h 0"
     by (smt Groups.mult_ac(2) exhaust_2 semiring_norm(160))
   also have "... = A$$(0,0) * A $$ (1,1) - A$$(0,1)*A$$(1,0)"
     unfolding index_hma_def[symmetric] by (transfer, auto)
   finally show ?thesis .
 qed
 
 lemma mat_diag_smult: "mat_diag n (\<lambda> x. (k::'a::comm_ring_1)) = (k \<cdot>\<^sub>m 1\<^sub>m n)"
 proof -
   have "mat_diag n (\<lambda> x. k) = mat_diag n (\<lambda> x. k * 1)" by auto
   also have "... = mat_diag n (\<lambda> x. k) * mat_diag n (\<lambda> x. 1)" using mat_diag_diag
     by (simp add: mat_diag_def)
   also have "... = mat_diag n (\<lambda> x. k) * (1\<^sub>m n)" by auto  thm mat_diag_mult_left
   also have "... = Matrix.mat n n (\<lambda>(i, j). k * (1\<^sub>m n) $$ (i, j))" by (rule mat_diag_mult_left, auto)
   also have "... = (k \<cdot>\<^sub>m 1\<^sub>m n)" unfolding smult_mat_def by auto
   finally show ?thesis .
 qed
 
 lemma invertible_mat_four_block_mat_lower_right:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat n n" and inv_A: "invertible_mat A"
   shows "invertible_mat (four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)"
 proof -
   let ?I = "(four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 n) (0\<^sub>m n 1) A)"
   have "Determinant.det ?I = Determinant.det (1\<^sub>m 1) * Determinant.det A"
     by (rule det_four_block_mat_lower_left_zero_col, insert assms, auto)
   also have "... = Determinant.det A" by auto
   finally have "Determinant.det ?I = Determinant.det A" .
   thus ?thesis
     by (metis (no_types, lifting) assms carrier_matD(1) carrier_matD(2) carrier_mat_triv
         index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
         invertible_iff_is_unit_JNF)
 qed
 
 
 lemma invertible_mat_four_block_mat_lower_right_id:
   assumes A: "(A::'a::comm_ring_1 mat) \<in> carrier_mat m m" and B: "B = 0\<^sub>m m (n-m)" and C: "C = 0\<^sub>m (n-m) m"
     and D: "D = 1\<^sub>m (n-m)" and "n>m" and inv_A: "invertible_mat A"
   shows "invertible_mat (four_block_mat A B C D)"
 proof -
   have "Determinant.det (four_block_mat A B C D) = Determinant.det A"
     by (rule det_four_block_mat_lower_right_id, insert assms, auto)
   thus ?thesis using inv_A
     by (metis (no_types, lifting) assms(1) assms(4) carrier_matD(1) carrier_matD(2) carrier_mat_triv
         index_mat_four_block(2) index_mat_four_block(3) index_one_mat(2) index_one_mat(3)
         invertible_iff_is_unit_JNF)
 qed
 
 lemma split_block4_decreases_dim_row:
   assumes E: "(A,B,C,D) = split_block E 1 1"
     and E1: "dim_row E > 1" and E2: "dim_col E > 1"
   shows "dim_row D < dim_row E"
 proof -
   have "D \<in> carrier_mat (1 + (dim_row E - 2)) (1 + (dim_col E - 2))"
     by (rule split_block(4)[OF E[symmetric]], insert E1 E2, auto)
   hence "D \<in> carrier_mat (dim_row E - 1) (dim_col E - 1)" using E1 E2 by auto
   thus ?thesis using E1 by auto
 qed
 
 
 lemma inv_P'PAQQ':
   assumes A: "A \<in> carrier_mat n n"
     and P: "P \<in> carrier_mat n n"
     and inv_P: "inverts_mat P' P"
     and inv_Q: "inverts_mat Q Q'"
     and Q: "Q \<in> carrier_mat n n"
     and P': "P' \<in> carrier_mat n n"
     and Q': "Q' \<in> carrier_mat n n"
 shows  "(P'*(P*A*Q)*Q') = A"
 proof -
   have "(P'*(P*A*Q)*Q') = (P'*(P*A*Q*Q'))"
     by (smt P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
         index_mult_mat(2) index_mult_mat(3))
   also have "... = ((P'*P)*A*(Q*Q'))"
     by (smt A P P' Q Q' assoc_mult_mat carrier_matD(1) carrier_matD(2) carrier_mat_triv
         index_mult_mat(3) inv_Q inverts_mat_def right_mult_one_mat')
   finally show ?thesis
     by (metis P' Q A inv_P inv_Q carrier_matD(1) inverts_mat_def
         left_mult_one_mat right_mult_one_mat)
 qed
 
 lemma
   assumes "U \<in> carrier_mat 2 2" and "V \<in> carrier_mat 2 2" and "A = U * V"
 shows mat_mult2_00: "A $$ (0,0) = U $$ (0,0)*V $$ (0,0) + U $$ (0,1)*V $$ (1,0)"
   and mat_mult2_01: "A $$ (0,1) = U $$ (0,0)*V $$ (0,1) + U $$ (0,1)*V $$ (1,1)"
   and mat_mult2_10: "A $$ (1,0) = U $$ (1,0)*V $$ (0,0) + U $$ (1,1)*V $$ (1,0)"
   and mat_mult2_11: "A $$ (1,1) = U $$ (1,0)*V $$ (0,1) + U $$ (1,1)*V $$ (1,1)"
     using assms unfolding times_mat_def Matrix.row_def col_def scalar_prod_def
     using sum_two_rw by auto
 
 
 subsection\<open>Lemmas about @{text "sorted lists"}, @{text "insort"} and @{text "pick"}\<close>
 
 
 lemma sorted_distinct_imp_sorted_wrt:
   assumes "sorted xs" and "distinct xs"
   shows "sorted_wrt (<) xs"
   using assms
   by (induct xs, insert le_neq_trans, auto)
 
 
 lemma sorted_map_strict:
   assumes "strict_mono_on g {0..<n}"
   shows "sorted (map g [0..<n])"
   using assms
   by (induct n, auto simp add: sorted_append strict_mono_on_def less_imp_le)
 
 
 lemma sorted_list_of_set_map_strict:
   assumes "strict_mono_on g {0..<n}"
   shows "sorted_list_of_set (g ` {0..<n}) = map g [0..<n]"
   using assms
   proof (induct n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   note sg = Suc.prems
   have sg_n: "strict_mono_on g {0..<n}" using sg unfolding strict_mono_on_def by auto
   have g_image_rw: "g ` {0..<Suc n} = insert (g n) (g ` {0..<n})"
     by (simp add: set_upt_Suc)
   have "sorted_list_of_set (g ` {0..<Suc n}) = sorted_list_of_set (insert (g n) (g ` {0..<n}))"
     using g_image_rw by simp
   also have "... = insort (g n) (sorted_list_of_set (g ` {0..<n}))"
   proof (rule sorted_list_of_set.insert)
     have "inj_on g {0..<Suc n}" using sg strict_mono_on_imp_inj_on by blast
     thus "g n \<notin> g ` {0..<n}" unfolding inj_on_def by fastforce
   qed (simp)
   also have "... = insort (g n) (map g [0..<n])"
     using Suc.hyps sg unfolding strict_mono_on_def by auto
   also have "... = map g [0..<Suc n]"
   proof (simp, rule sorted_insort_is_snoc)
     show "sorted (map g [0..<n])" by (rule sorted_map_strict[OF sg_n])
     show "\<forall>x\<in>set (map g [0..<n]). x \<le> g n" using sg unfolding strict_mono_on_def
       by (simp add: less_imp_le)
   qed
   finally show ?case .
 qed
 
 
 lemma sorted_nth_strict_mono:
   "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>i < j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i < xs!j"
   by (simp add: less_le nth_eq_iff_index_eq sorted_iff_nth_mono_less)
 
 
 lemma sorted_list_of_set_0_LEAST:
   assumes finI: "finite I" and I: "I \<noteq> {}"
   shows "sorted_list_of_set I ! 0 = (LEAST n. n\<in>I)"
 proof (rule Least_equality[symmetric])
   show "sorted_list_of_set I ! 0 \<in> I"
     by (metis I Max_in finI gr_zeroI in_set_conv_nth not_less_zero set_sorted_list_of_set)
   fix y assume "y \<in> I"
   thus "sorted_list_of_set I ! 0 \<le> y"
     by (metis eq_iff finI in_set_conv_nth neq0_conv sorted_iff_nth_mono_less
         sorted_list_of_set(1) sorted_sorted_list_of_set)
 qed
 
 lemma sorted_list_of_set_eq_pick:
   assumes i: "i < length (sorted_list_of_set I)"
   shows "sorted_list_of_set I ! i = pick I i"
 proof -
   have finI: "finite I"
   proof (rule ccontr)
     assume "infinite I"
     hence "length (sorted_list_of_set I) = 0" using sorted_list_of_set.infinite by auto
     thus False using i by simp
   qed
   show ?thesis
   using i
 proof (induct i)
   case 0
   have I: "I \<noteq> {}" using "0.prems" sorted_list_of_set_empty by blast
   show ?case unfolding pick.simps by (rule sorted_list_of_set_0_LEAST[OF finI I])
 next
   case (Suc i)
   note x_less = Suc.prems
   show ?case
   proof (unfold pick.simps, rule Least_equality[symmetric], rule conjI)
     show 1: "pick I i < sorted_list_of_set I ! Suc i"
       by (metis Suc.hyps Suc.prems Suc_lessD distinct_sorted_list_of_set find_first_unique lessI
-          nat_less_le sorted_sorted_list_of_set sorted_sorted_wrt sorted_wrt_nth_less)
+          nat_less_le sorted_sorted_list_of_set sorted_wrt_nth_less)
     show "sorted_list_of_set I ! Suc i \<in> I"
       using Suc.prems finI nth_mem set_sorted_list_of_set by blast
     have rw: "sorted_list_of_set I ! i = pick I i"
       using Suc.hyps Suc_lessD x_less by blast
     have sorted_less: "sorted_list_of_set I ! i < sorted_list_of_set I ! Suc i"
       by (simp add: 1 rw)
     fix y assume y: "y \<in> I \<and> pick I i < y"
     show "sorted_list_of_set I ! Suc i \<le> y"
       by (smt antisym_conv finI in_set_conv_nth less_Suc_eq less_Suc_eq_le nat_neq_iff rw
           sorted_iff_nth_mono_less sorted_list_of_set(1) sorted_sorted_list_of_set x_less y)
   qed
 qed
 qed
 
 text\<open>$b$ is the position where we add, $a$ the element to be added and $i$ the position
   that is checked\<close>
 
 lemma insort_nth':
   assumes "\<forall>j<b. xs ! j < a" and "sorted xs" and "a \<notin> set xs"
     and "i < length xs + 1" and "i < b"
     and "xs \<noteq> []" and "b < length xs"
   shows "insort a xs ! i = xs ! i"
   using assms
 proof (induct xs arbitrary: a b i)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   note less = Cons.prems(1)
   note sorted = Cons.prems(2)
   note a_notin = Cons.prems(3)
   note i_length = Cons.prems(4)
   note i_b = Cons.prems(5)
   note b_length = Cons.prems(7)
   show ?case
   proof (cases "a \<le> x")
     case True
     have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
     also have "... =  (x # xs) ! i"
       using Cons.prems(1) Cons.prems(5) True by force
     finally show ?thesis .
   next
     case False note x_less_a = False
     have "insort a (x # xs) ! i = (x # insort a xs) ! i" using False by simp
     also have "... = (x # xs) ! i"
     proof (cases "i = 0")
       case True
       then show ?thesis by auto
     next
       case False
       have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
         by (simp add: False nth_Cons')
       also have "... = xs ! (i-1)"
       proof (rule Cons.hyps)
         show "sorted xs" using sorted by simp
         show "a \<notin> set xs" using a_notin by simp
         show "i - 1 < length xs + 1" using i_length False by auto
         show "xs \<noteq> []" using i_b b_length by force
         show "i - 1 < b - 1" by (simp add: False diff_less_mono i_b leI)
         show "b - 1 < length xs" using b_length i_b by auto
         show "\<forall>j<b - 1. xs ! j < a" using less less_diff_conv by auto
       qed
       also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
       finally show ?thesis .
     qed
     finally show ?thesis .
   qed
 qed
 
 
 lemma insort_nth:
   assumes  "sorted xs" and "a \<notin> set xs"
     and "i < index (insort a xs) a"
     and "xs \<noteq> []"
   shows "insort a xs ! i = xs ! i"
   using assms
 proof (induct xs arbitrary: a i)
 case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   note sorted = Cons.prems(1)
   note a_notin = Cons.prems(2)
   note i_index = Cons.prems(3)
   show ?case
   proof (cases "a \<le> x")
     case True
     have "insort a (x # xs) ! i = (a # x # xs) ! i" using True by simp
     also have "... = (x # xs) ! i"
       using Cons.prems(1) Cons.prems(3) True by force
     finally show ?thesis .
   next
     case False note x_less_a = False
     show ?thesis
     proof (cases "xs = []")
       case True
       have "x \<noteq> a" using False by auto
       then show ?thesis  using True i_index False by auto
     next
       case False note xs_not_empty = False
       have "insort a (x # xs) ! i = (x # insort a xs) ! i" using x_less_a by simp
       also have "... = (x # xs) ! i"
       proof (cases "i = 0")
         case True
         then show ?thesis by auto
       next
         case False note i0 = False
         have "(x # insort a xs) ! i = (insort a xs) ! (i-1)"
           by (simp add: False nth_Cons')
         also have "... = xs ! (i-1)"
         proof (rule Cons.hyps[OF _ _ _ xs_not_empty])
           show "sorted xs" using sorted by simp
           show "a \<notin> set xs" using a_notin by simp
           have "index (insort a (x # xs)) a = index ((x # insort a xs)) a"
             using x_less_a by auto
           also have "... = index (insort a xs) a + 1"
             unfolding index_Cons using x_less_a by simp
           finally show "i - 1 < index (insort a xs) a" using False i_index by linarith
         qed
         also have "... = (x # xs) ! i" by (simp add: False nth_Cons')
         finally show ?thesis .
       qed
       finally show ?thesis .
     qed
   qed
 qed
 
 lemma insort_nth2:
   assumes "sorted xs" and "a \<notin> set xs"
     and "i < length xs" and "i \<ge> index (insort a xs) a"
     and "xs \<noteq> []"
   shows "insort a xs ! (Suc i) = xs ! i"
   using assms
 proof (induct xs arbitrary: a i)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   note sorted = Cons.prems(1)
   note a_notin = Cons.prems(2)
   note i_length = Cons.prems(3)
   note index_i = Cons.prems(4)
   show ?case
   proof (cases "a \<le> x")
     case True
     have "insort a (x # xs) ! (Suc i) = (a # x # xs) ! (Suc i)" using True by simp
     also have "... =  (x # xs) ! i"
       using Cons.prems(1) Cons.prems(5) True by force
     finally show ?thesis .
   next
     case False note x_less_a = False
     have "insort a (x # xs) ! (Suc i) = (x # insort a xs) ! (Suc i)" using False by simp
     also have "... = (x # xs) ! i"
     proof (cases "i = 0")
         case True
         then show ?thesis using index_i linear x_less_a by fastforce
       next
         case False note i0 = False
         show ?thesis
         proof -
           have Suc_i: "Suc (i - 1) = i"
             using i0 by auto
           have "(x # insort a xs) ! (Suc i) = (insort a xs) ! i"
             by (simp add: nth_Cons')
           also have "... = (insort a xs) ! Suc (i - 1)" using Suc_i by simp
           also have "... = xs ! (i - 1)"
           proof (rule Cons.hyps)
             show "sorted xs" using sorted by simp
             show "a \<notin> set xs" using a_notin by simp
             show "i - 1 < length xs" using i_length using Suc_i by auto
             thus "xs \<noteq> []" by auto
             have "index (insort a (x # xs)) a = index ((x # insort a xs)) a" using x_less_a by simp
             also have "... = index (insort a xs) a + 1" unfolding index_Cons using x_less_a by simp
             finally show "index (insort a xs) a \<le> i - 1" using index_i i0 by auto
           qed
           also have "... = (x # xs) ! i" using Suc_i by auto
           finally show ?thesis .
         qed
       qed
       finally show ?thesis .
     qed
 qed
 
 lemma pick_index:
   assumes a: "a \<in> I" and a'_card: "a' < card I"
   shows "(pick I a' = a) = (index (sorted_list_of_set I) a = a')"
 proof -
   have finI: "finite I" using a'_card card.infinite by force
   have length_I: "length (sorted_list_of_set I) = card I"
     by (metis a'_card card.infinite distinct_card distinct_sorted_list_of_set
         not_less_zero set_sorted_list_of_set)
   let ?i = "index (sorted_list_of_set I) a"
   have "(sorted_list_of_set I) ! a' = pick I a'"
     by (rule sorted_list_of_set_eq_pick, auto simp add: finI a'_card length_I)
   moreover have "(sorted_list_of_set I) ! ?i = a"
     by (rule nth_index, simp add: a finI)
   ultimately show ?thesis
     by (metis a'_card distinct_sorted_list_of_set index_nth_id length_I)
 qed
 
 end