diff --git a/thys/IMP2_Binary_Heap/IMP2_Binary_Heap.thy b/thys/IMP2_Binary_Heap/IMP2_Binary_Heap.thy
--- a/thys/IMP2_Binary_Heap/IMP2_Binary_Heap.thy
+++ b/thys/IMP2_Binary_Heap/IMP2_Binary_Heap.thy
@@ -1,903 +1,903 @@
 theory IMP2_Binary_Heap
   imports IMP2.IMP2 IMP2.IMP2_Aux_Lemmas
 begin
 section \<open>Introduction\<close>
 text \<open>In this submission imperative versions of the following array-based binary minimum heap
       functions are implemented and verified: insert, get-min, delete-min, make-heap.
       The latter three are then used to prove the correctness of an in-place heapsort, which sorts
       an array in descending order. To do that in Isabelle/HOL, the proof framework IMP2
       \cite{IMP2-AFP} is used. Here arrays are modeled by \<open>int \<Rightarrow> int\<close> functions. The imperative
       implementations are iterative versions of the partly recursive algorithms described in
       \cite{MS} and \cite{CLRS}.
 
       This submission starts with the basic definitions and lemmas, which are needed for array-based 
       binary heaps. These definitions and lemmas are parameterised with an arbitrary (transitive) 
       comparison function (where such a function is needed), so they are not only applicable to 
       minimum heaps. After some more general, useful lemmas on arrays, the imperative minimum heap 
       functions and the heapsort are implemented and verified.\<close>
 
 section \<open>Heap Related Definitions and Theorems\<close>
 subsection \<open>Array Bounds\<close>
 text \<open>A small helper function is used to define valid array indices. Note that the lower index 
       bound \<open>l\<close> is arbitrary and not fixed to 0 or 1. The upper index bound \<open>r\<close> is not a valid
       index itself, so that the empty array can be denoted by having \<open>l = r\<close>.\<close>
 abbreviation bounded :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "bounded l r x \<equiv> l \<le> x \<and> x < r"
 
 subsection \<open>Parent and Children\<close>
 
 subsubsection \<open>Definitions\<close>
 text \<open>For the notion of an array-based binary heap, the parent and child relations on the array 
       indices need to be defined.\<close>
 definition parent :: "int \<Rightarrow> int \<Rightarrow> int" where
   "parent l c = l + (c - l - 1) div 2"
 
 definition l_child :: "int \<Rightarrow> int \<Rightarrow> int" where
   "l_child l p = 2 * p - l + 1"
 
 definition r_child :: "int \<Rightarrow> int \<Rightarrow> int" where
   "r_child l p = 2 * p - l + 2"
 
 subsubsection \<open>Lemmas\<close>
 lemma parent_upper_bound: "parent l c < c \<longleftrightarrow> l \<le> c"
   unfolding parent_def by auto
 
 lemma parent_upper_bound_alt: "l \<le> parent l c \<Longrightarrow> parent l c < c"
   unfolding parent_def by simp
 
 lemma parent_lower_bound: "l \<le> parent l c \<longleftrightarrow> l < c"
   unfolding parent_def by linarith
 
 lemma grand_parent_upper_bound: "parent l (parent l c) < c \<longleftrightarrow> l \<le> c"
   unfolding parent_def by linarith
 
 corollary parent_bounds: "l < x \<Longrightarrow> x < r \<Longrightarrow> bounded l r (parent l x)"
   using parent_lower_bound parent_upper_bound_alt by fastforce
 
 
 lemma l_child_lower_bound: " p < l_child l p \<longleftrightarrow> l \<le> p"
   unfolding l_child_def by simp
 
 corollary l_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < l_child l p"
   using l_child_lower_bound[of p l] by linarith
 
 lemma parent_l_child[simp]: "parent l (l_child l n) = n"
   unfolding parent_def l_child_def by simp
 
 
 lemma r_child_lower_bound: "l \<le> p \<Longrightarrow> p < r_child l p"
   unfolding r_child_def by simp
 
 corollary r_child_lower_bound_alt: "l \<le> x \<Longrightarrow> x \<le> p \<Longrightarrow> x < r_child l p"
   using r_child_lower_bound[of l p] by linarith
 
 lemma parent_r_child[simp]: "parent l (r_child l n) = n"
   unfolding parent_def r_child_def by simp
 
 
 lemma smaller_l_child: "l_child l x < r_child l x"
   unfolding l_child_def r_child_def by simp
 
 lemma parent_two_children: 
   "(c = l_child l p \<or> c = r_child l p) \<longleftrightarrow> parent l c = p"
   unfolding parent_def l_child_def r_child_def by linarith
 
 subsection \<open>Heap Invariants\<close>
 subsubsection \<open>Definitions\<close>
 text \<open>The following heap invariants and the following lemmas are parameterised with an arbitrary 
       (transitive) comparison function. For the concrete function implementations at the end of 
       this submission \<open>\<le>\<close> on ints is used.\<close>
 
 text \<open>For the \<open>make_heap\<close> function, which transforms an unordered array into a valid heap,
       the notion of a partial heap is needed. Here the heap invariant only holds for array indices
       between a certain valid array index \<open>m\<close> and \<open>r\<close>. The standard heap invariant is then
       simply the special case where \<open>m = l\<close>.\<close>
 definition is_partial_heap 
   :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "is_partial_heap cmp heap l m r = (\<forall> x. bounded m r x \<longrightarrow> 
                bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x))"
 
 abbreviation is_heap 
   :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "is_heap cmp heap l r \<equiv> is_partial_heap cmp heap l l r"
 
 
 text \<open>During all of the modifying heap functions the heap invariant is temporarily violated at
       a single index \<open>i\<close> and it is then gradually restored by either \<open>sift_down\<close> or 
       \<open>sift_up\<close>. The following definitions formalize these weakened invariants.
 
       The second part of the conjunction in the following definitions states, that the comparison 
       between the parent of \<open>i\<close> and each of the children of \<open>i\<close> evaluates to \<open>True\<close> without 
       explicitly using the child relations.\<close>
 definition is_partial_heap_except_down 
   :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "is_partial_heap_except_down cmp heap l m r i = (\<forall> x. bounded m r x \<longrightarrow>
     ((parent l x \<noteq> i \<longrightarrow> bounded m r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and> 
      (parent l x = i \<longrightarrow> bounded m r (parent l (parent l x))  
                      \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"
 
 abbreviation is_heap_except_down 
   :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "is_heap_except_down cmp heap l r i \<equiv> is_partial_heap_except_down cmp heap l l r i"
 
 
 text \<open>As mentioned the notion of a partial heap is only needed for \<open>make_heap\<close>, 
       which only uses \<open>sift_down\<close> internally, so there doesn't need to be an additional 
       definition for the partial heap version of the \<open>sift_up\<close> invariant.\<close>
 definition is_heap_except_up 
   :: "('a::order \<Rightarrow> 'a::order \<Rightarrow> bool) \<Rightarrow> (int \<Rightarrow> 'a::order) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "is_heap_except_up cmp heap l r i = (\<forall> x. bounded l r x \<longrightarrow> 
     ((x \<noteq> i \<longrightarrow> bounded l r (parent l x) \<longrightarrow> cmp (heap (parent l x)) (heap x)) \<and> 
      (parent l x = i \<longrightarrow> bounded l r (parent l (parent l x)) 
                      \<longrightarrow> cmp (heap (parent l (parent l x))) (heap x))))"
 
 subsubsection \<open>Lemmas\<close>
 
 lemma empty_partial_heap[simp]: "is_partial_heap cmp heap l r r"
   unfolding is_partial_heap_def by linarith
 
 lemma is_partial_heap_smaller_back: 
   "is_partial_heap cmp heap l m r \<Longrightarrow> r' \<le> r \<Longrightarrow> is_partial_heap cmp heap l m r'"
   unfolding is_partial_heap_def by simp
 
 lemma is_partial_heap_smaller_front: 
   "is_partial_heap cmp heap l m r \<Longrightarrow> m \<le> m' \<Longrightarrow> is_partial_heap cmp heap l m' r"
   unfolding is_partial_heap_def by simp
 
 text \<open>The second half of each array is a is a partial binary heap, since it contains only leafs,
       which are all trivial binary heaps.\<close>
 lemma snd_half_is_partial_heap: 
   "(l + r) div 2 \<le> m \<Longrightarrow> is_partial_heap cmp heap l m r" 
   unfolding is_partial_heap_def parent_def by linarith
 
 lemma modify_outside_partial_heap: 
   assumes 
     "heap = heap' on {m..<r}" 
     "is_partial_heap cmp heap l m r"
   shows "is_partial_heap cmp heap' l m r"
   using assms eq_onD unfolding is_partial_heap_def by fastforce
 
 text \<open>The next few lemmas formalize how the heap invariant is weakened, when the heap is modified
       in a certain way.\<close>
 
 text \<open>This lemma is used by \<open>make_heap\<close>.\<close>
 lemma partial_heap_added_first_el: 
   assumes 
     "l \<le> m" "m \<le> r"
     "is_partial_heap cmp heap l (m + 1) r"
   shows "is_partial_heap_except_down cmp heap l m r m"
  unfolding is_partial_heap_except_down_def
 proof
   fix x
   let ?p_x = "parent l x"
   let ?gp_x = "parent l ?p_x"
   show "bounded m r x \<longrightarrow>
         (?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
         (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
   proof
     assume x_bound: "bounded m r x"
     have p_x_lower: "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> ?p_x \<ge> m + 1"
       by simp
     hence "?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> x \<ge> m + 1"
       using parent_upper_bound[of l x] x_bound assms(1) by linarith
     hence p_invariant: "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x))"
       using assms(3) is_partial_heap_def p_x_lower x_bound by blast
 
     have gp_up_bound: "(?p_x = m \<longrightarrow> ?gp_x < m)"
       by (simp add: assms(1) parent_upper_bound)
     show "(?p_x \<noteq> m \<longrightarrow> bounded m r ?p_x \<longrightarrow> cmp (heap ?p_x) (heap x)) \<and>
           (?p_x = m \<longrightarrow> bounded m r ?gp_x \<longrightarrow> cmp (heap ?gp_x) (heap x))"
       using gp_up_bound p_invariant by linarith
   qed
 qed
 
 text \<open>This lemma is used by \<open>del_min\<close>.\<close>
 lemma heap_changed_first_el: 
   assumes "is_heap cmp heap l r" "l \<le> r"
   shows "is_heap_except_down cmp (heap(l := b)) l r l"
 proof -
   have "is_partial_heap cmp heap l (l + 1) r"
     using assms(1) is_partial_heap_smaller_front by fastforce
   hence "is_partial_heap cmp (heap(l := b)) l (l + 1) r"
     using modify_outside_partial_heap[of heap] by simp
   thus ?thesis
     by (simp add: assms(2) partial_heap_added_first_el)
 qed
 
 text \<open>This lemma is used by \<open>insert\<close>.\<close>
 lemma heap_appended_el: 
   assumes 
     "is_heap cmp heap l r" 
     "heap = heap' on {l..<r}"
   shows "is_heap_except_up cmp heap' l (r+1) r"
 proof -
   have "is_heap cmp heap' l r" 
     using assms(1,2) modify_outside_partial_heap by blast 
   thus ?thesis unfolding is_partial_heap_def is_heap_except_up_def
     by (metis not_less_iff_gr_or_eq parent_upper_bound zless_add1_eq)
 qed
 
 subsubsection \<open>First Heap Element\<close>
 text \<open>The next step is to show that the first element of the heap is always the ``smallest'' 
       according to the given comparison function. For the proof a rule for strong induction on lower
       bounded integers is needed. Its proof is based on the proof of strong induction on natural 
       numbers found in \cite{Str_Ind}.\<close>
 lemma strong_int_gr_induct_helper: 
   assumes "k < (i::int)" "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)"
   shows "\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j"
   using assms
 proof(induction i rule: int_gr_induct)
   case base 
   then show ?case by linarith 
 next
   case (step i) 
   then show ?case 
   proof(cases "j = i")
     case True
     then show ?thesis using step.IH step.prems(1,3) by blast 
   next
     case False
     hence "j < i" using step.prems(2) by simp
     then show ?thesis using step.IH step.prems(1,3) by blast 
   qed
 qed
 
 theorem strong_int_gr_induct:
   assumes 
     "k < (i::int)" 
     "(\<And>i. k < i \<Longrightarrow> (\<And>j. k < j \<Longrightarrow> j < i \<Longrightarrow> P j) \<Longrightarrow> P i)" 
   shows "P i"
   using assms less_induct strong_int_gr_induct_helper by blast
 
 text \<open>Now the main theorem, that the first heap element is the ``smallest'' according to the
       given comparison function, can be proven.\<close>
 theorem heap_first_el:
   assumes 
     "is_heap cmp heap l r"
     "transp cmp"
     "l < x" "x < r"
   shows "cmp (heap l) (heap x)"
   using assms unfolding is_partial_heap_def
 proof(induction x rule: strong_int_gr_induct[of l])
   case 1
   then show ?case using assms(3) by simp
 next
   case (2 i)
   have cmp_pi_i: "cmp (heap (parent l i)) (heap i)"
     using "2.hyps" "2.prems"(1,4) parent_bounds by simp
   then show ?case 
   proof(cases)
     assume "parent l i > l"
     then have "cmp (heap l) (heap (parent l i))"
       using "2.IH" "2.prems"(1,2,4) parent_upper_bound_alt by simp
     then show ?thesis
       using "2.prems"(2) cmp_pi_i transpE by metis
   next
     assume "\<not> parent l i > l"
     then have "parent l i = l"
       using "2.hyps" dual_order.order_iff_strict parent_lower_bound by metis
     then show ?thesis
       using cmp_pi_i by simp
   qed
 qed
 
 
 
 section \<open>General Lemmas on Arrays\<close>
 text \<open>Some additional lemmas on @{const "mset_ran"}, @{const "swap"} and @{const "eq_on"} are needed
       for the final proofs.\<close>
 
 subsection \<open>Lemmas on @{const "mset_ran"}\<close>
 abbreviation arr_mset :: "(int \<Rightarrow> 'a) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a multiset" where
   "arr_mset arr l r \<equiv> mset_ran arr {l..<r}"
 
 lemma in_mset_imp_in_array: 
   "x \<in># (arr_mset arr l r) \<longleftrightarrow> (\<exists>i. bounded l r i \<and> arr i = x)"
   unfolding mset_ran_def by fastforce
 
 lemma arr_mset_remove_last: 
   "l \<le> r \<Longrightarrow> arr_mset arr l r = arr_mset arr l (r + 1) - {#arr r#}"
   by (simp add: intvs_upper_decr mset_ran_def)
 
 lemma arr_mset_append: 
   "l \<le> r \<Longrightarrow> arr_mset arr l (r + 1) = arr_mset arr l r + {#arr r#}"
   using arr_mset_remove_last[of l r arr] by simp
 
 corollary arr_mset_append_alt: 
   "l \<le> r \<Longrightarrow> arr_mset (arr(r := b)) l (r + 1) = arr_mset arr l r + {#b#}"
   by (simp add: arr_mset_append mset_ran_subst_outside)
 
 lemma arr_mset_remove_first: 
   "i \<le> r \<Longrightarrow> arr_mset arr (i - 1) r = arr_mset arr i r + {#arr (i - 1)#}"
   by(induction r rule: int_ge_induct) (auto simp add: arr_mset_append)
 
 lemma arr_mset_split: 
   assumes "l \<le> m" "m \<le> r"
   shows "arr_mset arr l r = arr_mset arr l m + arr_mset arr m r"
   using assms
 proof(induction m rule: int_ge_induct[of l])
   case (step i)
   have add_last: "arr_mset arr l (i + 1) = arr_mset arr l i + {#arr i#}"
     using step arr_mset_append by blast
   have rem_first: "arr_mset arr (i+1) r = arr_mset arr i r - {#arr i#}"
     by (metis step.prems arr_mset_remove_first add_diff_cancel_right') 
   show ?case 
     using step add_last rem_first by fastforce
 qed (simp)
 
 text \<open>That the first element in a heap is the ``smallest'', can now be expressed using multisets.\<close>
 corollary heap_first_el_alt:                                                   
   assumes 
     "transp cmp" 
     "is_heap cmp heap l r" 
     "x \<in># (arr_mset heap l r)" 
     "heap l \<noteq> x"
   shows "cmp (heap l) x"
   by(metis assms heap_first_el in_mset_imp_in_array le_less)
 
 
 subsection \<open>Lemmas on @{term "swap"} and @{term "eq_on"}\<close>
 
 lemma eq_on_subset: 
   "arr1 = arr2 on R \<Longrightarrow> S \<subseteq> R \<Longrightarrow> arr1 = arr2 on S"
   by (simp add: eq_on_def set_mp)
 
 lemma swap_swaps: 
   "arr' = swap arr x y \<Longrightarrow> arr' y = arr x \<and> arr' x = arr y"
   unfolding swap_def by simp
 
 lemma swap_only_swaps: 
   "arr' = swap arr x y \<Longrightarrow> z \<noteq> x \<Longrightarrow> z \<noteq> y \<Longrightarrow> arr' z = arr z"
   unfolding swap_def by simp
 
 lemma swap_commute: "swap arr x y = swap arr y x"
   unfolding swap_def by fastforce
 
 lemma swap_eq_on: 
   "arr1 = arr2 on S \<Longrightarrow> x \<notin> S \<Longrightarrow> y \<notin> S \<Longrightarrow> arr1 = swap arr2 x y on S"
   unfolding swap_def by simp
 
 corollary swap_parent_eq_on: 
   assumes 
     "arr1 = arr2 on - {l..<r}" 
     "l < c" "c < r" 
   shows "arr1 = swap arr2 (parent l c) c on - {l..<r} "
   using parent_bounds swap_eq_on assms by fastforce
 
 corollary swap_child_eq_on: 
   assumes 
     "arr1 = arr2 on - {l..<r}" 
     "c = l_child l p \<or> c = r_child l p" 
     "l \<le> p" "c < r" 
   shows "arr1 = swap arr2 p c on - {l..<r} "
   by (metis assms parent_lower_bound parent_two_children swap_parent_eq_on)
 
 lemma swap_child_mset: 
   assumes 
     "arr_mset arr1 l r = arr_mset arr2 l r" 
     "c = l_child l p \<or> c = r_child l p" 
     "l \<le> p" "c < r" 
   shows "arr_mset arr1 l r = arr_mset (swap arr2 p c) l r"
 proof -
   have child_bounded: "l < c \<and> c < r"
     by (metis assms(2-4) parent_lower_bound parent_two_children)
   have parent_bounded: "bounded l r p"
     by (metis assms(2-4) dual_order.strict_trans parent_two_children parent_upper_bound_alt)
   thus ?thesis
     using assms(1) child_bounded mset_ran_swap[of p "{l..<r}" c arr2] atLeastLessThan_iff
     by simp
 qed
 
 text \<open>The following lemma shows, which propositions have to hold on the pre-swap array, so that
       a comparison between two elements holds on the post-swap array. This is useful for the 
       proofs of the loop invariants of \<open>sift_up\<close> and \<open>sift_down\<close>. The lemma is kept 
       quite general (except for the argument order) and could probably be more closely
       related to the parent relation for more concise proofs.\<close>
 lemma cmp_swapI: 
   fixes arr::"'a::order \<Rightarrow> 'a::order"
   assumes
     "m < n \<and> x < y"
     "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y = n \<Longrightarrow> P (arr n) (arr m)"
     "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow> P (arr m) (arr n)"
     "m < n \<and> x < y \<Longrightarrow> x = m \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr y) (arr n)"
     "m < n \<and> x < y \<Longrightarrow> x = n \<Longrightarrow> y \<noteq> m \<Longrightarrow> y \<noteq> n \<Longrightarrow>  P (arr m) (arr y)"
     "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = n \<Longrightarrow> P (arr m) (arr x)"
     "m < n \<and> x < y \<Longrightarrow> x \<noteq> m \<Longrightarrow> x \<noteq> n \<Longrightarrow> y = m \<Longrightarrow> P (arr x) (arr n)"
   shows "P (swap arr x y m) (swap arr x y n)"
   by (metis assms order.asym swap_only_swaps swap_swaps)
 
 section \<open>Imperative Heap Implementation\<close>
 text \<open>The following imperative heap functions are based on \cite{MS} and \cite{CLRS}. All functions,
       that are recursive in these books, are iterative in the following implementations. The 
       function definitions are done with IMP2 \cite{IMP2-AFP}. From now on the heaps only contain 
       ints and only use \<open>\<le>\<close> as comparison function. The auxiliary lemmas used from now on are 
       heavily modeled after the proof goals, that are generated by the vcg tool (also part of IMP2).\<close>
 
 subsection \<open>Simple Functions\<close>
 subsubsection \<open>Parent, Children and Swap\<close>
 text \<open>In this section the parent and children relations are expressed as IMP2 procedures. 
       Additionally a simple procedure, that swaps two array elements, is defined.\<close>
 procedure_spec prnt (l, x) returns p
   assumes True
     ensures "p = parent l\<^sub>0 x\<^sub>0"
   defines \<open>p = ((x - l - 1) / 2 + l)\<close>
   by vcg (simp add: parent_def)
 
 procedure_spec left_child (l, x) returns lc
   assumes True 
     ensures "lc = l_child l\<^sub>0 x\<^sub>0"
   defines \<open>lc = 2 * x - l + 1\<close>
   by vcg (simp add: l_child_def)
 
 procedure_spec right_child (l, x) returns rc
   assumes True
     ensures "rc = r_child l\<^sub>0 x\<^sub>0"
   defines \<open>rc = 2 * x - l + 2\<close>
   by vcg (simp add: r_child_def)
 
 procedure_spec swp (heap, x, y) returns heap
   assumes True
     ensures "heap = swap heap\<^sub>0 x\<^sub>0 y\<^sub>0 "
   defines \<open>tmp = heap[x]; heap[x] = heap[y]; heap[y] = tmp\<close>
   by vcg (simp add: swap_def)
 
 subsubsection \<open>\<open>get_min\<close>\<close>
 text \<open>In this section \<open>get_min\<close> is defined, which simply returns the first element (the minimum) of 
       the heap. For this definition an additional theorem is proven, which enables the use of
       @{const "Min_mset"} in the postcondition.\<close>
 
 theorem heap_minimum: 
   assumes 
     "l < r" 
     "is_heap (\<le>) heap l r"
   shows "heap l = Min_mset (arr_mset heap l r)"
 proof -
   have "(\<forall>x \<in># (arr_mset heap l r). (heap l) \<le> x)"
-    using assms(2) heap_first_el_alt transp_le by blast
+    using assms(2) heap_first_el_alt transp_on_le by blast
   thus ?thesis
     by (simp add: assms(1) dual_order.antisym)
 qed
 
 procedure_spec get_min (heap, l, r) returns min
   assumes "l < r \<and> is_heap (\<le>) heap l r"  
     ensures "min = Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)"
   for heap[] l r
   defines \<open>min = heap[l]\<close>
   by vcg (simp add: heap_minimum)
 
 subsection \<open>Modifying Functions\<close>
 
 subsubsection \<open>\<open>sift_up\<close> and \<open>insert\<close>\<close>
 text \<open>The next heap function is \<open>insert\<close>, which internally uses \<open>sift_up\<close>. In the beginning of 
       this section \<open>sift_up_step\<close> is proven, which states that each \<open>sift_up\<close> loop iteration 
       correctly transforms the weakened heap invariant. For its proof two additional
       auxiliary lemmas are used. After \<open>sift_up_step\<close> \<open>sift_up\<close> and then \<open>insert\<close> are verified.\<close>
 
 text \<open>\<open>sift_up_step\<close> can be proven directly by the smt-solver without auxiliary lemmas, but they
       were introduced to show the proof details. The analogous proofs for \<open>sift_down\<close> were 
       just solved with smt, since the proof structure should be very similar, even though the 
       \<open>sift_down\<close> proof goals are slightly more complex.\<close>
 lemma sift_up_step_aux1:
   fixes heap::"int \<Rightarrow> int"
   assumes  
     "is_heap_except_up (\<le>) heap l r x"
     "parent l x \<ge> l" 
     "(heap x) \<le> (heap (parent l x))" 
     "bounded l r k" 
     "k \<noteq> (parent l x)" 
     "bounded l r (parent l k)"
   shows "(swap heap (parent l x) x (parent l k)) \<le> (swap heap (parent l x) x k)"
   apply(intro cmp_swapI[of "(parent l k)" k "(parent l x)" x "(\<le>)" heap])
   subgoal using assms(2,6) parent_upper_bound_alt by blast
   subgoal using assms(3) by blast
   subgoal using assms(1,4,6) unfolding is_heap_except_up_def by blast
   subgoal using assms(1,3,4,6) unfolding is_heap_except_up_def by fastforce
   subgoal using assms(5) by blast
   subgoal by blast 
   subgoal using assms(1,2,4) unfolding is_heap_except_up_def by simp
   done
 
 lemma sift_up_step_aux2: 
   fixes heap::"int \<Rightarrow> int"
   assumes
     "is_heap_except_up (\<le>) heap l r x"
     "parent l x \<ge> l"
     "heap x \<le> (heap (parent l x))"
     "bounded l r k"
     "parent l k = parent l x"
     "bounded l r (parent l (parent l k))"
   shows 
     "swap heap (parent l x) x (parent l (parent l k)) \<le> swap heap (parent l x) x k"
   using assms unfolding is_heap_except_up_def
 proof-
   let ?gp_k = "parent l (parent l k)"
   let ?gp_x = "parent l (parent l x)"
   have gp_k_eq_gp_x: "swap heap (parent l x) x ?gp_k = heap ?gp_x"
     by (metis assms(2,5) grand_parent_upper_bound less_irrefl swap_only_swaps)
   show ?thesis
       using assms unfolding is_heap_except_up_def
   proof(cases)
     assume k_eq_x: "k = x"
     have "swap heap (parent l x) x k = heap (parent l x)"
       by (metis k_eq_x swap_swaps)
     then show ?thesis
       using assms(1,2,4,6) unfolding is_heap_except_up_def
       by (metis gp_k_eq_gp_x k_eq_x parent_bounds parent_lower_bound)
   next
     assume k_neq_x: "k \<noteq> x"
     have "swap heap (parent l x) x k = heap k"
       by (metis assms(5) gp_k_eq_gp_x k_neq_x swap_only_swaps)
     then show ?thesis using assms unfolding is_heap_except_up_def
       by (metis gp_k_eq_gp_x k_neq_x order_trans parent_bounds parent_lower_bound)
   qed
 qed
 
 lemma sift_up_step:
   fixes heap::"int \<Rightarrow> int"
   assumes  
     "is_heap_except_up (\<le>) heap l r x"
     "parent l x \<ge> l" 
     "(heap x) \<le> (heap (parent l x))"
   shows "is_heap_except_up (\<le>) (swap heap (parent l x) x) l r (parent l x)"
   using assms sift_up_step_aux1 sift_up_step_aux2
   unfolding is_heap_except_up_def by blast
 
 text \<open>\<open>sift_up\<close> restores the heap invariant, that is only violated at the current position, by 
       iteratively swapping the current element with its parent until the beginning of the array is 
       reached or the current element is bigger than its parent.\<close>
 procedure_spec sift_up (heap, l, r, x) returns heap
   assumes "is_heap_except_up (\<le>) heap l r x \<and> bounded l r x"
     ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and>
              arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and>
              heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
   for heap[] l x r
   defines \<open>
     p = prnt(l, x);
     while (x > l \<and> heap[x] \<le> heap[p]) 
       @variant \<open>x - l\<close>
       @invariant \<open>is_heap_except_up (\<le>) heap l r x \<and> p = parent l x \<and> 
                   bounded l r x \<and> arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l r \<and>
                   heap\<^sub>0 = heap  on - {l..<r}\<close> 
     {
         heap = swp(heap, p, x);
         x = p;
         p = prnt(l, x)
     }\<close>
   apply vcg_cs
   apply(intro conjI)
   subgoal using parent_lower_bound sift_up_step by blast
   subgoal using parent_lower_bound by blast
   subgoal using parent_bounds by blast
   subgoal using parent_bounds by (simp add: mset_ran_swap)
   subgoal using swap_parent_eq_on by blast
   subgoal using parent_upper_bound by simp
   subgoal unfolding is_heap_except_up_def is_partial_heap_def
     by (metis le_less not_less parent_lower_bound)
   done
 
 text \<open>\<open>insert\<close> inserts an element into a heap by appending it to the heap and restoring the heap 
       invariant with @{const "sift_up"}.\<close>
 procedure_spec insert (heap, l, r, el) returns (heap, l, r)
   assumes "is_heap (\<le>) heap l r \<and> l \<le> r"  
     ensures "is_heap (\<le>) heap l r \<and>
              arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 + {#el\<^sub>0#} \<and>
              l = l\<^sub>0 \<and> r = r\<^sub>0 + 1  \<and> heap\<^sub>0 = heap on - {l..<r}"
   for heap l r el
   defines \<open>
     heap[r] = el;
     x = r;
     r = r + 1;
     heap = sift_up(heap, l, r, x)
   \<close>
   apply vcg_cs 
   subgoal by (simp add: heap_appended_el)
   subgoal by (metis arr_mset_append_alt add_mset_add_single)
   done
 
 subsubsection \<open>\<open>sift_down\<close>, \<open>del_min\<close> and \<open>make_heap\<close>\<close>
 text \<open>The next heap functions are \<open>del_min\<close> and \<open>make_heap\<close>, which both use \<open>sift_down\<close> to 
       restore/establish the heap invariant. \<open>sift_down\<close> is proven first (this time without 
       additional auxiliary lemmas) followed by \<open>del_min\<close> and \<open>make_heap\<close>.\<close>
 
 text \<open>\<open>sift_down\<close> restores the heap invariant, that is only violated at the current position, by 
       iteratively swapping the current element with its smallest child until the end of 
       the array is reached or the current element is smaller than its children.\<close>
 procedure_spec sift_down(heap, l, r, x) returns heap 
   assumes "is_partial_heap_except_down (\<le>) heap l x r x \<and> l \<le> x \<and> x \<le> r"
     ensures "is_partial_heap (\<le>) heap l\<^sub>0 x\<^sub>0 r\<^sub>0 \<and> 
              arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset heap l\<^sub>0 r\<^sub>0 \<and> 
              heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
   defines \<open>
    lc = left_child(l, x);
    rc = right_child(l, x);
     while (lc < r \<and> (heap[lc] < heap[x] \<or> (rc < r \<and> heap[rc] < heap[x]))) 
       @variant \<open>r - x\<close>
       @invariant \<open>is_partial_heap_except_down (\<le>) heap l x\<^sub>0 r x \<and>
                   x\<^sub>0 \<le> x \<and> x \<le> r \<and> lc = l_child l x \<and> rc = r_child l x \<and>
                   arr_mset heap\<^sub>0 l r = arr_mset heap l r \<and>
                   heap\<^sub>0 = heap on - {l..<r}\<close>
   { 
     smallest = lc;
     if (rc < r \<and> heap[rc] < heap[lc]) {
       smallest = rc
     };
     heap = swp(heap, x, smallest);
     x = smallest;
     lc = left_child(l, x);
     rc = right_child(l, x)
   }\<close>
   apply vcg_cs
   subgoal
     apply(intro conjI)
     subgoal unfolding is_partial_heap_except_down_def
       by (smt parent_two_children swap_swaps swap_only_swaps
           swap_commute parent_upper_bound_alt)
     subgoal using r_child_lower_bound_alt by fastforce
     subgoal using swap_child_mset order_trans by blast
     subgoal using swap_child_eq_on by fastforce
     done
   subgoal
     by (meson less_le_trans not_le order.asym r_child_lower_bound) 
   subgoal
     apply(intro conjI)
     subgoal unfolding is_partial_heap_except_down_def
       by (smt parent_two_children swap_swaps swap_only_swaps
           swap_commute parent_upper_bound_alt)
     subgoal using l_child_lower_bound_alt by fastforce
     subgoal using swap_child_mset order_trans by blast
     subgoal using swap_child_eq_on by fastforce
     done
   subgoal 
     by (meson less_le_trans not_le order.asym l_child_lower_bound)
   subgoal unfolding is_partial_heap_except_down_def is_partial_heap_def
     by (metis dual_order.strict_trans not_less parent_two_children smaller_l_child)
   done
 
 
 text \<open>\<open>del_min\<close> needs an additional lemma which shows, that it actually removes (only) the minimum
       from the heap.\<close>
 lemma del_min_mset: 
   fixes heap::"int \<Rightarrow> int"
   assumes 
     "l < r"
     "is_heap (\<le>) heap l r"
     "mod_heap = heap(l := heap (r - 1))"
     "arr_mset mod_heap l (r - 1) = arr_mset new_heap l (r - 1)"
   shows 
     "arr_mset new_heap l (r - 1) = arr_mset heap l r - {#Min_mset (arr_mset heap l r)#}"
 proof -
   let ?heap_mset = "arr_mset heap l r"
   have l_is_min: "heap l = Min_mset ?heap_mset"
     using assms(1,2) heap_minimum by blast
   have "(arr_mset mod_heap l r) = ?heap_mset + {#heap (r-1)#} - {#heap l#}"
     by (simp add: assms(1,3) mset_ran_subst_inside)
   hence "(arr_mset mod_heap l (r - 1)) = ?heap_mset - {#heap l#}"
     by (simp add: assms(1,3) arr_mset_remove_last) 
   thus ?thesis
     using assms(4) l_is_min by simp
 qed
 
 text \<open>\<open>del_min\<close> removes the minimum element from the heap by replacing the first element with the 
       last element, shrinking the array by one and subsequently restoring the heap invariant 
       with @{const "sift_down"}.\<close>
 procedure_spec del_min (heap, l, r) returns (heap, l, r)
   assumes "l < r \<and> is_heap (\<le>) heap l r"  
     ensures "is_heap (\<le>) heap l r \<and> 
              arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 - {#Min_mset (arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0)#} \<and> 
              l = l\<^sub>0 \<and> r = r\<^sub>0 - 1 \<and> 
              heap\<^sub>0 = heap on - {l\<^sub>0..<r\<^sub>0}"
   for heap l r
   defines \<open>
     r = r - 1;
     heap[l] = heap[r];
     heap = sift_down(heap, l, r, l)
   \<close>
   apply vcg_cs
   subgoal by (simp add: heap_changed_first_el is_partial_heap_smaller_back)
   subgoal
     apply(rule conjI)
     subgoal using del_min_mset by blast
     subgoal by (simp add: eq_on_def intvs_incdec(3) intvs_lower_incr)
     done
   done
 
 
 text \<open>\<open>make_heap\<close> transforms an arbitrary array into a heap by iterating through all array 
       positions from the middle of the array up to the beginning of the array and calling 
       @{const "sift_down"} for each one.\<close>
 procedure_spec make_heap (heap, l, r) returns heap
   assumes "l \<le> r"  
     ensures "is_heap (\<le>) heap l\<^sub>0 r\<^sub>0 \<and> 
              arr_mset heap l\<^sub>0 r\<^sub>0 = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and> 
              heap\<^sub>0 = heap on - {l\<^sub>0..< r\<^sub>0}"
   for heap[] l r
   defines \<open>
     y = (r + l)/2 - 1;
     while (y \<ge> l)
           @variant \<open>y - l + 1\<close>
           @invariant \<open>is_partial_heap (\<le>) heap l (y + 1) r \<and>
                       arr_mset heap l r = arr_mset heap\<^sub>0 l\<^sub>0 r\<^sub>0 \<and>
                       l - 1 \<le> y \<and> y < r \<and> heap\<^sub>0 = heap on - {l..<r}\<close>
     {
       heap = sift_down(heap, l, r, y);
       y = y - 1
     }\<close> 
   apply(vcg_cs)
   subgoal 
     apply(rule conjI)
     subgoal by (simp add: snd_half_is_partial_heap add.commute)
     subgoal by linarith 
     done
   subgoal using partial_heap_added_first_el le_less by blast 
   subgoal using eq_on_trans by blast 
   subgoal using dual_order.antisym by fastforce
   done
 
 subsection \<open>Heapsort Implementation\<close>
 
 text \<open>The final part of this submission is the implementation of the in-place heapsort. Firstly it 
       builds the \<open>\<le>\<close>-heap and then it iteratively removes the minimum of the heap, which is put at 
       the now vacant end of the shrinking heap. This is done until the heap is empty, which leaves 
       the array sorted in descending order.\<close>
 subsubsection \<open>Auxiliary Lemmas\<close>
 text \<open>Firstly the notion of a sorted array is needed. This is more or less the same as 
       @{const "ran_sorted"} generalized for arbitrary comparison functions.\<close>
 definition array_is_sorted :: "(int \<Rightarrow> int \<Rightarrow> bool) \<Rightarrow>  (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "array_is_sorted cmp a l r \<equiv> \<forall>i. \<forall>j. bounded l r i \<longrightarrow> bounded l r j \<longrightarrow> i < j \<longrightarrow> cmp (a i) (a j)"
 
 text \<open>This lemma states, that the heapsort doesn't change the elements contained in the array during
       the loop iterations.\<close>
 lemma heap_sort_mset_step:
   fixes arr::"int \<Rightarrow> int"
   assumes 
     "l < m" "m \<le> r"
     "arr_mset arr' l (m - 1) = arr_mset arr l m - {#Min_mset (arr_mset arr l m)#}"
     "arr = arr' on - {l..<m}"
     "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l m))"
   shows "arr_mset arr l r = arr_mset mod_arr l r"
 proof -
   let ?min = "{#Min_mset (arr_mset arr l m)#}"
   let ?new_arr_mset = "arr_mset mod_arr"
   have middle: "?new_arr_mset (m - 1) m = ?min"
     by (simp add: assms(5))
   have first_half: "?new_arr_mset l (m - 1) = arr_mset arr l m - ?min"
     by (simp add: assms(3,5) mset_ran_subst_outside)
   hence "?new_arr_mset l m = ?new_arr_mset l (m - 1) + ?new_arr_mset (m - 1) m"
     by (metis assms(1,3,5) diff_add_cancel middle arr_mset_append_alt zle_diff1_eq)
   hence first_half_middle: "?new_arr_mset l m = arr_mset arr l m"
     using middle first_half assms(1) by simp
 
   hence "mod_arr = arr on - {l..<m}"
     using assms(1,4,5) eq_on_sym eq_on_trans by auto
   then have second_half: "arr_mset arr m r = arr_mset mod_arr m r"
     by (simp add: eq_on_def mset_ran_cong)
 
   then show ?thesis
     by (metis arr_mset_split assms(1,2) first_half_middle le_less)
 qed
 
 text \<open>This lemma states, that each loop iteration leaves the growing second half of the array 
       sorted in descending order.\<close>
 lemma heap_sort_second_half_sorted_step: 
   fixes arr::"int \<Rightarrow> int"
   assumes
     "l\<^sub>0 < m" "m \<le> r\<^sub>0"
     "arr = arr' on - {l\<^sub>0..<m}"
     "\<forall>i. \<forall>j. bounded m r\<^sub>0 i \<longrightarrow> bounded m r\<^sub>0 j \<longrightarrow>  i < j \<longrightarrow> arr j \<le> arr i"
     "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
     "bounded (m - 1) r\<^sub>0 i" 
     "bounded (m - 1) r\<^sub>0 j" 
     "i < j"
     "mod_arr = (arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m)))"
   shows "mod_arr j \<le> mod_arr i"
 proof -
   have second_half_eq: "mod_arr = arr on {m..< r\<^sub>0}" 
     using assms(3, 9) unfolding eq_on_def by simp
   have j_stricter_bound: "bounded m r\<^sub>0 j"
     using assms(6-8) by simp
   then have el_at_j: "mod_arr j \<in># arr_mset arr m r\<^sub>0"
     using eq_onD second_half_eq by fastforce
   then show ?thesis 
   proof(cases)
     assume "i = (m-1)"
     then have "mod_arr i \<in># arr_mset arr l\<^sub>0 m"
       by (simp add: assms(1, 9))
     then show ?thesis
       using assms(5) el_at_j not_less by blast 
   next
     assume "i \<noteq> (m-1)"  
     then have "bounded m r\<^sub>0 i"
       using assms(6) by simp
     then show ?thesis 
       using assms(4, 8) eq_on_def j_stricter_bound second_half_eq by force
   qed
 qed
 
 
 text \<open>The following lemma shows that all elements in the first part of the array (the binary heap) 
       are bigger than the elements in the second part (the sorted part) after every iteration. This 
       lemma and the invariant of the \<open>heap_sort\<close> loop use \<open>\<not> x < y\<close> instead of \<open>x \<ge> y\<close> since 
       \<open>vcg_cs\<close> doesn't terminate in the latter case.\<close>
 lemma heap_sort_fst_part_bigger_snd_part_step:
   fixes arr::"int \<Rightarrow> int" 
   assumes
     "l\<^sub>0 < m"
     "m \<le> r\<^sub>0"
     "arr_mset arr' l\<^sub>0 (m - 1) = arr_mset arr l\<^sub>0 m - {#Min_mset (arr_mset arr l\<^sub>0 m)#}"
     "arr = arr' on - {l\<^sub>0..<m}"
     "\<forall>x\<in>#arr_mset arr l\<^sub>0 m. \<forall>y\<in>#arr_mset arr m r\<^sub>0. \<not> x < y"
     "mod_arr = arr'(m - 1 := Min_mset (arr_mset arr l\<^sub>0 m))"
     "x\<in>#arr_mset mod_arr l\<^sub>0 (m - 1)"
     "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0"
   shows "\<not> x < y"
 proof -
   have "{m..<r\<^sub>0} \<subseteq> - {l\<^sub>0..<m}" 
     by auto
   hence "arr' = arr on {m..<r\<^sub>0}" 
     using assms(4) eq_on_sym eq_on_subset by blast
   hence arr_eq_on: "mod_arr = arr on {m..<r\<^sub>0}"
     by (simp add: assms(6))
   hence same_mset: "arr_mset mod_arr m r\<^sub>0 = arr_mset arr m r\<^sub>0"
     using mset_ran_cong by blast
   have "x \<in># arr_mset arr l\<^sub>0 m" using same_mset assms
     by (metis assms(3,6,7) add_mset_remove_trivial_eq lran_upd_outside(2)
         mset_lran cancel_ab_semigroup_add_class.diff_right_commute
         diff_single_trivial multi_self_add_other_not_self order_refl)
   then have x_bigger_min: "x \<ge> Min_mset (arr_mset arr l\<^sub>0 m)"
     using Min_le by blast 
   have y_smaller_min: "y \<le> Min_mset (arr_mset arr l\<^sub>0 m)" 
   proof(cases "y = mod_arr (m - 1)")
     case False
     hence "y\<in>#arr_mset mod_arr (m - 1) r\<^sub>0 - {#mod_arr (m - 1)#}"
       by (metis assms(8) diff_single_trivial insert_DiffM insert_noteq_member)
     then have "y\<in>#arr_mset arr m r\<^sub>0"
       by (simp add: assms(2) intvs_decr_l mset_ran_insert same_mset)
     then show ?thesis
       using assms(1) assms(5) by fastforce 
   qed (simp add: assms(6))
   then show ?thesis
     using x_bigger_min by linarith 
 qed
 
 subsubsection \<open>Implementation\<close>
 text \<open>Now finally the correctness of the \<open>heap_sort\<close> is shown. As mentioned, it starts by 
       transforming the array into a minimum heap using @{const "make_heap"}. Then in each 
       iteration it removes the first element from the heap with @{const "del_min"} after its value 
       was retrieved with @{const "get_min"}. This value is then put at the position freed by 
       @{const "del_min"}.\<close>
 program_spec heap_sort
   assumes "l \<le> r"  
     ensures "array_is_sorted (\<ge>) arr l\<^sub>0 r\<^sub>0 \<and> 
              arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and> 
              arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0 } \<and> l = l\<^sub>0 \<and> r = r\<^sub>0"
   for l r arr[]
   defines \<open>
     arr = make_heap(arr, l, r);
     m = r;
     while (m > l)
       @variant \<open>m - l + 1\<close> 
       @invariant \<open>is_heap (\<le>) arr l m \<and>
         array_is_sorted (\<ge>) arr m r\<^sub>0 \<and>
         (\<forall>x \<in># arr_mset arr l\<^sub>0 m. \<forall>y \<in># arr_mset arr m r\<^sub>0. \<not> x < y) \<and>
         arr_mset arr\<^sub>0 l\<^sub>0 r\<^sub>0 = arr_mset arr l\<^sub>0 r\<^sub>0 \<and> 
         l \<le> m \<and> m \<le> r\<^sub>0 \<and> l = l\<^sub>0 \<and> arr\<^sub>0 = arr on - {l\<^sub>0 ..<r\<^sub>0}\<close>
     {
       min = get_min(arr, l, m);
       (arr, l, m) = del_min(arr, l, m);
       arr[m] = min 
     }
   \<close>
   apply vcg_cs
   subgoal unfolding array_is_sorted_def by simp
   subgoal
     apply(intro conjI)
     subgoal unfolding is_partial_heap_def by simp
     subgoal unfolding array_is_sorted_def using heap_sort_second_half_sorted_step
       by blast
     subgoal using heap_sort_fst_part_bigger_snd_part_step by blast
     subgoal using heap_sort_mset_step by blast
     subgoal unfolding eq_on_def
       by (metis ComplD ComplI atLeastLessThan_iff less_le_trans)
     done
   done
 end
diff --git a/thys/Polynomials/MPoly_Type_Class_OAlist.thy b/thys/Polynomials/MPoly_Type_Class_OAlist.thy
--- a/thys/Polynomials/MPoly_Type_Class_OAlist.thy
+++ b/thys/Polynomials/MPoly_Type_Class_OAlist.thy
@@ -1,963 +1,963 @@
 (* Author: Fabian Immler, TU Muenchen *)
 (* Author: Florian Haftmann, TU Muenchen *)
 (* Author: Andreas Lochbihler, ETH Zurich *)
 (* Author: Alexander Maletzky, RISC Linz *)
 
 section \<open>Executable Representation of Polynomial Mappings as Association Lists\<close>
 
 theory MPoly_Type_Class_OAlist
   imports Term_Order
 begin
 
 instantiation pp :: (type, "{equal, zero}") equal
 begin
 
 definition equal_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool" where
   "equal_pp p q \<equiv> (\<forall>t. lookup_pp p t = lookup_pp q t)"
 
 instance by standard (auto simp: equal_pp_def intro: pp_eqI)
 
 end
 
 instantiation poly_mapping :: (type, "{equal, zero}") equal
 begin
 
 definition equal_poly_mapping :: "('a, 'b) poly_mapping \<Rightarrow> ('a, 'b) poly_mapping \<Rightarrow> bool" where
   equal_poly_mapping_def [code del]: "equal_poly_mapping p q \<equiv> (\<forall>t. lookup p t = lookup q t)"
 
 instance by standard (auto simp: equal_poly_mapping_def intro: poly_mapping_eqI)
 
 end
 
 subsection \<open>Power-Products Represented by @{type oalist_tc}\<close>
 
 definition PP_oalist :: "('a::linorder, 'b::zero) oalist_tc \<Rightarrow> ('a, 'b) pp"
   where "PP_oalist xs = pp_of_fun (OAlist_tc_lookup xs)"
 
 code_datatype PP_oalist
 
 lemma lookup_PP_oalist [simp, code]: "lookup_pp (PP_oalist xs) = OAlist_tc_lookup xs"
   unfolding PP_oalist_def
 proof (rule lookup_pp_of_fun)
   have "{x. OAlist_tc_lookup xs x \<noteq> 0} \<subseteq> fst ` set (list_of_oalist_tc xs)"
   proof (rule, simp)
     fix x
     assume "OAlist_tc_lookup xs x \<noteq> 0"
     thus "x \<in> fst ` set (list_of_oalist_tc xs)"
       using in_OAlist_tc_sorted_domain_iff_lookup set_OAlist_tc_sorted_domain by blast
   qed
   also have "finite ..." by simp
   finally (finite_subset) show "finite {x. OAlist_tc_lookup xs x \<noteq> 0}" .
 qed
 
 lemma keys_PP_oalist [code]: "keys_pp (PP_oalist xs) = set (OAlist_tc_sorted_domain xs)"
   by (rule set_eqI, simp add: keys_pp_iff in_OAlist_tc_sorted_domain_iff_lookup)
 
 lemma lex_comp_PP_oalist [code]:
   "lex_comp' (PP_oalist xs) (PP_oalist ys) =
          the (OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys)"
   for xs ys::"('a::nat, 'b::nat) oalist_tc"
 proof (cases "lex_comp' (PP_oalist xs) (PP_oalist ys) = Eq")
   case True
   hence "PP_oalist xs = PP_oalist ys" by (rule lex_comp'_EqD)
   hence eq: "OAlist_tc_lookup xs = OAlist_tc_lookup ys" by (simp add: pp_eq_iff)
   have "OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys = Some Eq"
     by (rule OAlist_tc_lex_ord_EqI, simp add: eq)
   thus ?thesis by (simp add: True)
 next
   case False
   then obtain x where 1: "x \<in> keys_pp (rep_nat_pp (PP_oalist xs)) \<union> keys_pp (rep_nat_pp (PP_oalist ys))"
     and 2: "comparator_of (lookup_pp (rep_nat_pp (PP_oalist xs)) x) (lookup_pp (rep_nat_pp (PP_oalist ys)) x) =
           lex_comp' (PP_oalist xs) (PP_oalist ys)"
     and 3: "\<And>y. y < x \<Longrightarrow> lookup_pp (rep_nat_pp (PP_oalist xs)) y = lookup_pp (rep_nat_pp (PP_oalist ys)) y"
     by (rule lex_comp'_valE, blast)
   have "OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys = Some (lex_comp' (PP_oalist xs) (PP_oalist ys))"
   proof (rule OAlist_tc_lex_ord_valI)
     from False show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) \<noteq> Some Eq" by simp
   next
     from 1 have "abs_nat x \<in> abs_nat ` (keys_pp (rep_nat_pp (PP_oalist xs)) \<union> keys_pp (rep_nat_pp (PP_oalist ys)))"
       by (rule imageI)
     also have "... = fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)"
       by (simp add: keys_rep_nat_pp_pp keys_PP_oalist OAlist_tc_sorted_domain_def image_Un image_image)
     finally show "abs_nat x \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)" .
   next
     show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) =
           Some (comparator_of (OAlist_tc_lookup xs (abs_nat x)) (OAlist_tc_lookup ys (abs_nat x)))"
       by (simp add: 2[symmetric] lookup_rep_nat_pp_pp)
   next
     fix y::'a
     assume "y < abs_nat x"
     hence "rep_nat y < x" by (metis abs_inverse ord_iff(2))
     hence "lookup_pp (rep_nat_pp (PP_oalist xs)) (rep_nat y) = lookup_pp (rep_nat_pp (PP_oalist ys)) (rep_nat y)"
       by (rule 3)
     hence "OAlist_tc_lookup xs y = OAlist_tc_lookup ys y" by (auto simp: lookup_rep_nat_pp_pp elim: rep_inj)
     thus "Some (comparator_of (OAlist_tc_lookup xs y) (OAlist_tc_lookup ys y)) = Some Eq" by simp
   qed
   thus ?thesis by simp
 qed
 
 lemma zero_PP_oalist [code]: "(0::('a::linorder, 'b::zero) pp) = PP_oalist OAlist_tc_empty"
   by (rule pp_eqI, simp add: lookup_OAlist_tc_empty)
 
 lemma plus_PP_oalist [code]:
   "PP_oalist xs + PP_oalist ys = PP_oalist (OAlist_tc_map2_val_neutr (\<lambda>_. (+)) xs ys)"
   by (rule pp_eqI, simp add: lookup_plus_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all)
 
 lemma minus_PP_oalist [code]:
   "PP_oalist xs - PP_oalist ys = PP_oalist (OAlist_tc_map2_val_rneutr (\<lambda>_. (-)) xs ys)"
   by (rule pp_eqI, simp add: lookup_minus_pp, rule lookup_OAlist_tc_map2_val_rneutr[symmetric], simp)
 
 lemma equal_PP_oalist [code]: "equal_class.equal (PP_oalist xs) (PP_oalist ys) = (xs = ys)"
   by (simp add: equal_eq pp_eq_iff, auto elim: OAlist_tc_lookup_inj)
 
 lemma lcs_PP_oalist [code]:
   "lcs (PP_oalist xs) (PP_oalist ys) = PP_oalist (OAlist_tc_map2_val_neutr (\<lambda>_. max) xs ys)"
   for xs ys :: "('a::linorder, 'b::add_linorder_min) oalist_tc"
   by (rule pp_eqI, simp add: lookup_lcs_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all add: max_def)
 
 lemma deg_pp_PP_oalist [code]: "deg_pp (PP_oalist xs) = sum_list (map snd (list_of_oalist_tc xs))"
 proof -
   have "irreflp ((<)::_::linorder \<Rightarrow> _)" by (rule irreflpI, simp)
   have "deg_pp (PP_oalist xs) = sum (OAlist_tc_lookup xs) (set (OAlist_tc_sorted_domain xs))"
     by (simp add: deg_pp_alt keys_PP_oalist)
   also have "... = sum_list (map (OAlist_tc_lookup xs) (OAlist_tc_sorted_domain xs))"
     by (rule sum.distinct_set_conv_list, rule distinct_sorted_wrt_irrefl,
-        fact, fact transp_less, fact sorted_OAlist_tc_sorted_domain)
+        fact, fact transp_on_less, fact sorted_OAlist_tc_sorted_domain)
   also have "... = sum_list (map snd (list_of_oalist_tc xs))"
     by (rule arg_cong[where f=sum_list], simp add: OAlist_tc_sorted_domain_def OAlist_tc_lookup_eq_valueI)
   finally show ?thesis .
 qed
 
 lemma single_PP_oalist [code]: "single_pp x e = PP_oalist (oalist_tc_of_list [(x, e)])"
   by (rule pp_eqI, simp add: lookup_single_pp OAlist_tc_lookup_single)
 
 definition adds_pp_add_linorder :: "('b, 'a::add_linorder) pp \<Rightarrow> _ \<Rightarrow> bool"
   where [code_abbrev]: "adds_pp_add_linorder = (adds)"
 
 lemma adds_pp_PP_oalist [code]:
   "adds_pp_add_linorder (PP_oalist xs) (PP_oalist ys) = OAlist_tc_prod_ord (\<lambda>_. less_eq) xs ys"
   for xs ys::"('a::linorder, 'b::add_linorder_min) oalist_tc"
 proof (simp add: adds_pp_add_linorder_def adds_pp_iff adds_poly_mapping lookup_pp.rep_eq[symmetric] OAlist_tc_prod_ord_alt le_fun_def,
       intro iffI allI ballI)
   fix k
   assume "\<forall>x. OAlist_tc_lookup xs x \<le> OAlist_tc_lookup ys x"
   thus "OAlist_tc_lookup xs k \<le> OAlist_tc_lookup ys k" by blast
 next
   fix x
   assume *: "\<forall>k\<in>fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys).
               OAlist_tc_lookup xs k \<le> OAlist_tc_lookup ys k"
   show "OAlist_tc_lookup xs x \<le> OAlist_tc_lookup ys x"
   proof (cases "x \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)")
     case True
     with * show ?thesis ..
   next
     case False
     hence "x \<notin> set (OAlist_tc_sorted_domain xs)" and "x \<notin> set (OAlist_tc_sorted_domain ys)"
       by (simp_all add: set_OAlist_tc_sorted_domain)
     thus ?thesis by (simp add: in_OAlist_tc_sorted_domain_iff_lookup)
   qed
 qed
 
 subsubsection \<open>Constructor\<close>
 
 definition "sparse\<^sub>0 xs = PP_oalist (oalist_tc_of_list xs)" \<comment>\<open>sparse representation\<close>
 
 subsubsection \<open>Computations\<close>
 
 experiment begin
 
 abbreviation "X \<equiv> 0::nat"
 abbreviation "Y \<equiv> 1::nat"
 abbreviation "Z \<equiv> 2::nat"
 
 value [code] "sparse\<^sub>0 [(X, 2::nat), (Z, 7)]"
 
 lemma
   "sparse\<^sub>0 [(X, 2::nat), (Z, 7)] - sparse\<^sub>0 [(X, 2), (Z, 2)] = sparse\<^sub>0 [(Z, 5)]"
   by eval
 
 lemma
   "lcs (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse\<^sub>0 [(Y, 3), (Z, 2)]) = sparse\<^sub>0 [(X, 2), (Y, 3), (Z, 7)]"
   by eval
 
 lemma
   "(sparse\<^sub>0 [(X, 2::nat), (Z, 1)]) adds (sparse\<^sub>0 [(X, 3), (Y, 2), (Z, 1)])"
   by eval
 
 lemma
   "lookup_pp (sparse\<^sub>0 [(X, 2::nat), (Z, 3)]) X = 2"
   by eval
 
 lemma
   "deg_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
   by eval
 
 lemma
   "lex_comp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)]) = Lt"
   by eval
 
 lemma
   "lex_comp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)], 3::nat) (sparse\<^sub>0 [(X, 4)], 2) = Lt"
   by eval
 
 lemma
   "lex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
   by eval
 
 lemma
   "lex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
   by eval
 
 lemma
   "\<not> dlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
   by eval
 
 lemma
   "dlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)])"
   by eval
 
 lemma
   "\<not> drlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)])"
   by eval
 
 end
 
 subsection \<open>\<open>MP_oalist\<close>\<close>
 
 lift_definition MP_oalist :: "('a::nat_term, 'b::zero) oalist_ntm \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   is OAlist_lookup_ntm
 proof -
   fix xs :: "('a, 'b) oalist_ntm"
   have "{x. OAlist_lookup_ntm xs x \<noteq> 0} \<subseteq> fst ` set (fst (list_of_oalist_ntm xs))"
   proof (rule, simp)
     fix x
     assume "OAlist_lookup_ntm xs x \<noteq> 0"
     thus "x \<in> fst ` set (fst (list_of_oalist_ntm xs))"
       using oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain by blast
   qed
   also have "finite ..." by simp
   finally (finite_subset) show "finite {x. OAlist_lookup_ntm xs x \<noteq> 0}" .
 qed
 
 lemmas [simp, code] = MP_oalist.rep_eq
 
 code_datatype MP_oalist
 
 lemma keys_MP_oalist [code]: "keys (MP_oalist xs) = set (map fst (fst (list_of_oalist_ntm xs)))"
   by (rule set_eqI, simp add: in_keys_iff oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
 
 lemma MP_oalist_empty [simp]: "MP_oalist (OAlist_empty_ntm ko) = 0"
   by (rule poly_mapping_eqI, simp add: oa_ntm.lookup_empty)
 
 lemma zero_MP_oalist [code]: "(0::('a::{linorder,nat_term} \<Rightarrow>\<^sub>0 'b::zero)) = MP_oalist (OAlist_empty_ntm nat_term_order_of_le)"
   by simp
 
 definition is_zero :: "('a \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> bool"
   where [code_abbrev]: "is_zero p \<longleftrightarrow> (p = 0)"
 
 lemma is_zero_MP_oalist [code]: "is_zero (MP_oalist xs) = List.null (fst (list_of_oalist_ntm xs))"
   unfolding is_zero_def List.null_def
 proof
   assume "MP_oalist xs = 0"
   hence "OAlist_lookup_ntm xs k = 0" for k by (simp add: poly_mapping_eq_iff)
   thus "fst (list_of_oalist_ntm xs) = []"
     by (metis image_eqI ko_ntm.min_key_val_raw_in oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain)
 next
   assume "fst (list_of_oalist_ntm xs) = []"
   hence "OAlist_lookup_ntm xs k = 0" for k
     by (metis oa_ntm.list_of_oalist_empty oa_ntm.lookup_empty oalist_ntm_eqI surjective_pairing)
   thus "MP_oalist xs = 0" by (simp add: poly_mapping_eq_iff ext)
 qed
 
 lemma plus_MP_oalist [code]: "MP_oalist xs + MP_oalist ys = MP_oalist (OAlist_map2_val_neutr_ntm (\<lambda>_. (+)) xs ys)"
   by (rule poly_mapping_eqI, simp add: lookup_plus_fun, rule oa_ntm.lookup_map2_val_neutr[symmetric], simp_all)
 
 lemma minus_MP_oalist [code]: "MP_oalist xs - MP_oalist ys = MP_oalist (OAlist_map2_val_rneutr_ntm (\<lambda>_. (-)) xs ys)"
   by (rule poly_mapping_eqI, simp add: lookup_minus_fun, rule oa_ntm.lookup_map2_val_rneutr[symmetric], simp)
 
 lemma uminus_MP_oalist [code]: "- MP_oalist xs = MP_oalist (OAlist_map_val_ntm (\<lambda>_. uminus) xs)"
   by (rule poly_mapping_eqI, simp, rule oa_ntm.lookup_map_val[symmetric], simp)
 
 lemma equal_MP_oalist [code]: "equal_class.equal (MP_oalist xs) (MP_oalist ys) = (OAlist_eq_ntm xs ys)"
   by (simp add: oa_ntm.oalist_eq_alt equal_eq poly_mapping_eq_iff)
 
 lemma map_MP_oalist [code]: "Poly_Mapping.map f (MP_oalist xs) = MP_oalist (OAlist_map_val_ntm (\<lambda>_. f) xs)"
 proof -
   have eq: "OAlist_map_val_ntm (\<lambda>_. f) xs = OAlist_map_val_ntm (\<lambda>_ c. f c when c \<noteq> 0) xs"
   proof (rule oa_ntm.map_val_cong)
     fix t c
     assume *: "(t, c) \<in> set (fst (list_of_oalist_ntm xs))"
     hence "fst (t, c) \<in> fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
     hence "OAlist_lookup_ntm xs t \<noteq> 0"
       by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
     moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
     ultimately have "c \<noteq> 0" by simp
     thus "f c = (f c when c \<noteq> 0)" by simp
   qed
   show ?thesis
     by (rule poly_mapping_eqI, simp add: Poly_Mapping.map.rep_eq eq, rule oa_ntm.lookup_map_val[symmetric], simp)
 qed
 
 lemma range_MP_oalist [code]: "Poly_Mapping.range (MP_oalist xs) = set (map snd (fst (list_of_oalist_ntm xs)))"
 proof (simp add: Poly_Mapping.range.rep_eq, intro set_eqI iffI)
   fix c
   assume "c \<in> range (OAlist_lookup_ntm xs) - {0}"
   hence "c \<in> range (OAlist_lookup_ntm xs)" and "c \<noteq> 0" by simp_all
   from this(1) obtain t where "OAlist_lookup_ntm xs t = c" by fastforce
   with \<open>c \<noteq> 0\<close> have "(t, c) \<in> set (fst (list_of_oalist_ntm xs))" by (simp add: oa_ntm.lookup_eq_value)
   hence "snd (t, c) \<in> snd ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
   thus "c \<in> snd ` set (fst (list_of_oalist_ntm xs))" by simp
 next
   fix c
   assume "c \<in> snd ` set (fst (list_of_oalist_ntm xs))"
   then obtain t where *: "(t, c) \<in> set (fst (list_of_oalist_ntm xs))" by fastforce
   hence "fst (t, c) \<in> fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
   hence "OAlist_lookup_ntm xs t \<noteq> 0"
     by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
   moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
   ultimately show "c \<in> range (OAlist_lookup_ntm xs) - {0}" by fastforce
 qed
 
 lemma if_poly_mapping_eq_iff:
   "(if x = y then a else b) = (if (\<forall>i\<in>keys x \<union> keys y. lookup x i = lookup y i) then a else b)"
   by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)
 
 lemma keys_add_eq: "keys (a + b) = keys a \<union> keys b - {x \<in> keys a \<inter> keys b. lookup a x + lookup b x = 0}"
   by (auto simp: in_keys_iff lookup_add add_eq_0_iff
       simp del: lookup_not_eq_zero_eq_in_keys)
 
 locale gd_nat_term =
     gd_term pair_of_term term_of_pair
         "\<lambda>s t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
         "\<lambda>s t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
         "le_of_nat_term_order cmp_term"
         "lt_of_nat_term_order cmp_term"
       for pair_of_term::"'t::nat_term \<Rightarrow> ('a::{nat_term,graded_dickson_powerprod} \<times> 'k::{countable,the_min,wellorder})"
       and term_of_pair::"('a \<times> 'k) \<Rightarrow> 't"
       and cmp_term +
     assumes splus_eq_splus: "t \<oplus> u = nat_term_class.splus (term_of_pair (t, the_min)) u"
 begin
 
 definition shift_map_keys :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('t, 'b) oalist_ntm \<Rightarrow> ('t, 'b::semiring_0) oalist_ntm"
   where "shift_map_keys t f xs = OAlist_ntm (map_raw (\<lambda>kv. (t \<oplus> fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
 
 lemma list_of_oalist_shift_keys:
   "list_of_oalist_ntm (shift_map_keys t f xs) = (map_raw (\<lambda>kv. (t \<oplus> fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
   unfolding shift_map_keys_def
   by (rule oa_ntm.list_of_oalist_of_list_id, rule ko_ntm.oalist_inv_map_raw, fact oalist_inv_list_of_oalist_ntm,
       simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
 
 lemma lookup_shift_map_keys_plus:
   "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) (t \<oplus> u) = c * lookup (MP_oalist xs) u" (is "?l = ?r")
 proof -
   let ?f = "\<lambda>kv. (t \<oplus> fst kv, c * snd kv)"
   have "?l = lookup_ko_ntm (map_raw ?f (list_of_oalist_ntm xs)) (fst (?f (u, c)))"
     by (simp add: oa_ntm.lookup_def list_of_oalist_shift_keys)
   also have "... = snd (?f (u, lookup_ko_ntm (list_of_oalist_ntm xs) u))"
     by (rule ko_ntm.lookup_raw_map_raw, fact oalist_inv_list_of_oalist_ntm, simp,
         simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
   also have "... = ?r" by (simp add: oa_ntm.lookup_def)
   finally show ?thesis .
 qed
 
 lemma keys_shift_map_keys_subset:
   "keys (MP_oalist (shift_map_keys t ((*) c) xs)) \<subseteq> ((\<oplus>) t) ` keys (MP_oalist xs)" (is "?l \<subseteq> ?r")
 proof -
   let ?f = "\<lambda>kv. (t \<oplus> fst kv, c * snd kv)"
   have "?l = fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))"
     by (simp add: keys_MP_oalist list_of_oalist_shift_keys)
   also from ko_ntm.map_raw_subset have "... \<subseteq> fst ` ?f ` set (fst (list_of_oalist_ntm xs))"
     by (rule image_mono)
   also have "... \<subseteq> ?r" by (simp add: keys_MP_oalist image_image)
   finally show ?thesis .
 qed
 
 lemma monom_mult_MP_oalist [code]:
   "monom_mult c t (MP_oalist xs) =
     MP_oalist (if c = 0 then OAlist_empty_ntm (snd (list_of_oalist_ntm xs)) else shift_map_keys t ((*) c) xs)"
 proof (cases "c = 0")
   case True
   hence "monom_mult c t (MP_oalist xs) = 0" using monom_mult_zero_left by simp
   thus ?thesis using True by simp
 next
   case False
   have "monom_mult c t (MP_oalist xs) = MP_oalist (shift_map_keys t ((*) c) xs)"
   proof (rule poly_mapping_eqI, simp add: lookup_monom_mult del: MP_oalist.rep_eq, intro conjI impI)
     fix u
     assume "t adds\<^sub>p u"
     then obtain v where "u = t \<oplus> v" by (rule adds_ppE)
     thus "c * lookup (MP_oalist xs) (u \<ominus> t) = lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u"
       by (simp add: splus_sminus lookup_shift_map_keys_plus del: MP_oalist.rep_eq)
   next
     fix u
     assume "\<not> t adds\<^sub>p u"
     have "u \<notin> keys (MP_oalist (shift_map_keys t ((*) c) xs))"
     proof
       assume "u \<in> keys (MP_oalist (shift_map_keys t ((*) c) xs))"
       also have "... \<subseteq> ((\<oplus>) t) ` keys (MP_oalist xs)" by (fact keys_shift_map_keys_subset)
       finally obtain v where "u = t \<oplus> v" ..
       hence "t adds\<^sub>p u" by (rule adds_ppI)
       with \<open>\<not> t adds\<^sub>p u\<close> show False ..
     qed
     thus "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u = 0" by (simp add: in_keys_iff)
   qed
   thus ?thesis by (simp add: False)
 qed
 
 lemma mult_scalar_MP_oalist [code]:
   "(MP_oalist xs) \<odot> (MP_oalist ys) =
       (if is_zero (MP_oalist xs) then
         MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))
       else
         let ct = OAlist_hd_ntm xs in
         monom_mult (snd ct) (fst ct) (MP_oalist ys) + (MP_oalist (OAlist_tl_ntm xs)) \<odot> (MP_oalist ys))"
 proof (split if_split, intro conjI impI)
   assume "is_zero (MP_oalist xs)"
   thus "MP_oalist xs \<odot> MP_oalist ys = MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))"
     by (simp add: is_zero_def)
 next
   assume "\<not> is_zero (MP_oalist xs)"
   hence *: "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
   define ct where "ct = OAlist_hd_ntm xs"
   have eq: "except (MP_oalist xs) {fst ct} = MP_oalist (OAlist_tl_ntm xs)"
     by (rule poly_mapping_eqI, simp add: lookup_except ct_def oa_ntm.lookup_tl')
   have "MP_oalist xs \<odot> MP_oalist ys =
           monom_mult (lookup (MP_oalist xs) (fst ct)) (fst ct) (MP_oalist ys) +
           except (MP_oalist xs) {fst ct} \<odot> MP_oalist ys" by (fact mult_scalar_rec_left)
   also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + except (MP_oalist xs) {fst ct} \<odot> MP_oalist ys"
     using * by (simp add: ct_def oa_ntm.snd_hd)
   also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) \<odot> MP_oalist ys"
     by (simp only: eq)
   finally show "MP_oalist xs \<odot> MP_oalist ys =
                 (let ct = OAlist_hd_ntm xs in
                   monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) \<odot> MP_oalist ys)"
     by (simp add: ct_def Let_def)
 qed
 
 end (* ordered_nat_term *)
 
 subsubsection \<open>Special case of addition: adding monomials\<close>
 
 definition plus_monomial_less :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::monoid_add)"
   where "plus_monomial_less p c u = p + monomial c u"
 
 text \<open>@{const plus_monomial_less} is useful when adding a monomial to a polynomial, where the term
   of the monomial is known to be smaller than all terms in the polynomial, because it can be
   implemented more efficiently than general addition.\<close>
 
 lemma plus_monomial_less_MP_oalist [code]:
   "plus_monomial_less (MP_oalist xs) c u = MP_oalist (OAlist_update_by_fun_gr_ntm u (\<lambda>c0. c0 + c) xs)"
   unfolding plus_monomial_less_def oa_ntm.update_by_fun_gr_eq_update_by_fun
   by (rule poly_mapping_eqI, simp add: lookup_plus_fun oa_ntm.lookup_update_by_fun lookup_single)
 
 text \<open>@{const plus_monomial_less} is computed by @{const OAlist_update_by_fun_gr_ntm}, because greater
   terms come @{emph \<open>before\<close>} smaller ones in @{type oalist_ntm}.\<close>
 
 subsubsection \<open>Constructors\<close>
 
 definition "distr\<^sub>0 ko xs = MP_oalist (oalist_of_list_ntm (xs, ko))" \<comment>\<open>sparse representation\<close>
 
 definition V\<^sub>0 :: "'a \<Rightarrow> ('a, nat) pp \<Rightarrow>\<^sub>0 'b::{one,zero}" where
   "V\<^sub>0 n \<equiv> monomial 1 (single_pp n 1)"
 
 definition C\<^sub>0 :: "'b \<Rightarrow> ('a, nat) pp \<Rightarrow>\<^sub>0 'b::zero" where "C\<^sub>0 c \<equiv> monomial c 0"
 
 lemma C\<^sub>0_one: "C\<^sub>0 1 = 1"
   by (simp add: C\<^sub>0_def)
 
 lemma C\<^sub>0_numeral: "C\<^sub>0 (numeral x) = numeral x"
   by (auto intro!: poly_mapping_eqI simp: C\<^sub>0_def lookup_numeral)
 
 lemma C\<^sub>0_minus: "C\<^sub>0 (- x) = - C\<^sub>0 x"
   by (simp add: C\<^sub>0_def single_uminus)
 
 lemma C\<^sub>0_zero: "C\<^sub>0 0 = 0"
   by (auto intro!: poly_mapping_eqI simp: C\<^sub>0_def)
 
 lemma V\<^sub>0_power: "V\<^sub>0 v ^ n = monomial 1 (single_pp v n)"
   by (induction n) (auto simp: V\<^sub>0_def mult_single single_pp_plus)
 
 lemma single_MP_oalist [code]: "Poly_Mapping.single k v = distr\<^sub>0 nat_term_order_of_le [(k, v)]"
   unfolding distr\<^sub>0_def by (rule poly_mapping_eqI, simp add: lookup_single OAlist_lookup_ntm_single)
 
 lemma one_MP_oalist [code]: "1 = distr\<^sub>0 nat_term_order_of_le [(0, 1)]"
   by (metis single_MP_oalist single_one)
 
 lemma except_MP_oalist [code]: "except (MP_oalist xs) S = MP_oalist (OAlist_filter_ntm (\<lambda>kv. fst kv \<notin> S) xs)"
   by (rule poly_mapping_eqI, simp add: lookup_except oa_ntm.lookup_filter)
 
 subsubsection \<open>Changing the Internal Order\<close>
 
 definition change_ord :: "'a::nat_term_compare nat_term_order \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)"
   where "change_ord to = (\<lambda>x. x)"
 
 lemma change_ord_MP_oalist [code]: "change_ord to (MP_oalist xs) = MP_oalist (OAlist_reorder_ntm to xs)"
   by (rule poly_mapping_eqI, simp add: change_ord_def oa_ntm.lookup_reorder)
 
 subsubsection \<open>Ordered Power-Products\<close>
 
 lemma foldl_assoc:
   assumes "\<And>x y z. f (f x y) z = f x (f y z)"
   shows "foldl f (f a b) xs = f a (foldl f b xs)"
 proof (induct xs arbitrary: a b)
   fix a b
   show "foldl f (f a b) [] = f a (foldl f b [])" by simp
 next
   fix a b x xs
   assume "\<And>a b. foldl f (f a b) xs = f a (foldl f b xs)"
   from assms[of a b x] this[of a "f b x"]
     show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
   qed
 
 context gd_nat_term
 begin
 
 definition ord_pp :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "ord_pp s t = le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
 
 definition ord_pp_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "ord_pp_strict s t = lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
 
 lemma lt_MP_oalist [code]:
   "lt (MP_oalist xs) = (if is_zero (MP_oalist xs) then min_term else fst (OAlist_min_key_val_ntm cmp_term xs))"
 proof (split if_split, intro conjI impI)
   assume "is_zero (MP_oalist xs)"
   thus "lt (MP_oalist xs) = min_term" by (simp add: is_zero_def)
 next
   assume "\<not> is_zero (MP_oalist xs)"
   hence "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
   show "lt (MP_oalist xs) = fst (OAlist_min_key_val_ntm cmp_term xs)"
   proof (rule lt_eqI_keys)
     show "fst (OAlist_min_key_val_ntm cmp_term xs) \<in> keys (MP_oalist xs)"
       by (simp add: keys_MP_oalist, rule imageI, rule oa_ntm.min_key_val_in, fact)
   next
     fix u
     assume "u \<in> keys (MP_oalist xs)"
     also have "... = fst ` set (fst (list_of_oalist_ntm xs))" by (simp add: keys_MP_oalist)
     finally obtain z where "z \<in> set (fst (list_of_oalist_ntm xs))" and "u = fst z" ..
     from this(1) have "ko.le (key_order_of_nat_term_order_inv cmp_term) (fst (OAlist_min_key_val_ntm cmp_term xs)) u"
       unfolding \<open>u = fst z\<close> by (rule oa_ntm.min_key_val_minimal)
     thus "le_of_nat_term_order cmp_term u (fst (OAlist_min_key_val_ntm cmp_term xs))"
       by (simp add: le_of_nat_term_order_alt)
   qed
 qed
 
 lemma lc_MP_oalist [code]:
   "lc (MP_oalist xs) = (if is_zero (MP_oalist xs) then 0 else snd (OAlist_min_key_val_ntm cmp_term xs))"
 proof (split if_split, intro conjI impI)
   assume "is_zero (MP_oalist xs)"
   thus "lc (MP_oalist xs) = 0" by (simp add: is_zero_def)
 next
   assume "\<not> is_zero (MP_oalist xs)"
   moreover from this have "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
   ultimately show "lc (MP_oalist xs) = snd (OAlist_min_key_val_ntm cmp_term xs)"
     by (simp add: lc_def lt_MP_oalist oa_ntm.snd_min_key_val)
 qed
 
 lemma tail_MP_oalist [code]: "tail (MP_oalist xs) = MP_oalist (OAlist_except_min_ntm cmp_term xs)"
 proof (cases "is_zero (MP_oalist xs)")
   case True
   hence "fst (list_of_oalist_ntm xs) = []" by (simp add: is_zero_MP_oalist List.null_def)
   hence "fst (list_of_oalist_ntm (OAlist_except_min_ntm cmp_term xs)) = []"
     by (rule oa_ntm.except_min_Nil)
   hence "is_zero (MP_oalist (OAlist_except_min_ntm cmp_term xs))"
     by (simp add: is_zero_MP_oalist List.null_def)
   with True show ?thesis by (simp add: is_zero_def)
 next
   case False
   show ?thesis by (rule poly_mapping_eqI, simp add: lookup_tail_2 oa_ntm.lookup_except_min' lt_MP_oalist False)
 qed
 
 definition comp_opt_p :: "('t \<Rightarrow>\<^sub>0 'c::zero, 't \<Rightarrow>\<^sub>0 'c) comp_opt"
   where "comp_opt_p p q =
               (if p = q then Some Eq else if ord_strict_p p q then Some Lt else if ord_strict_p q p then Some Gt else None)"
 
 lemma comp_opt_p_MP_oalist [code]:
   "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
     OAlist_lex_ord_ntm cmp_term (\<lambda>_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None) xs ys"
 proof -
   let ?f = "\<lambda>_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None"
   show ?thesis
   proof (cases "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Eq")
     case True
     hence "MP_oalist xs = MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
     hence "lookup (MP_oalist xs) = lookup (MP_oalist ys)" by (rule arg_cong)
     hence eq: "OAlist_lookup_ntm xs = OAlist_lookup_ntm ys" by simp
     have "OAlist_lex_ord_ntm cmp_term ?f xs ys = Some Eq"
       by (rule oa_ntm.lex_ord_EqI, simp add: eq)
     with True show ?thesis by simp
   next
     case False
     hence neq: "MP_oalist xs \<noteq> MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
     then obtain v where 1: "v \<in> keys (MP_oalist xs) \<union> keys (MP_oalist ys)"
       and 2: "lookup (MP_oalist xs) v \<noteq> lookup (MP_oalist ys) v"
       and 3: "\<And>u. lt_of_nat_term_order cmp_term v u \<Longrightarrow> lookup (MP_oalist xs) u = lookup (MP_oalist ys) u"
       by (rule poly_mapping_neqE, blast)
     show ?thesis
     proof (rule HOL.sym, rule oa_ntm.lex_ord_valI)
       from 1 show "v \<in> fst ` set (fst (list_of_oalist_ntm xs)) \<union> fst ` set (fst (list_of_oalist_ntm ys))"
         by (simp add: keys_MP_oalist)
     next
       from 2 have 4: "OAlist_lookup_ntm xs v \<noteq> OAlist_lookup_ntm ys v" by simp
       show "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
             (if OAlist_lookup_ntm xs v = OAlist_lookup_ntm ys v then Some Eq
              else if OAlist_lookup_ntm xs v = 0 then Some Lt
              else if OAlist_lookup_ntm ys v = 0 then Some Gt else None)"
       proof (simp add: 4, intro conjI impI)
         assume "OAlist_lookup_ntm ys v = 0" and "OAlist_lookup_ntm xs v = 0"
         with 4 show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by simp
       next
         assume "OAlist_lookup_ntm xs v \<noteq> 0" and "OAlist_lookup_ntm ys v = 0"
         hence "lookup (MP_oalist ys) v = 0" and "lookup (MP_oalist xs) v \<noteq> 0" by simp_all
         hence "ord_strict_p (MP_oalist ys) (MP_oalist xs)" using 3[symmetric]
           by (rule ord_strict_pI)
         with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Gt" by (auto simp: comp_opt_p_def)
       next
         assume "OAlist_lookup_ntm ys v \<noteq> 0" and "OAlist_lookup_ntm xs v = 0"
         hence "lookup (MP_oalist xs) v = 0" and "lookup (MP_oalist ys) v \<noteq> 0" by simp_all
         hence "ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule ord_strict_pI)
         with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by (auto simp: comp_opt_p_def)
       next
         assume "OAlist_lookup_ntm xs v \<noteq> 0"
         hence "lookup (MP_oalist xs) v \<noteq> 0" by simp
         with 2 have a: "\<not> ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule not_ord_strict_pI)
         assume "OAlist_lookup_ntm ys v \<noteq> 0"
         hence "lookup (MP_oalist ys) v \<noteq> 0" by simp
         with 2[symmetric] have "\<not> ord_strict_p (MP_oalist ys) (MP_oalist xs)"
           using 3[symmetric] by (rule not_ord_strict_pI)
         with neq a show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = None" by (auto simp: comp_opt_p_def)
       qed
     next
       fix u
       assume "ko.lt (key_order_of_nat_term_order_inv cmp_term) u v"
       hence "lt_of_nat_term_order cmp_term v u" by (simp only: lt_of_nat_term_order_alt)
       hence "lookup (MP_oalist xs) u = lookup (MP_oalist ys) u" by (rule 3)
       thus "(if OAlist_lookup_ntm xs u = OAlist_lookup_ntm ys u then Some Eq
             else if OAlist_lookup_ntm xs u = 0 then Some Lt
             else if OAlist_lookup_ntm ys u = 0 then Some Gt else None) = Some Eq" by simp
     qed fact
   qed
 qed
 
 lemma compute_ord_p [code]: "ord_p p q = (let aux = comp_opt_p p q in aux = Some Lt \<or> aux = Some Eq)"
   by (auto simp: ord_p_def comp_opt_p_def)
 
 lemma compute_ord_p_strict [code]: "ord_strict_p p q = (comp_opt_p p q = Some Lt)"
   by (auto simp: comp_opt_p_def)
 
 lemma keys_to_list_MP_oalist [code]: "keys_to_list (MP_oalist xs) = OAlist_sorted_domain_ntm cmp_term xs"
 proof -
   have eq: "ko.lt (key_order_of_nat_term_order_inv cmp_term) = ord_term_strict_conv"
     by (intro ext, simp add: lt_of_nat_term_order_alt)
   have 1: "irreflp ord_term_strict_conv" by (rule irreflpI, simp)
   have 2: "transp ord_term_strict_conv" by (rule transpI, simp)
   have "antisymp ord_term_strict_conv" by (rule antisympI, simp)
   moreover have 3: "sorted_wrt ord_term_strict_conv (keys_to_list (MP_oalist xs))"
     unfolding keys_to_list_def by (fact pps_to_list_sorted_wrt)
   moreover note _
   moreover have 4: "sorted_wrt ord_term_strict_conv (OAlist_sorted_domain_ntm cmp_term xs)"
     unfolding eq[symmetric] by (fact oa_ntm.sorted_sorted_domain)
   ultimately show ?thesis
   proof (rule sorted_wrt_distinct_set_unique)
     from 1 2 3 show "distinct (keys_to_list (MP_oalist xs))" by (rule distinct_sorted_wrt_irrefl)
   next
     from 1 2 4 show "distinct (OAlist_sorted_domain_ntm cmp_term xs)" by (rule distinct_sorted_wrt_irrefl)
   next
     show "set (keys_to_list (MP_oalist xs)) = set (OAlist_sorted_domain_ntm cmp_term xs)"
       by (simp add: set_keys_to_list keys_MP_oalist oa_ntm.set_sorted_domain)
   qed
 qed
 
 end (* ordered_nat_term *)
 
 lifting_update poly_mapping.lifting
 lifting_forget poly_mapping.lifting
 
 subsection \<open>Interpretations\<close>
 
 lemma term_powerprod_gd_term:
   fixes pair_of_term :: "'t::nat_term \<Rightarrow> ('a::{graded_dickson_powerprod,nat_pp_compare} \<times> 'k::{the_min,wellorder})"
   assumes "term_powerprod pair_of_term term_of_pair"
     and "\<And>v. fst (rep_nat_term v) = rep_nat_pp (fst (pair_of_term v))"
     and "\<And>t. snd (rep_nat_term (term_of_pair (t, the_min))) = 0"
     and "\<And>v w. snd (pair_of_term v) \<le> snd (pair_of_term w) \<Longrightarrow> snd (rep_nat_term v) \<le> snd (rep_nat_term w)"
     and "\<And>s t k. term_of_pair (s + t, k) = splus (term_of_pair (s, k)) (term_of_pair (t, k))"
     and "\<And>t v. term_powerprod.splus pair_of_term term_of_pair t v = splus (term_of_pair (t, the_min)) v"
   shows "gd_term pair_of_term term_of_pair
         (\<lambda>s t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
         (\<lambda>s t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
         (le_of_nat_term_order cmp_term)
         (lt_of_nat_term_order cmp_term)"
 proof -
   from assms(1) interpret tp: term_powerprod pair_of_term term_of_pair .
   let ?f = "\<lambda>x. term_of_pair (x, the_min)"
   show ?thesis
   proof (intro gd_term.intro ordered_term.intro)
     from assms(1) show "term_powerprod pair_of_term term_of_pair" .
   next
     show "ordered_powerprod (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
                         (\<lambda>s t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
     proof (intro ordered_powerprod.intro ordered_powerprod_axioms.intro)
       show "class.linorder (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
                         (\<lambda>s t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
       proof (unfold_locales, simp_all add: lt_of_nat_term_order_alt le_of_nat_term_order_alt ko.linear ko.less_le_not_le)
         fix x y
         assume "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (x, the_min)) (term_of_pair (y, the_min))"
           and "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (y, the_min)) (term_of_pair (x, the_min))"
         hence "term_of_pair (x, the_min) = term_of_pair (y, the_min)"
           by (rule ko.antisym)
         hence "(x, the_min) = (y, the_min::'k)" by (rule tp.term_of_pair_injective)
         thus "x = y" by simp
       qed
     next
       fix t
       show "le_of_nat_term_order cmp_term (?f 0) (?f t)"
         unfolding le_of_nat_term_order
         by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare,
             simp add: assms(3), simp add: assms(2) zero_pp tp.pair_term)
     next
       fix s t u
       assume "le_of_nat_term_order cmp_term (?f s) (?f t)"
       hence "le_of_nat_term_order cmp_term (?f (u + s)) (?f (u + t))"
         by (simp add: le_of_nat_term_order assms(5) nat_term_compare_splus)
       thus "le_of_nat_term_order cmp_term (?f (s + u)) (?f (t + u))" by (simp only: ac_simps)
     qed
   next
     show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
       by (fact linorder_le_of_nat_term_order)
   next
     show "ordered_term_axioms pair_of_term term_of_pair (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
        (le_of_nat_term_order cmp_term)"
     proof
       fix v w t
       assume "le_of_nat_term_order cmp_term v w"
       thus "le_of_nat_term_order cmp_term (t \<oplus> v) (t \<oplus> w)"
         by (simp add: le_of_nat_term_order assms(6) nat_term_compare_splus)
     next
       fix v w
       assume "le_of_nat_term_order cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w))"
       hence 3: "nat_term_compare cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w)) \<noteq> Gt"
         by (simp add: le_of_nat_term_order)
       assume "tp.component_of_term v \<le> tp.component_of_term w"
       hence 4: "snd (rep_nat_term v) \<le> snd (rep_nat_term w)"
         by (simp add: tp.component_of_term_def assms(4))
       note comparator_nat_term_compare nat_term_comp_nat_term_compare
       moreover have "fst (rep_nat_term v) = fst (rep_nat_term (?f (tp.pp_of_term v)))"
         by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
       moreover have "fst (rep_nat_term w) = fst (rep_nat_term (?f (tp.pp_of_term w)))"
         by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
       moreover note 4
       moreover have "snd (rep_nat_term (?f (tp.pp_of_term v))) = snd (rep_nat_term (?f (tp.pp_of_term w)))"
         by (simp add: assms(3))
       ultimately show "le_of_nat_term_order cmp_term v w" unfolding le_of_nat_term_order using 3
         by (rule nat_term_compD4'')
     qed
   qed
 qed
 
 lemma gd_term_to_pair_unit:
   "gd_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _) fst
         (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
         (\<lambda>s t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
         (le_of_nat_term_order cmp_term)
         (lt_of_nat_term_order cmp_term)"
 proof (intro gd_term.intro ordered_term.intro)
   show "term_powerprod to_pair_unit fst" by unfold_locales
 next
   show "ordered_powerprod (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
                       (\<lambda>s t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))"
     unfolding fst_conv using linorder_le_of_nat_term_order
   proof (intro ordered_powerprod.intro)
     from le_of_nat_term_order_zero_min show "ordered_powerprod_axioms (le_of_nat_term_order cmp_term)"
     proof (unfold_locales)
       fix s t u
       assume "le_of_nat_term_order cmp_term s t"
       hence "le_of_nat_term_order cmp_term (u + s) (u + t)" by (rule le_of_nat_term_order_plus_monotone)
       thus "le_of_nat_term_order cmp_term (s + u) (t + u)" by (simp only: ac_simps)
     qed
   qed
 next
   show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
     by (fact linorder_le_of_nat_term_order)
 next
   show "ordered_term_axioms to_pair_unit fst (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
      (le_of_nat_term_order cmp_term)" by (unfold_locales, auto intro: le_of_nat_term_order_plus_monotone)
 qed
 
 corollary gd_nat_term_to_pair_unit:
   "gd_nat_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _) fst cmp_term"
   by (rule gd_nat_term.intro, fact gd_term_to_pair_unit, rule gd_nat_term_axioms.intro, simp add: splus_pp_term)
 
 lemma gd_term_id:
   "gd_term (\<lambda>x::('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} \<times> 'b::{nat,the_min}). x) (\<lambda>x. x)
         (\<lambda>s t. le_of_nat_term_order cmp_term (s, the_min) (t, the_min))
         (\<lambda>s t. lt_of_nat_term_order cmp_term (s, the_min) (t, the_min))
         (le_of_nat_term_order cmp_term)
         (lt_of_nat_term_order cmp_term)"
   apply (rule term_powerprod_gd_term)
   subgoal by unfold_locales
   subgoal by (simp add: rep_nat_term_prod_def)
   subgoal by (simp add: rep_nat_term_prod_def the_min_eq_zero)
   subgoal by (simp add: rep_nat_term_prod_def ord_iff[symmetric])
   subgoal by (simp add: splus_prod_def pprod.splus_def)
   subgoal by (simp add: splus_prod_def)
   done
 
 corollary gd_nat_term_id: "gd_nat_term (\<lambda>x. x) (\<lambda>x. x) cmp_term"
   for cmp_term :: "('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} \<times> 'c::{nat,the_min}) nat_term_order"
   by (rule gd_nat_term.intro, fact gd_term_id, rule gd_nat_term_axioms.intro, simp add: splus_prod_def)
 
 subsection \<open>Computations\<close>
 
 type_synonym 'a mpoly_tc = "(nat, nat) pp \<Rightarrow>\<^sub>0 'a"
 
 global_interpretation punit0: gd_nat_term "to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _" fst cmp_term
   rewrites "punit.adds_term = (adds)"
   and "punit.pp_of_term = (\<lambda>x. x)"
   and "punit.component_of_term = (\<lambda>_. ())"
   for cmp_term
   defines monom_mult_punit = punit.monom_mult
   and mult_scalar_punit = punit.mult_scalar
   and shift_map_keys_punit = punit0.shift_map_keys
   and ord_pp_punit = punit0.ord_pp
   and ord_pp_strict_punit = punit0.ord_pp_strict
   and min_term_punit = punit0.min_term
   and lt_punit = punit0.lt
   and lc_punit = punit0.lc
   and tail_punit = punit0.tail
   and comp_opt_p_punit = punit0.comp_opt_p
   and ord_p_punit = punit0.ord_p
   and ord_strict_p_punit = punit0.ord_strict_p
   and keys_to_list_punit = punit0.keys_to_list
   subgoal by (fact gd_nat_term_to_pair_unit)
   subgoal by (fact punit_adds_term)
   subgoal by (fact punit_pp_of_term)
   subgoal by (fact punit_component_of_term)
   done
 
 lemma shift_map_keys_punit_MP_oalist [code abstract]:
   "list_of_oalist_ntm (shift_map_keys_punit t f xs) = map_raw (\<lambda>(k, v). (t + k, f v)) (list_of_oalist_ntm xs)"
   by (simp add: punit0.list_of_oalist_shift_keys case_prod_beta')
 
 lemmas [code] = punit0.mult_scalar_MP_oalist[unfolded mult_scalar_punit_def punit_mult_scalar]
                 punit0.punit_min_term
 
 lemma ord_pp_punit_alt [code_unfold]: "ord_pp_punit = le_of_nat_term_order"
   by (intro ext, simp add: punit0.ord_pp_def)
 
 lemma ord_pp_strict_punit_alt [code_unfold]: "ord_pp_strict_punit = lt_of_nat_term_order"
   by (intro ext, simp add: punit0.ord_pp_strict_def)
 
 lemma gd_powerprod_ord_pp_punit: "gd_powerprod (ord_pp_punit cmp_term) (ord_pp_strict_punit cmp_term)"
   unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..
 
 locale trivariate\<^sub>0_rat
 begin
 
 abbreviation X::"rat mpoly_tc" where "X \<equiv> V\<^sub>0 (0::nat)"
 abbreviation Y::"rat mpoly_tc" where "Y \<equiv> V\<^sub>0 (1::nat)"
 abbreviation Z::"rat mpoly_tc" where "Z \<equiv> V\<^sub>0 (2::nat)"
 
 end
 
 experiment begin interpretation trivariate\<^sub>0_rat .
 
 value [code] "X ^ 2"
 
 value [code] "X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2"
 
 value [code] "distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)] = distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0, 3)], 1)]"
 
 lemma
   "ord_strict_p_punit DRLEX (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) (X\<^sup>2 * Z\<^sup>2 + 2 * Y ^ 3 * Z\<^sup>2)"
   by eval
 
 lemma
   "tail_punit DLEX (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) = X\<^sup>2 * Z"
   by eval
 
 value [code] "min_term_punit::(nat, nat) pp"
 
 value [code] "is_zero (distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)])"
 
 value [code] "lt_punit DRLEX (distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)])"
 
 lemma
   "lt_punit DRLEX (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) = sparse\<^sub>0 [(1, 3), (2, 2)]"
   by eval
 
 lemma
   "lt_punit DRLEX (X + Y + Z) = sparse\<^sub>0 [(2, 1)]"
   by eval
 
 lemma
   "keys (X\<^sup>2 * Z ^ 3 + 2 * Y ^ 3 * Z\<^sup>2) =
     {sparse\<^sub>0 [(0, 2), (2, 3)], sparse\<^sub>0 [(1, 3), (2, 2)]}"
   by eval
 
 lemma
   "- 1 * X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2 = - X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2"
   by eval
 
 lemma
   "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 + X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 = X\<^sup>2 * Z ^ 7 + X\<^sup>2 * Z ^ 4"
   by eval
 
 lemma
   "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 - X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 =
     X\<^sup>2 * Z ^ 7 - X\<^sup>2 * Z ^ 4"
   by eval
 
 lemma
   "lookup (X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 + 2) (sparse\<^sub>0 [(0, 2), (2, 7)]) = 1"
   by eval
 
 lemma
   "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 \<noteq>
    X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2"
   by eval
 
 lemma
   "0 * X^2 * Z^7 + 0 * Y^3*Z\<^sup>2 = 0"
   by eval
 
 lemma
   "monom_mult_punit 3 (sparse\<^sub>0 [(1, 2::nat)]) (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) =
     3 * Y\<^sup>2 * Z * X\<^sup>2 + 6 * Y ^ 5 * Z\<^sup>2"
   by eval
 
 lemma
   "monomial (-4) (sparse\<^sub>0 [(0, 2::nat)]) = - 4 * X\<^sup>2"
   by eval
 
 lemma "monomial (0::rat) (sparse\<^sub>0 [(0::nat, 2::nat)]) = 0"
   by eval
 
 lemma
   "(X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) * (X\<^sup>2 * Z ^ 3 + - 2 * Y ^ 3 * Z\<^sup>2) =
     X ^ 4 * Z ^ 4 + - 2 * X\<^sup>2 * Z ^ 3 * Y ^ 3 +
  - 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X\<^sup>2"
   by eval
 
 end
 
 subsection \<open>Code setup for type MPoly\<close>
 
 text \<open>postprocessing from \<open>Var\<^sub>0, Const\<^sub>0\<close> to \<open>Var, Const\<close>.\<close>
 
 lemmas [code_post] =
   plus_mpoly.abs_eq[symmetric]
   times_mpoly.abs_eq[symmetric]
   one_mpoly_def[symmetric]
   Var.abs_eq[symmetric]
   Const.abs_eq[symmetric]
 
 instantiation mpoly::("{equal, zero}")equal begin
 
 lift_definition equal_mpoly:: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> bool" is HOL.equal .
 
 instance proof standard qed (transfer, rule equal_eq)
 
 end
 
 end (* theory *)
diff --git a/thys/Polynomials/OAlist.thy b/thys/Polynomials/OAlist.thy
--- a/thys/Polynomials/OAlist.thy
+++ b/thys/Polynomials/OAlist.thy
@@ -1,4282 +1,4282 @@
 (* Author: Florian Haftmann, TU Muenchen *)
 (* Author: Andreas Lochbihler, ETH Zurich *)
 (* Author: Alexander Maletzky, RISC Linz *)
 
 section \<open>Associative Lists with Sorted Keys\<close>
 
 theory OAlist
   imports Deriving.Comparator
 begin
 
 text \<open>We define the type of @{emph \<open>ordered associative lists\<close>} (oalist). An oalist is an associative
   list (i.\,e. a list of pairs) such that the keys are distinct and sorted wrt. some linear
   order relation, and no key is mapped to @{term 0}. The latter invariant allows to implement various
   functions operating on oalists more efficiently.
 
   The ordering of the keys in an oalist \<open>xs\<close> is encoded as an additional parameter of \<open>xs\<close>.
   This means that oalists may be ordered wrt. different orderings, even if they are of the same type.
   Operations operating on more than one oalists, like \<open>map2_val\<close>, typically ensure that the orderings
   of their arguments are identical by re-ordering one argument wrt. the order relation of the other.
   This, however, implies that equality of order relations must be effectively decidable if executable
   code is to be generated.\<close>
 
 subsection \<open>Preliminaries\<close>
 
 fun min_list_param :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a" where
   "min_list_param rel (x # xs) = (case xs of [] \<Rightarrow> x | _ \<Rightarrow> (let m = min_list_param rel xs in if rel x m then x else m))"
 
 lemma min_list_param_in:
   assumes "xs \<noteq> []"
   shows "min_list_param rel xs \<in> set xs"
   using assms
 proof (induct xs)
   case Nil
   thus ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
         intro conjI impI allI, simp, simp)
     fix y ys
     assume xs: "xs = y # ys"
     have "min_list_param rel (y # ys) = min_list_param rel xs" by (simp only: xs)
     also have "... \<in> set xs" by (rule Cons(1), simp add: xs)
     also have "... \<subseteq> set (x # y # ys)" by (auto simp: xs)
     finally show "min_list_param rel (y # ys) \<in> set (x # y # ys)" .
   qed
 qed
 
 lemma min_list_param_minimal:
   assumes "transp rel" and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> rel x y \<or> rel y x"
     and "z \<in> set xs"
   shows "rel (min_list_param rel xs) z"
   using assms(2, 3)
 proof (induct xs)
   case Nil
   from Nil(2) show ?case by simp
 next
   case (Cons x xs)
   from Cons(3) have disj1: "z = x \<or> z \<in> set xs" by simp
   have "x \<in> set (x # xs)" by simp
   hence disj2: "rel x z \<or> rel z x" using Cons(3) by (rule Cons(2))
   have *: "rel (min_list_param rel xs) z" if "z \<in> set xs" using _ that
   proof (rule Cons(1))
     fix a b
     assume "a \<in> set xs" and "b \<in> set xs"
     hence "a \<in> set (x # xs)" and "b \<in> set (x # xs)" by simp_all
     thus "rel a b \<or> rel b a" by (rule Cons(2))
   qed
   show ?case
   proof (simp add: min_list_param.simps[of rel x xs] Let_def del: min_list_param.simps set_simps(2) split: list.split,
         intro conjI impI allI)
     assume "xs = []"
     with disj1 disj2 show "rel x z" by simp
   next
     fix y ys
     assume "xs = y # ys" and "rel x (min_list_param rel (y # ys))"
     hence "rel x (min_list_param rel xs)" by simp
     from disj1 show "rel x z"
     proof
       assume "z = x"
       thus ?thesis using disj2 by simp
     next
       assume "z \<in> set xs"
       hence "rel (min_list_param rel xs) z" by (rule *)
       with assms(1) \<open>rel x (min_list_param rel xs)\<close> show ?thesis by (rule transpD)
     qed
   next
     fix y ys
     assume xs: "xs = y # ys" and "\<not> rel x (min_list_param rel (y # ys))"
     from disj1 show "rel (min_list_param rel (y # ys)) z"
     proof
       assume "z = x"
       have "min_list_param rel (y # ys) \<in> set (y # ys)" by (rule min_list_param_in, simp)
       hence "min_list_param rel (y # ys) \<in> set (x # xs)" by (simp add: xs)
       with \<open>x \<in> set (x # xs)\<close> have "rel x (min_list_param rel (y # ys)) \<or> rel (min_list_param rel (y # ys)) x"
         by (rule Cons(2))
       with \<open>\<not> rel x (min_list_param rel (y # ys))\<close> have "rel (min_list_param rel (y # ys)) x" by simp
       thus ?thesis by (simp only: \<open>z = x\<close>)
     next
       assume "z \<in> set xs"
       hence "rel (min_list_param rel xs) z" by (rule *)
       thus ?thesis by (simp only: xs)
     qed
   qed
 qed
 
 definition comp_of_ord :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a comparator" where
   "comp_of_ord le x y = (if le x y then if x = y then Eq else Lt else Gt)"
 
 lemma comp_of_ord_eq_comp_of_ords:
   assumes "antisymp le"
   shows "comp_of_ord le = comp_of_ords le (\<lambda>x y. le x y \<and> \<not> le y x)"
   by (intro ext, auto simp: comp_of_ord_def comp_of_ords_def intro: assms antisympD)
 
 lemma comparator_converse:
   assumes "comparator cmp"
   shows "comparator (\<lambda>x y. cmp y x)"
 proof -
   from assms interpret comp?: comparator cmp .
   show ?thesis by (unfold_locales, auto simp: comp.eq comp.sym intro: comp_trans)
 qed
 
 lemma comparator_composition:
   assumes "comparator cmp" and "inj f"
   shows "comparator (\<lambda>x y. cmp (f x) (f y))"
 proof -
   from assms(1) interpret comp?: comparator cmp .
   from assms(2) have *: "x = y" if "f x = f y" for x y using that by (rule injD)
   show ?thesis by (unfold_locales, auto simp: comp.sym comp.eq * intro: comp_trans)
 qed
 
 (*
 subsection \<open>Syntactic Type Class for Default Elements\<close>
 
 text \<open>We do not want to use the existing type-class @{class default}, but instead introduce a new one:\<close>
 
 class oalist_dflt = fixes dflt::'a
 
 simproc_setup reorient_dflt ("dflt = x") = Reorient_Proc.proc
 *)
 
 subsection \<open>Type \<open>key_order\<close>\<close>
 
 typedef 'a key_order = "{compare :: 'a comparator. comparator compare}"
   morphisms key_compare Abs_key_order
 proof -
   from well_order_on obtain r where "well_order_on (UNIV::'a set) r" ..
   hence "linear_order r" by (simp only: well_order_on_def)
   hence lin: "(x, y) \<in> r \<or> (y, x) \<in> r" for x y
     by (metis Diff_iff Linear_order_in_diff_Id UNIV_I \<open>well_order r\<close> well_order_on_Field)
   have antisym: "(x, y) \<in> r \<Longrightarrow> (y, x) \<in> r \<Longrightarrow> x = y" for x y
     by (meson \<open>linear_order r\<close> antisymD linear_order_on_def partial_order_on_def)
   have trans: "(x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r" for x y z
     by (meson \<open>linear_order r\<close> linear_order_on_def order_on_defs(1) partial_order_on_def trans_def)
   define comp where "comp = (\<lambda>x y. if (x, y) \<in> r then if (y, x) \<in> r then Eq else Lt else Gt)"
   show ?thesis
   proof (rule, simp)
     show "comparator comp"
     proof (standard, simp_all add: comp_def split: if_splits, intro impI)
       fix x y
       assume "(x, y) \<in> r" and "(y, x) \<in> r"
       thus "x = y" by (rule antisym)
     next
       fix x y
       assume "(x, y) \<notin> r"
       with lin show "(y, x) \<in> r" by blast
     next
       fix x y z
       assume "(y, x) \<notin> r" and "(z, y) \<notin> r"
       assume "(x, y) \<in> r" and "(y, z) \<in> r"
       hence "(x, z) \<in> r" by (rule trans)
       moreover have "(z, x) \<notin> r"
       proof
         assume "(z, x) \<in> r"
         with \<open>(x, z) \<in> r\<close> have "x = z" by (rule antisym)
         from \<open>(z, y) \<notin> r\<close> \<open>(x, y) \<in> r\<close> show False unfolding \<open>x = z\<close> ..
       qed
       ultimately show "(z, x) \<notin> r \<and> ((z, x) \<notin> r \<longrightarrow> (x, z) \<in> r)" by simp
     qed
   qed
 qed
 
 lemma comparator_key_compare [simp, intro!]: "comparator (key_compare ko)"
   using key_compare[of ko] by simp
 
 instantiation key_order :: (type) equal
 begin
 
 definition equal_key_order :: "'a key_order \<Rightarrow> 'a key_order \<Rightarrow> bool" where "equal_key_order = (=)"
 
 instance by (standard, simp add: equal_key_order_def)
 
 end
 
 setup_lifting type_definition_key_order
 
 instantiation key_order :: (type) uminus
 begin
 
 lift_definition uminus_key_order :: "'a key_order \<Rightarrow> 'a key_order" is "\<lambda>c x y. c y x"
   by (fact comparator_converse)
 
 instance ..
 
 end
 
 lift_definition le_of_key_order :: "'a key_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" is "\<lambda>cmp. le_of_comp cmp" .
 
 lift_definition lt_of_key_order :: "'a key_order \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" is "\<lambda>cmp. lt_of_comp cmp" .
 
 definition key_order_of_ord :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a key_order"
   where "key_order_of_ord ord = Abs_key_order (comp_of_ord ord)"
 
 lift_definition key_order_of_le :: "'a::linorder key_order" is comparator_of
   by (fact comparator_of)
 
 interpretation key_order_lin: linorder "le_of_key_order ko" "lt_of_key_order ko"
 proof transfer
   fix comp::"'a comparator"
   assume "comparator comp"
   then interpret comp: comparator comp .
   show "class.linorder comp.le comp.lt" by (fact comp.linorder)
 qed
 
 lemma le_of_key_order_alt: "le_of_key_order ko x y = (key_compare ko x y \<noteq> Gt)"
   by (transfer, simp add: comparator.nGt_le_conv)
 
 lemma lt_of_key_order_alt: "lt_of_key_order ko x y = (key_compare ko x y = Lt)"
   by (transfer, meson comparator.Lt_lt_conv)
 
 lemma key_compare_Gt: "key_compare ko x y = Gt \<longleftrightarrow> key_compare ko y x = Lt"
   by (transfer, meson comparator.nGt_le_conv comparator.nLt_le_conv)
 
 lemma key_compare_Eq: "key_compare ko x y = Eq \<longleftrightarrow> x = y"
   by (transfer, simp add: comparator.eq)
 
 lemma key_compare_same [simp]: "key_compare ko x x = Eq"
   by (simp add: key_compare_Eq)
 
 lemma uminus_key_compare [simp]: "invert_order (key_compare ko x y) = key_compare ko y x"
   by (transfer, simp add: comparator.sym)
 
 lemma key_compare_uminus [simp]: "key_compare (- ko) x y = key_compare ko y x"
   by (transfer, rule refl)
 
 lemma uminus_key_order_sameD:
   assumes "- ko = (ko::'a key_order)"
   shows "x = (y::'a)"
 proof (rule ccontr)
   assume "x \<noteq> y"
   hence "key_compare ko x y \<noteq> Eq" by (simp add: key_compare_Eq)
   hence "key_compare ko x y \<noteq> invert_order (key_compare ko x y)"
     by (metis invert_order.elims order.distinct(5))
   also have "invert_order (key_compare ko x y) = key_compare (- ko) x y" by simp
   finally have "- ko \<noteq> ko" by (auto simp del: key_compare_uminus)
   thus False using assms ..
 qed
 
 lemma key_compare_key_order_of_ord:
   assumes "antisymp ord" and "transp ord" and "\<And>x y. ord x y \<or> ord y x"
   shows "key_compare (key_order_of_ord ord) = (\<lambda>x y. if ord x y then if x = y then Eq else Lt else Gt)"
 proof -
   have eq: "key_compare (key_order_of_ord ord) = comp_of_ord ord"
     unfolding key_order_of_ord_def comp_of_ord_eq_comp_of_ords[OF assms(1)]
   proof (rule Abs_key_order_inverse, simp, rule comp_of_ords, unfold_locales)
     fix x
     from assms(3) show "ord x x" by blast
   next
     fix x y z
     assume "ord x y" and "ord y z"
     with assms(2) show "ord x z" by (rule transpD)
   next
     fix x y
     assume "ord x y" and "ord y x"
     with assms(1) show "x = y" by (rule antisympD)
   qed (rule refl, rule assms(3))
   have *: "x = y" if "ord x y" and "ord y x" for x y using assms(1) that by (rule antisympD)
   show ?thesis by (rule, rule, auto simp: eq comp_of_ord_def intro: *)
 qed
 
 lemma key_compare_key_order_of_le:
   "key_compare key_order_of_le = (\<lambda>x y. if x < y then Lt else if x = y then Eq else Gt)"
   by (transfer, intro ext, fact comparator_of_def)
 
 subsection \<open>Invariant in Context @{locale comparator}\<close>
 
 context comparator
 begin
 
 definition oalist_inv_raw :: "('a \<times> 'b::zero) list \<Rightarrow> bool"
   where "oalist_inv_raw xs \<longleftrightarrow> (0 \<notin> snd ` set xs \<and> sorted_wrt lt (map fst xs))"
 
 lemma oalist_inv_rawI:
   assumes "0 \<notin> snd ` set xs" and "sorted_wrt lt (map fst xs)"
   shows "oalist_inv_raw xs"
   unfolding oalist_inv_raw_def using assms unfolding fst_conv snd_conv by blast
 
 lemma oalist_inv_rawD1:
   assumes "oalist_inv_raw xs"
   shows "0 \<notin> snd ` set xs"
   using assms unfolding oalist_inv_raw_def fst_conv by blast
 
 lemma oalist_inv_rawD2:
   assumes "oalist_inv_raw xs"
   shows "sorted_wrt lt (map fst xs)"
   using assms unfolding oalist_inv_raw_def fst_conv snd_conv by blast
 
 lemma oalist_inv_raw_Nil: "oalist_inv_raw []"
   by (simp add: oalist_inv_raw_def)
 
 lemma oalist_inv_raw_singleton: "oalist_inv_raw [(k, v)] \<longleftrightarrow> (v \<noteq> 0)"
   by (auto simp: oalist_inv_raw_def)
 
 lemma oalist_inv_raw_ConsI:
   assumes "oalist_inv_raw xs" and "v \<noteq> 0" and "xs \<noteq> [] \<Longrightarrow> lt k (fst (hd xs))"
   shows "oalist_inv_raw ((k, v) # xs)"
 proof (rule oalist_inv_rawI)
   from assms(1) have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
   with assms(2) show "0 \<notin> snd ` set ((k, v) # xs)" by simp
 next
   show "sorted_wrt lt (map fst ((k, v) # xs))"
   proof (cases "xs = []")
     case True
     thus ?thesis by simp
   next
     case False
     then obtain k' v' xs' where xs: "xs = (k', v') # xs'" by (metis list.exhaust prod.exhaust)
     from assms(3)[OF False] have "lt k k'" by (simp add: xs)
     moreover from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
     ultimately show "sorted_wrt lt (map fst ((k, v) # xs))"
-      by (simp add: xs sorted_wrt2[OF transp_less] del: sorted_wrt.simps)
+      by (simp add: xs sorted_wrt2[OF transp_on_less] del: sorted_wrt.simps)
   qed
 qed
 
 lemma oalist_inv_raw_ConsD1:
   assumes "oalist_inv_raw (x # xs)"
   shows "oalist_inv_raw xs"
 proof (rule oalist_inv_rawI)
   from assms have "0 \<notin> snd ` set (x # xs)" by (rule oalist_inv_rawD1)
   thus "0 \<notin> snd ` set xs" by simp
 next
   from assms have "sorted_wrt lt (map fst (x # xs))" by (rule oalist_inv_rawD2)
   thus "sorted_wrt lt (map fst xs)" by simp
 qed
 
 lemma oalist_inv_raw_ConsD2:
   assumes "oalist_inv_raw ((k, v) # xs)"
   shows "v \<noteq> 0"
 proof -
   from assms have "0 \<notin> snd ` set ((k, v) # xs)" by (rule oalist_inv_rawD1)
   thus ?thesis by auto
 qed
 
 lemma oalist_inv_raw_ConsD3:
   assumes "oalist_inv_raw ((k, v) # xs)" and "k' \<in> fst ` set xs"
   shows "lt k k'"
 proof -
   from assms(2) obtain x where "x \<in> set xs" and "k' = fst x" by fastforce
   from assms(1) have "sorted_wrt lt (map fst ((k, v) # xs))" by (rule oalist_inv_rawD2)
   hence "\<forall>x\<in>set xs. lt k (fst x)" by simp
   hence "lt k (fst x)" using \<open>x \<in> set xs\<close> ..
   thus ?thesis by (simp only: \<open>k' = fst x\<close>)
 qed
 
 lemma oalist_inv_raw_tl:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (tl xs)"
 proof (rule oalist_inv_rawI)
   from assms have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
   thus "0 \<notin> snd ` set (tl xs)" by (metis (no_types, lifting) image_iff list.set_sel(2) tl_Nil)
 next
   show "sorted_wrt lt (map fst (tl xs))"
     by (metis hd_Cons_tl oalist_inv_rawD2 oalist_inv_raw_ConsD1 assms tl_Nil)
 qed
 
 lemma oalist_inv_raw_filter:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (filter P xs)"
 proof (rule oalist_inv_rawI)
   from assms have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
   thus "0 \<notin> snd ` set (filter P xs)" by auto
 next
   from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
   thus "sorted_wrt lt (map fst (filter P xs))" by (induct xs, simp, simp)
 qed
 
 lemma oalist_inv_raw_map:
   assumes "oalist_inv_raw xs"
     and "\<And>a. snd (f a) = 0 \<Longrightarrow> snd a = 0"
     and "\<And>a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
   shows "oalist_inv_raw (map f xs)"
 proof (rule oalist_inv_rawI)
   show "0 \<notin> snd ` set (map f xs)"
   proof (simp, rule)
     assume "0 \<in> snd ` f ` set xs"
     then obtain a where "a \<in> set xs" and "snd (f a) = 0" by fastforce
     from this(2) have "snd a = 0" by (rule assms(2))
     from assms(1) have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
     moreover from \<open>a \<in> set xs\<close> have "0 \<in> snd ` set xs" by (simp add: \<open>snd a = 0\<close>[symmetric])
     ultimately show False ..
   qed
 next
   from assms(1) have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
   hence "sorted_wrt (\<lambda>x y. comp (fst x) (fst y) = Lt) xs"
     by (simp only: sorted_wrt_map Lt_lt_conv)
   thus "sorted_wrt lt (map fst (map f xs))"
     by (simp add: sorted_wrt_map Lt_lt_conv[symmetric] assms(3))
 qed
 
 lemma oalist_inv_raw_induct [consumes 1, case_names Nil Cons]:
   assumes "oalist_inv_raw xs"
   assumes "P []"
   assumes "\<And>k v xs. oalist_inv_raw ((k, v) # xs) \<Longrightarrow> oalist_inv_raw xs \<Longrightarrow> v \<noteq> 0 \<Longrightarrow>
               (\<And>k'. k' \<in> fst ` set xs \<Longrightarrow> lt k k') \<Longrightarrow> P xs \<Longrightarrow> P ((k, v) # xs)"
   shows "P xs"
   using assms(1)
 proof (induct xs)
   case Nil
   from assms(2) show ?case .
 next
   case (Cons x xs)
   obtain k v where x: "x = (k, v)" by fastforce
   from Cons(2) have "oalist_inv_raw ((k, v) # xs)" and "oalist_inv_raw xs" and "v \<noteq> 0" unfolding x
     by (this, rule oalist_inv_raw_ConsD1, rule oalist_inv_raw_ConsD2)
   moreover from Cons(2) have "lt k k'" if "k' \<in> fst ` set xs" for k' using that
     unfolding x by (rule oalist_inv_raw_ConsD3)
   moreover from \<open>oalist_inv_raw xs\<close> have "P xs" by (rule Cons(1))
   ultimately show ?case unfolding x by (rule assms(3))
 qed
 
 subsection \<open>Operations on Lists of Pairs in Context @{locale comparator}\<close>
 
 type_synonym (in -) ('a, 'b) comp_opt = "'a \<Rightarrow> 'b \<Rightarrow> (order option)"
 
 definition (in -) lookup_dflt :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b::zero"
   where "lookup_dflt xs k = (case map_of xs k of Some v \<Rightarrow> v | None \<Rightarrow> 0)"
 
 text \<open>@{const lookup_dflt} is only an auxiliary function needed for proving some lemmas.\<close>
 
 fun lookup_pair :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b::zero"
 where
   "lookup_pair [] x = 0"|
   "lookup_pair ((k, v) # xs) x =
     (case comp x k of
        Lt \<Rightarrow> 0
      | Eq \<Rightarrow> v
      | Gt \<Rightarrow> lookup_pair xs x)"
 
 fun update_by_pair :: "('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b::zero) list"
 where
   "update_by_pair (k, v) [] = (if v = 0 then [] else [(k, v)])"
 | "update_by_pair (k, v) ((k', v') # xs) =
   (case comp k k' of Lt \<Rightarrow> (if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
                      | Eq \<Rightarrow> (if v = 0 then xs else (k, v) # xs)
                    | Gt \<Rightarrow> (k', v') # update_by_pair (k, v) xs)"
 
 (* TODO: Add update_by_gr_pair. *)
 
 definition sort_oalist :: "('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b::zero) list"
   where "sort_oalist xs = foldr update_by_pair xs []"
 
 fun update_by_fun_pair :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b::zero) list"
 where
   "update_by_fun_pair k f [] = (let v = f 0 in if v = 0 then [] else [(k, v)])"
 | "update_by_fun_pair k f ((k', v') # xs) =
   (case comp k k' of Lt \<Rightarrow> (let v = f 0 in if v = 0 then (k', v') # xs else (k, v) # (k', v') # xs)
                      | Eq \<Rightarrow> (let v = f v' in if v = 0 then xs else (k, v) # xs)
                    | Gt \<Rightarrow> (k', v') # update_by_fun_pair k f xs)"
 
 definition update_by_fun_gr_pair :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b::zero) list"
   where "update_by_fun_gr_pair k f xs =
           (if xs = [] then
             (let v = f 0 in if v = 0 then [] else [(k, v)])
           else if comp k (fst (last xs)) = Gt then
             (let v = f 0 in if v = 0 then xs else xs @ [(k, v)])
           else
             update_by_fun_pair k f xs
           )"
 
 fun (in -) map_pair :: "(('a \<times> 'b) \<Rightarrow> ('a \<times> 'c)) \<Rightarrow> ('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list"
 where
   "map_pair f [] = []"
 | "map_pair f (kv # xs) =
     (let (k, v) = f kv; aux = map_pair f xs in if v = 0 then aux else (k, v) # aux)"
 
 text \<open>The difference between @{const List.map} and @{const map_pair} is that the latter removes
   @{term 0} values, whereas the former does not.\<close>
 
 abbreviation (in -) map_val_pair :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list"
   where "map_val_pair f \<equiv> map_pair (\<lambda>(k, v). (k, f k v))"
 
 fun map2_val_pair :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> (('a \<times> 'b) list \<Rightarrow> ('a \<times> 'd) list) \<Rightarrow>
                       (('a \<times> 'c) list \<Rightarrow> ('a \<times> 'd) list) \<Rightarrow>
                       ('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list \<Rightarrow> ('a \<times> 'd::zero) list"
 where
   "map2_val_pair f g h xs [] = g xs"
 | "map2_val_pair f g h [] ys = h ys"
 | "map2_val_pair f g h ((kx, vx) # xs) ((ky, vy) # ys) =
     (case comp kx ky of
              Lt    \<Rightarrow> (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys) in if v = 0 then aux else (kx, v) # aux)
            | Eq   \<Rightarrow> (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
            | Gt \<Rightarrow> (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys in if v = 0 then aux else (ky, v) # aux))"
 
 fun lex_ord_pair :: "('a \<Rightarrow> (('b, 'c) comp_opt)) \<Rightarrow> (('a \<times> 'b::zero) list, ('a \<times> 'c::zero) list) comp_opt"
 where
   "lex_ord_pair f []       []       = Some Eq"|
   "lex_ord_pair f []       ((ky, vy) # ys) =
     (let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f [] ys else aux)"|
   "lex_ord_pair f ((kx, vx) # xs) []       =
     (let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs [] else aux)"|
   "lex_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
     (case comp kx ky of
              Lt    \<Rightarrow> (let aux = f kx vx 0 in if aux = Some Eq then lex_ord_pair f xs ((ky, vy) # ys) else aux)
            | Eq   \<Rightarrow> (let aux = f kx vx vy in if aux = Some Eq then lex_ord_pair f xs ys else aux)
            | Gt \<Rightarrow> (let aux = f ky 0 vy in if aux = Some Eq then lex_ord_pair f ((kx, vx) # xs) ys else aux))"
 
 fun prod_ord_pair :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list \<Rightarrow> bool"
 where
   "prod_ord_pair f []       []       = True"|
   "prod_ord_pair f []       ((ky, vy) # ys) = (f ky 0 vy \<and> prod_ord_pair f [] ys)"|
   "prod_ord_pair f ((kx, vx) # xs) []       = (f kx vx 0 \<and> prod_ord_pair f xs [])"|
   "prod_ord_pair f ((kx, vx) # xs) ((ky, vy) # ys) =
     (case comp kx ky of
              Lt    \<Rightarrow> (f kx vx 0 \<and> prod_ord_pair f xs ((ky, vy) # ys))
            | Eq   \<Rightarrow> (f kx vx vy \<and> prod_ord_pair f xs ys)
            | Gt \<Rightarrow> (f ky 0 vy \<and> prod_ord_pair f ((kx, vx) # xs) ys))"
 
 text \<open>@{const prod_ord_pair} is actually just a special case of @{const lex_ord_pair}, as proved below
   in lemma \<open>prod_ord_pair_eq_lex_ord_pair\<close>.\<close>
 
 subsubsection \<open>@{const lookup_pair}\<close>
 
 lemma lookup_pair_eq_0:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair xs k = 0 \<longleftrightarrow> (k \<notin> fst ` set xs)"
   using assms
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by simp
 next
   case (Cons k' v' xs)
   show ?case
   proof (simp add: Cons(3) eq split: order.splits, rule, simp_all only: atomize_imp[symmetric])
     assume "comp k k' = Lt"
     hence "k \<noteq> k'" by auto
     moreover have "k \<notin> fst ` set xs"
     proof
       assume "k \<in> fst ` set xs"
       hence "lt k' k" by (rule Cons(4))
       with \<open>comp k k' = Lt\<close> show False by (simp add: Lt_lt_conv)
     qed
     ultimately show "k \<noteq> k' \<and> k \<notin> fst ` set xs" ..
   next
     assume "comp k k' = Gt"
     hence "k \<noteq> k'" by auto
     thus "(lookup_pair xs k = 0) = (k \<noteq> k' \<and> k \<notin> fst ` set xs)" by (simp add: Cons(5))
   qed
 qed
 
 lemma lookup_pair_eq_value:
   assumes "oalist_inv_raw xs" and "v \<noteq> 0"
   shows "lookup_pair xs k = v \<longleftrightarrow> ((k, v) \<in> set xs)"
   using assms(1)
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   from assms(2) show ?case by simp
 next
   case (Cons k' v' xs)
   have *: "(k', u) \<notin> set xs" for u
   proof
     assume "(k', u) \<in> set xs"
     hence "fst (k', u) \<in> fst ` set xs" by fastforce
     hence "k' \<in> fst ` set xs" by simp
     hence "lt k' k'" by (rule Cons(4))
     thus False by (simp add: lt_of_key_order_alt[symmetric])
   qed
   show ?case
   proof (simp add: assms(2) Cons(5) eq split: order.split, intro conjI impI)
     assume "comp k k' = Lt"
     show "(k, v) \<notin> set xs"
     proof
       assume "(k, v) \<in> set xs"
       hence "fst (k, v) \<in> fst ` set xs" by fastforce
       hence "k \<in> fst ` set xs" by simp
       hence "lt k' k" by (rule Cons(4))
       with \<open>comp k k' = Lt\<close> show False by (simp add: Lt_lt_conv)
     qed
   qed (auto simp: *)
 qed
 
 lemma lookup_pair_eq_valueI:
   assumes "oalist_inv_raw xs" and "(k, v) \<in> set xs"
   shows "lookup_pair xs k = v"
 proof -
   from assms(2) have "v \<in> snd ` set xs" by force
   moreover from assms(1) have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
   ultimately have "v \<noteq> 0" by blast
   with assms show ?thesis by (simp add: lookup_pair_eq_value)
 qed
 
 lemma lookup_dflt_eq_lookup_pair:
   assumes "oalist_inv_raw xs"
   shows "lookup_dflt xs = lookup_pair xs"
 proof (rule, simp add: lookup_dflt_def split: option.split, intro conjI impI allI)
   fix k
   assume "map_of xs k = None"
   with assms show "lookup_pair xs k = 0" by (simp add: lookup_pair_eq_0 map_of_eq_None_iff)
 next
   fix k v
   assume "map_of xs k = Some v"
   hence "(k, v) \<in> set xs" by (rule map_of_SomeD)
   with assms have "lookup_pair xs k = v" by (rule lookup_pair_eq_valueI)
   thus "v = lookup_pair xs k" by (rule HOL.sym)
 qed
 
 lemma lookup_pair_inj:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lookup_pair xs = lookup_pair ys"
   shows "xs = ys"
   using assms
 proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
   case Nil
   thus ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     show ?case by simp
   next
     case (Cons k' v' ys)
     have "v' = lookup_pair ((k', v') # ys) k'" by simp
     also have "... = lookup_pair [] k'" by (simp only: Cons(6))
     also have "... = 0" by simp
     finally have "v' = 0" .
     with Cons(3) show ?case ..
   qed
 next
   case *: (Cons k v xs)
   from *(6, 7) show ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     have "v = lookup_pair ((k, v) # xs) k" by simp
     also have "... = lookup_pair [] k" by (simp only: Nil)
     also have "... = 0" by simp
     finally have "v = 0" .
     with *(3) show ?case ..
   next
     case (Cons k' v' ys)
     show ?case
     proof (cases "comp k k'")
       case Lt
       hence "\<not> lt k' k" by (simp add: Lt_lt_conv)
       with Cons(4) have "k \<notin> fst ` set ys" by blast
       moreover from Lt have "k \<noteq> k'" by auto
       ultimately have "k \<notin> fst ` set ((k', v') # ys)" by simp
       hence "0 = lookup_pair ((k', v') # ys) k"
         by (simp add: lookup_pair_eq_0[OF Cons(1)] del: lookup_pair.simps)
       also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6))
       also have "... = v" by simp
       finally have "v = 0" by simp
       with *(3) show ?thesis ..
     next
       case Eq
       hence "k' = k" by (simp only: eq)
       have "v' = lookup_pair ((k', v') # ys) k'" by simp
       also have "... = lookup_pair ((k, v) # xs) k" by (simp only: Cons(6) \<open>k' = k\<close>)
       also have "... = v" by simp
       finally have "v' = v" .
       moreover note \<open>k' = k\<close>
       moreover from Cons(2) have "xs = ys"
       proof (rule *(5))
         show "lookup_pair xs = lookup_pair ys"
         proof
           fix k0
           show "lookup_pair xs k0 = lookup_pair ys k0"
           proof (cases "lt k k0")
             case True
             hence eq: "comp k0 k = Gt"
               by (simp add: Gt_lt_conv)
             have "lookup_pair xs k0 = lookup_pair ((k, v) # xs) k0" by (simp add: eq)
             also have "... = lookup_pair ((k, v') # ys) k0" by (simp only: Cons(6) \<open>k' = k\<close>)
             also have "... = lookup_pair ys k0" by (simp add: eq)
             finally show ?thesis .
           next
             case False
             with *(4) have "k0 \<notin> fst ` set xs" by blast
             with *(2) have eq: "lookup_pair xs k0 = 0" by (simp add: lookup_pair_eq_0)
             from False Cons(4) have "k0 \<notin> fst ` set ys" unfolding \<open>k' = k\<close> by blast
             with Cons(2) have "lookup_pair ys k0 = 0" by (simp add: lookup_pair_eq_0)
             with eq show ?thesis by simp
           qed
         qed
       qed
       ultimately show ?thesis by simp
     next
       case Gt
       hence "\<not> lt k k'" by (simp add: Gt_lt_conv)
       with *(4) have "k' \<notin> fst ` set xs" by blast
       moreover from Gt have "k' \<noteq> k" by auto
       ultimately have "k' \<notin> fst ` set ((k, v) # xs)" by simp
       hence "0 = lookup_pair ((k, v) # xs) k'"
         by (simp add: lookup_pair_eq_0[OF *(1)] del: lookup_pair.simps)
       also have "... = lookup_pair ((k', v') # ys) k'" by (simp only: Cons(6))
       also have "... = v'" by simp
       finally have "v' = 0" by simp
       with Cons(3) show ?thesis ..
     qed
   qed
 qed
 
 lemma lookup_pair_tl:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (tl xs) k = (if (\<forall>k'\<in>fst ` set xs. le k k') then 0 else lookup_pair xs k)"
 proof -
   from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
   show ?thesis
   proof (split if_split, intro conjI impI)
     assume *: "\<forall>x\<in>fst ` set xs. le k x"
     show "lookup_pair (tl xs) k = 0"
     proof (simp add: lookup_pair_eq_0[OF 1], rule)
       assume k_in: "k \<in> fst ` set (tl xs)"
       hence "xs \<noteq> []" by auto
       then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
       have "k' \<in> fst ` set xs" unfolding xs by fastforce
       with * have "le k k'" ..
       from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
       moreover from k_in have "k \<in> fst ` set ys" by (simp add: xs)
       ultimately have "lt k' k" by (rule oalist_inv_raw_ConsD3)
       with \<open>le k k'\<close> show False by simp
     qed
   next
     assume "\<not> (\<forall>k'\<in>fst ` set xs. le k k')"
     hence "\<exists>x\<in>fst ` set xs. \<not> le k x" by simp
     then obtain k'' where k''_in: "k'' \<in> fst ` set xs" and "\<not> le k k''" ..
     from this(2) have "lt k'' k" by simp
     from k''_in have "xs \<noteq> []" by auto
     then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
     from k''_in have "k'' = k' \<or> k'' \<in> fst ` set ys" by (simp add: xs)
     hence "lt k' k"
     proof
       assume "k'' = k'"
       with \<open>lt k'' k\<close> show ?thesis by simp
     next
       from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
       moreover assume "k'' \<in> fst ` set ys"
       ultimately have "lt k' k''" by (rule oalist_inv_raw_ConsD3)
       thus ?thesis using \<open>lt k'' k\<close> by (rule less_trans)
     qed
     hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
     thus "lookup_pair (tl xs) k = lookup_pair xs k" by (simp add: xs lt_of_key_order_alt)
   qed
 qed
 
 lemma lookup_pair_tl':
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (tl xs) k = (if k = fst (hd xs) then 0 else lookup_pair xs k)"
 proof -
   from assms have 1: "oalist_inv_raw (tl xs)" by (rule oalist_inv_raw_tl)
   show ?thesis
   proof (split if_split, intro conjI impI)
     assume k: "k = fst (hd xs)"
     show "lookup_pair (tl xs) k = 0"
     proof (simp add: lookup_pair_eq_0[OF 1], rule)
       assume k_in: "k \<in> fst ` set (tl xs)"
       hence "xs \<noteq> []" by auto
       then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
       from assms have "oalist_inv_raw ((k', v') # ys)" by (simp only: xs)
       moreover from k_in have "k' \<in> fst ` set ys" by (simp add: k xs)
       ultimately have "lt k' k'" by (rule oalist_inv_raw_ConsD3)
       thus False by simp
     qed
   next
     assume "k \<noteq> fst (hd xs)"
     show "lookup_pair (tl xs) k = lookup_pair xs k"
     proof (cases "xs = []")
       case True
       show ?thesis by (simp add: True)
     next
       case False
       then obtain k' v' ys where xs: "xs = (k', v') # ys" using prod.exhaust list.exhaust by metis
       show ?thesis
       proof (simp add: xs eq Lt_lt_conv split: order.split, intro conjI impI)
         from \<open>k \<noteq> fst (hd xs)\<close> have "k \<noteq> k'" by (simp add: xs)
         moreover assume "k = k'"
         ultimately show "lookup_pair ys k' = v'" ..
       next
         assume "lt k k'"
         from assms have "oalist_inv_raw ys" unfolding xs by (rule oalist_inv_raw_ConsD1)
         moreover have "k \<notin> fst ` set ys"
         proof
           assume "k \<in> fst ` set ys"
           with assms have "lt k' k" unfolding xs by (rule oalist_inv_raw_ConsD3)
           with \<open>lt k k'\<close> show False by simp
         qed
         ultimately show "lookup_pair ys k = 0" by (simp add: lookup_pair_eq_0)
       qed
     qed
   qed
 qed
 
 lemma lookup_pair_filter:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (filter P xs) k = (let v = lookup_pair xs k in if P (k, v) then v else 0)"
   using assms
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by simp
 next
   case (Cons k' v' xs)
   show ?case
   proof (simp add: Cons(5) Let_def eq split: order.split, intro conjI impI)
     show "lookup_pair xs k' = 0"
     proof (simp add: lookup_pair_eq_0 Cons(2), rule)
       assume "k' \<in> fst ` set xs"
       hence "lt k' k'" by (rule Cons(4))
       thus False by simp
     qed
   next
     assume "comp k k' = Lt"
     hence "lt k k'" by (simp only: Lt_lt_conv)
     show "lookup_pair xs k = 0"
     proof (simp add: lookup_pair_eq_0 Cons(2), rule)
       assume "k \<in> fst ` set xs"
       hence "lt k' k" by (rule Cons(4))
       with \<open>lt k k'\<close> show False by simp
     qed
   qed
 qed
 
 lemma lookup_pair_map:
   assumes "oalist_inv_raw xs"
     and "\<And>k'. snd (f (k', 0)) = 0"
     and "\<And>a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
   shows "lookup_pair (map f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
   using assms(1)
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by (simp add: assms(2))
 next
   case (Cons k' v' xs)
   obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
   have "comp k k' = comp (fst (f (k, v))) (fst (f (k', v')))"
     by (simp add: assms(3))
   also have "... = comp (fst (f (k, v))) k''" by (simp add: f)
   finally have eq0: "comp k k' = comp (fst (f (k, v))) k''" .
   show ?case
   proof (simp add: assms(2) split: order.split, intro conjI impI, simp add: eq)
     assume "k = k'"
     hence "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) =
             lookup_pair (f (k', v') # map f xs) (fst (f (k, v)))" by simp
     also have "... = snd (f (k', v'))" by (simp add: f eq0[symmetric], simp add: \<open>k = k'\<close>)
     finally show "lookup_pair (f (k', v') # map f xs) (fst (f (k', v))) = snd (f (k', v'))" .
   qed (simp_all add: f eq0 Cons(5))
 qed
 
 lemma lookup_pair_Cons:
   assumes "oalist_inv_raw ((k, v) # xs)"
   shows "lookup_pair ((k, v) # xs) k0 = (if k = k0 then v else lookup_pair xs k0)"
 proof (simp add: eq split: order.split, intro impI)
   assume "comp k0 k = Lt"
   from assms have inv: "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
   show "lookup_pair xs k0 = 0"
   proof (simp only: lookup_pair_eq_0[OF inv], rule)
     assume "k0 \<in> fst ` set xs"
     with assms have "lt k k0" by (rule oalist_inv_raw_ConsD3)
     with \<open>comp k0 k = Lt\<close> show False by (simp add: Lt_lt_conv)
   qed
 qed
 
 lemma lookup_pair_single: "lookup_pair [(k, v)] k0 = (if k = k0 then v else 0)"
   by (simp add: eq split: order.split)
 
 subsubsection \<open>@{const update_by_pair}\<close>
 
 lemma set_update_by_pair_subset: "set (update_by_pair kv xs) \<subseteq> insert kv (set xs)"
 proof (induct xs arbitrary: kv)
   case Nil
   obtain k v where kv: "kv = (k, v)" by fastforce
   thus ?case by simp
 next
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by fastforce
   obtain k v where kv: "kv = (k, v)" by fastforce
   have 1: "set xs \<subseteq> insert a (insert b (set xs))" for a b by auto
   have 2: "set (update_by_pair kv xs) \<subseteq> insert kv (insert (k', v') (set xs))" for kv
     using Cons by blast
   show ?case by (simp add: x kv 1 2 split: order.split)
 qed
 
 lemma update_by_pair_sorted:
   assumes "sorted_wrt lt (map fst xs)"
   shows "sorted_wrt lt (map fst (update_by_pair kv xs))"
   using assms
 proof (induct xs arbitrary: kv)
   case Nil
   obtain k v where kv: "kv = (k, v)" by fastforce
   thus ?case by simp
 next
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by fastforce
   obtain k v where kv: "kv = (k, v)" by fastforce
   from Cons(2) have 1: "sorted_wrt lt (k' # (map fst xs))" by (simp add: x)
   hence 2: "sorted_wrt lt (map fst xs)" using sorted_wrt.elims(3) by fastforce
   hence 3: "sorted_wrt lt (map fst (update_by_pair (k, u) xs))" for u by (rule Cons(1))
   have 4: "sorted_wrt lt (k' # map fst (update_by_pair (k, u) xs))"
     if *: "comp k k' = Gt" for u
   proof (simp, intro conjI ballI)
     fix y
     assume "y \<in> set (update_by_pair (k, u) xs)"
     also from set_update_by_pair_subset have "... \<subseteq> insert (k, u) (set xs)" .
     finally have "y = (k, u) \<or> y \<in> set xs" by simp
     thus "lt k' (fst y)"
     proof
       assume "y = (k, u)"
       hence "fst y = k" by simp
       with * show ?thesis by (simp only: Gt_lt_conv)
     next
       from 1 have 5: "\<forall>y \<in> fst ` set xs. lt k' y" by simp
       assume "y \<in> set xs"
       hence "fst y \<in> fst ` set xs" by simp
       with 5 show ?thesis ..
     qed
   qed (fact 3)
   show ?case
     by (simp add: kv x 1 2 4 sorted_wrt2 split: order.split del: sorted_wrt.simps,
         intro conjI impI, simp add: 1 eq del: sorted_wrt.simps, simp add: Lt_lt_conv)
 qed
 
 lemma update_by_pair_not_0:
   assumes "0 \<notin> snd ` set xs"
   shows "0 \<notin> snd ` set (update_by_pair kv xs)"
   using assms
 proof (induct xs arbitrary: kv)
   case Nil
   obtain k v where kv: "kv = (k, v)" by fastforce
   thus ?case by simp
 next
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by fastforce
   obtain k v where kv: "kv = (k, v)" by fastforce
   from Cons(2) have 1: "v' \<noteq> 0" and 2: "0 \<notin> snd ` set xs" by (auto simp: x)
   from 2 have 3: "0 \<notin> snd ` set (update_by_pair (k, u) xs)" for u by (rule Cons(1))
   show ?case by (auto simp: kv x 1 2 3 split: order.split)
 qed
 
 corollary oalist_inv_raw_update_by_pair:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (update_by_pair kv xs)"
 proof (rule oalist_inv_rawI)
   from assms have "0 \<notin> snd ` set xs" by (rule oalist_inv_rawD1)
   thus "0 \<notin> snd ` set (update_by_pair kv xs)" by (rule update_by_pair_not_0)
 next
   from assms have "sorted_wrt lt (map fst xs)" by (rule oalist_inv_rawD2)
   thus "sorted_wrt lt (map fst (update_by_pair kv xs))" by (rule update_by_pair_sorted)
 qed
 
 lemma update_by_pair_less:
   assumes "v \<noteq> 0" and "xs = [] \<or> comp k (fst (hd xs)) = Lt"
   shows "update_by_pair (k, v) xs = (k, v) # xs"
   using assms(2)
 proof (induct xs)
 case Nil
   from assms(1) show ?case by simp
 next
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by fastforce
   from Cons(2) have "comp k k' = Lt" by (simp add: x)
   with assms(1) show ?case by (simp add: x)
 qed
 
 lemma lookup_pair_update_by_pair:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (update_by_pair (k1, v) xs) k2 = (if k1 = k2 then v else lookup_pair xs k2)"
   using assms
 proof (induct xs arbitrary: v rule: oalist_inv_raw_induct)
   case Nil
   show ?case by (simp split: order.split, simp add: eq)
 next
   case (Cons k' v' xs)
   show ?case
   proof (split if_split, intro conjI impI)
     assume "k1 = k2"
     with Cons(5) have eq0: "lookup_pair (update_by_pair (k2, u) xs) k2 = u" for u
       by (simp del: update_by_pair.simps)
     show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = v"
     proof (simp add: \<open>k1 = k2\<close> eq0 split: order.split, intro conjI impI)
       assume "comp k2 k' = Eq"
       hence "\<not> lt k' k2" by (simp add: eq)
       with Cons(4) have "k2 \<notin> fst ` set xs" by auto
       thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
     qed
   next
     assume "k1 \<noteq> k2"
     with Cons(5) have eq0: "lookup_pair (update_by_pair (k1, u) xs) k2 = lookup_pair xs k2" for u
       by (simp del: update_by_pair.simps)
     have *: "lookup_pair xs k2 = 0" if "lt k2 k'"
     proof -
       from \<open>lt k2 k'\<close> have "\<not> lt k' k2" by auto
       with Cons(4) have "k2 \<notin> fst ` set xs" by auto
       thus "lookup_pair xs k2 = 0" using Cons(2) by (simp add: lookup_pair_eq_0)
     qed
     show "lookup_pair (update_by_pair (k1, v) ((k', v') # xs)) k2 = lookup_pair ((k', v') # xs) k2"
       by (simp add: \<open>k1 \<noteq> k2\<close> eq0 split: order.split,
           auto intro: * simp: \<open>k1 \<noteq> k2\<close>[symmetric] eq Gt_lt_conv Lt_lt_conv)
   qed
 qed
 
 corollary update_by_pair_id:
   assumes "oalist_inv_raw xs" and "lookup_pair xs k = v"
   shows "update_by_pair (k, v) xs = xs"
 proof (rule lookup_pair_inj, rule oalist_inv_raw_update_by_pair)
   show "lookup_pair (update_by_pair (k, v) xs) = lookup_pair xs"
   proof
     fix k0
     from assms(2) show "lookup_pair (update_by_pair (k, v) xs) k0 = lookup_pair xs k0"
       by (auto simp: lookup_pair_update_by_pair[OF assms(1)])
   qed
 qed fact+
 
 lemma set_update_by_pair:
   assumes "oalist_inv_raw xs" and "v \<noteq> 0"
   shows "set (update_by_pair (k, v) xs) = insert (k, v) (set xs - range (Pair k))" (is "?A = ?B")
 proof (rule set_eqI)
   fix x::"'a \<times> 'b"
   obtain k' v' where x: "x = (k', v')" by fastforce
   from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, v) xs)"
     by (rule oalist_inv_raw_update_by_pair)
   show "(x \<in> ?A) \<longleftrightarrow> (x \<in> ?B)"
   proof (cases "v' = 0")
     case True
     have "0 \<notin> snd ` set (update_by_pair (k, v) xs)" and "0 \<notin> snd ` set xs"
       by (rule oalist_inv_rawD1, fact)+
     hence "(k', 0) \<notin> set (update_by_pair (k, v) xs)" and "(k', 0) \<notin> set xs"
       using image_iff by fastforce+
     thus ?thesis by (simp add: x True assms(2))
   next
     case False
     show ?thesis
       by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms(1) False]
           lookup_pair_update_by_pair[OF assms(1)])
   qed
 qed
 
 lemma set_update_by_pair_zero:
   assumes "oalist_inv_raw xs"
   shows "set (update_by_pair (k, 0) xs) = set xs - range (Pair k)" (is "?A = ?B")
 proof (rule set_eqI)
   fix x::"'a \<times> 'b"
   obtain k' v' where x: "x = (k', v')" by fastforce
   from assms(1) have inv: "oalist_inv_raw (update_by_pair (k, 0) xs)"
     by (rule oalist_inv_raw_update_by_pair)
   show "(x \<in> ?A) \<longleftrightarrow> (x \<in> ?B)"
   proof (cases "v' = 0")
     case True
     have "0 \<notin> snd ` set (update_by_pair (k, 0) xs)" and "0 \<notin> snd ` set xs"
       by (rule oalist_inv_rawD1, fact)+
     hence "(k', 0) \<notin> set (update_by_pair (k, 0) xs)" and "(k', 0) \<notin> set xs"
       using image_iff by fastforce+
     thus ?thesis by (simp add: x True)
   next
     case False
     show ?thesis
       by (auto simp: x lookup_pair_eq_value[OF inv False, symmetric] lookup_pair_eq_value[OF assms False]
           lookup_pair_update_by_pair[OF assms] False)
   qed
 qed
 
 subsubsection \<open>@{const update_by_fun_pair} and @{const update_by_fun_gr_pair}\<close>
 
 lemma update_by_fun_pair_eq_update_by_pair:
   assumes "oalist_inv_raw xs"
   shows "update_by_fun_pair k f xs = update_by_pair (k, f (lookup_pair xs k)) xs"
   using assms by (induct xs rule: oalist_inv_raw_induct, simp, simp split: order.split)
 
 corollary oalist_inv_raw_update_by_fun_pair:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (update_by_fun_pair k f xs)"
   unfolding update_by_fun_pair_eq_update_by_pair[OF assms] using assms by (rule oalist_inv_raw_update_by_pair)
 
 corollary lookup_pair_update_by_fun_pair:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (update_by_fun_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
   by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms] lookup_pair_update_by_pair[OF assms])
 
 lemma update_by_fun_pair_gr:
   assumes "oalist_inv_raw xs" and "xs = [] \<or> comp k (fst (last xs)) = Gt"
   shows "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
   using assms
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by simp
 next
   case (Cons k' v' xs)
   from Cons(6) have 1: "comp k (fst (last ((k', v') # xs))) = Gt" by simp
   have eq1: "comp k k' = Gt"
   proof (cases "xs = []")
     case True
     with 1 show ?thesis by simp
   next
     case False
     have "lt k' (fst (last xs))" by (rule Cons(4), simp add: False)
     from False 1 have "comp k (fst (last xs)) = Gt" by simp
     moreover from \<open>lt k' (fst (last xs))\<close> have "comp (fst (last xs)) k' = Gt"
       by (simp add: Gt_lt_conv)
     ultimately show ?thesis
       by (meson Gt_lt_conv less_trans Lt_lt_conv[symmetric])
   qed
   have eq2: "update_by_fun_pair k f xs = xs @ (if f 0 = 0 then [] else [(k, f 0)])"
   proof (rule Cons(5), simp only: disj_commute[of "xs = []"], rule disjCI)
     assume "xs \<noteq> []"
     with 1 show "comp k (fst (last xs)) = Gt" by simp
   qed
   show ?case by (simp split: order.split add: Let_def eq1 eq2)
 qed
 
 corollary update_by_fun_gr_pair_eq_update_by_fun_pair:
   assumes "oalist_inv_raw xs"
   shows "update_by_fun_gr_pair k f xs = update_by_fun_pair k f xs"
   by (simp add: update_by_fun_gr_pair_def Let_def update_by_fun_pair_gr[OF assms] split: order.split)
 
 corollary oalist_inv_raw_update_by_fun_gr_pair:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (update_by_fun_gr_pair k f xs)"
   unfolding update_by_fun_pair_eq_update_by_pair[OF assms] update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms]
   using assms by (rule oalist_inv_raw_update_by_pair)
 
 corollary lookup_pair_update_by_fun_gr_pair:
   assumes "oalist_inv_raw xs"
   shows "lookup_pair (update_by_fun_gr_pair k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_pair xs k2)"
   by (simp add: update_by_fun_pair_eq_update_by_pair[OF assms]
       update_by_fun_gr_pair_eq_update_by_fun_pair[OF assms] lookup_pair_update_by_pair[OF assms])
 
 subsubsection \<open>@{const map_pair}\<close>
 
 lemma map_pair_cong:
   assumes "\<And>kv. kv \<in> set xs \<Longrightarrow> f kv = g kv"
   shows "map_pair f xs = map_pair g xs"
   using assms
 proof (induct xs)
   case Nil
   show ?case by simp
 next
   case (Cons x xs)
   have "f x = g x" by (rule Cons(2), simp)
   moreover have "map_pair f xs = map_pair g xs" by (rule Cons(1), rule Cons(2), simp)
   ultimately show ?case by simp
 qed
 
 lemma map_pair_subset: "set (map_pair f xs) \<subseteq> f ` set xs"
 proof (induct xs rule: map_pair.induct)
   case (1 f)
   show ?case by simp
 next
   case (2 f kv xs)
   obtain k v where f: "f kv = (k, v)" by fastforce
   from f[symmetric] HOL.refl have *: "set (map_pair f xs) \<subseteq> f ` set xs"
     by (rule 2)
   show ?case by (simp add: f Let_def, intro conjI impI subset_insertI2 *)
 qed
 
 lemma oalist_inv_raw_map_pair:
   assumes "oalist_inv_raw xs"
     and "\<And>a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
   shows "oalist_inv_raw (map_pair f xs)"
   using assms(1)
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   from oalist_inv_raw_Nil show ?case by simp
 next
   case (Cons k v xs)
   obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
   show ?case
   proof (simp add: f Let_def Cons(5), rule)
     assume "v' \<noteq> 0"
     with Cons(5) show "oalist_inv_raw ((k', v') # map_pair f xs)"
     proof (rule oalist_inv_raw_ConsI)
       assume "map_pair f xs \<noteq> []"
       hence "hd (map_pair f xs) \<in> set (map_pair f xs)" by simp
       also have "... \<subseteq> f ` set xs" by (fact map_pair_subset)
       finally obtain x where "x \<in> set xs" and eq: "hd (map_pair f xs) = f x" ..
       from this(1) have "fst x \<in> fst ` set xs" by fastforce
       hence "lt k (fst x)" by (rule Cons(4))
       hence "lt (fst (f (k, v))) (fst (f x))"
         by (simp add: Lt_lt_conv[symmetric] assms(2))
       thus "lt k' (fst (hd (map_pair f xs)))" by (simp add: f eq)
     qed
   qed
 qed
 
 lemma lookup_pair_map_pair:
   assumes "oalist_inv_raw xs" and "snd (f (k, 0)) = 0"
     and "\<And>a b. comp (fst (f a)) (fst (f b)) = comp (fst a) (fst b)"
   shows "lookup_pair (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_pair xs k))"
   using assms(1)
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by (simp add: assms(2))
 next
   case (Cons k' v' xs)
   obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
   have "comp (fst (f (k, v))) k'' = comp (fst (f (k, v))) (fst (f (k', v')))"
     by (simp add: f)
   also have "... = comp k k'"
     by (simp add: assms(3))
   finally have eq0: "comp (fst (f (k, v))) k'' = comp k k'" .
   have *: "lookup_pair xs k = 0" if "comp k k' \<noteq> Gt"
   proof (simp add: lookup_pair_eq_0[OF Cons(2)], rule)
     assume "k \<in> fst ` set xs"
     hence "lt k' k" by (rule Cons(4))
     hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
     with \<open>comp k k' \<noteq> Gt\<close> show False ..
   qed
   show ?case
   proof (simp add: assms(2) f Let_def eq0 Cons(5) split: order.split, intro conjI impI)
     assume "comp k k' = Lt"
     hence "comp k k' \<noteq> Gt" by simp
     hence "lookup_pair xs k = 0" by (rule *)
     thus "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
   next
     assume "v'' = 0"
     assume "comp k k' = Eq"
     hence "k = k'" and "comp k k' \<noteq> Gt" by (simp only: eq, simp)
     from this(2) have "lookup_pair xs k = 0" by (rule *)
     hence "snd (f (k, lookup_pair xs k)) = 0" by (simp add: assms(2))
     also have "... = snd (f (k, v'))" by (simp add: \<open>k = k'\<close> f \<open>v'' = 0\<close>)
     finally show "snd (f (k, lookup_pair xs k)) = snd (f (k, v'))" .
   qed (simp add: f eq)
 qed
 
 lemma lookup_dflt_map_pair:
   assumes "distinct (map fst xs)" and "snd (f (k, 0)) = 0"
     and "\<And>a b. (fst (f a) = fst (f b)) \<longleftrightarrow> (fst a = fst b)"
   shows "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
   using assms(1)
 proof (induct xs)
   case Nil
   show ?case by (simp add: lookup_dflt_def assms(2))
 next
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by fastforce
   obtain k'' v'' where f: "f (k', v') = (k'', v'')" by fastforce
   from Cons(2) have "distinct (map fst xs)" and "k' \<notin> fst ` set xs" by (simp_all add: x)
   from this(1) have eq1: "lookup_dflt (map_pair f xs) (fst (f (k, v))) = snd (f (k, lookup_dflt xs k))"
     by (rule Cons(1))
   have eq2: "lookup_dflt ((a, b) # ys) c = (if c = a then b else lookup_dflt ys c)"
     for a b c and ys::"('b \<times> 'e::zero) list" by (simp add: lookup_dflt_def map_of_Cons_code)
   from \<open>k' \<notin> fst ` set xs\<close> have "map_of xs k' = None" by (simp add: map_of_eq_None_iff)
   hence eq3: "lookup_dflt xs k' = 0" by (simp add: lookup_dflt_def)
   show ?case
   proof (simp add: f Let_def x eq1 eq2 eq3, intro conjI impI)
     assume "k = k'"
     hence "snd (f (k', 0)) = snd (f (k, 0))" by simp
     also have "... = 0" by (fact assms(2))
     finally show "snd (f (k', 0)) = 0" .
   next
     assume "fst (f (k', v)) \<noteq> k''"
     hence "fst (f (k', v)) \<noteq> fst (f (k', v'))" by (simp add: f)
     thus "snd (f (k', 0)) = v''" by (simp add: assms(3))
   next
     assume "k \<noteq> k'"
     assume "fst (f (k, v)) = k''"
     also have "... = fst (f (k', v'))" by (simp add: f)
     finally have "k = k'" by (simp add: assms(3))
     with \<open>k \<noteq> k'\<close> show "v'' = snd (f (k, lookup_dflt xs k))" ..
   qed
 qed
 
 lemma distinct_map_pair:
   assumes "distinct (map fst xs)" and "\<And>a b. fst (f a) = fst (f b) \<Longrightarrow> fst a = fst b"
   shows "distinct (map fst (map_pair f xs))"
   using assms(1)
 proof (induct xs)
   case Nil
   show ?case by simp
 next
   case (Cons x xs)
   obtain k v where x: "x = (k, v)" by fastforce
   obtain k' v' where f: "f (k, v) = (k', v')" by fastforce
   from Cons(2) have "distinct (map fst xs)" and "k \<notin> fst ` set xs" by (simp_all add: x)
   from this(1) have 1: "distinct (map fst (map_pair f xs))" by (rule Cons(1))
   show ?case
   proof (simp add: x f Let_def 1, intro impI notI)
     assume "v' \<noteq> 0"
     assume "k' \<in> fst ` set (map_pair f xs)"
     then obtain y where "y \<in> set (map_pair f xs)" and "k' = fst y" ..
     from this(1) map_pair_subset have "y \<in> f ` set xs" ..
     then obtain z where "z \<in> set xs" and "y = f z" ..
     from this(2) have "fst (f z) = k'" by (simp add: \<open>k' = fst y\<close>)
     also have "... = fst (f (k, v))" by (simp add: f)
     finally have "fst z = fst (k, v)" by (rule assms(2))
     also have "... = k" by simp
     finally have "k \<in> fst ` set xs" using \<open>z \<in> set xs\<close> by blast
     with \<open>k \<notin> fst ` set xs\<close> show False ..
   qed
 qed
 
 lemma map_val_pair_cong:
   assumes "\<And>k v. (k, v) \<in> set xs \<Longrightarrow> f k v = g k v"
   shows "map_val_pair f xs = map_val_pair g xs"
 proof (rule map_pair_cong)
   fix kv
   assume "kv \<in> set xs"
   moreover obtain k v where "kv = (k, v)" by fastforce
   ultimately show "(case kv of (k, v) \<Rightarrow> (k, f k v)) = (case kv of (k, v) \<Rightarrow> (k, g k v))"
     by (simp add: assms)
 qed
 
 lemma oalist_inv_raw_map_val_pair:
   assumes "oalist_inv_raw xs"
   shows "oalist_inv_raw (map_val_pair f xs)"
   by (rule oalist_inv_raw_map_pair, fact assms, auto)
 
 lemma lookup_pair_map_val_pair:
   assumes "oalist_inv_raw xs" and "f k 0 = 0"
   shows "lookup_pair (map_val_pair f xs) k = f k (lookup_pair xs k)"
 proof -
   let ?f = "\<lambda>(k', v'). (k', f k' v')"
   have "lookup_pair (map_val_pair f xs) k = lookup_pair (map_val_pair f xs) (fst (?f (k, 0)))"
     by simp
   also have "... = snd (?f (k, local.lookup_pair xs k))"
     by (rule lookup_pair_map_pair, fact assms(1), auto simp: assms(2))
   also have "... = f k (lookup_pair xs k)" by simp
   finally show ?thesis .
 qed
 
 lemma map_pair_id:
   assumes "oalist_inv_raw xs"
   shows "map_pair id xs = xs"
   using assms
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by simp
 next
   case (Cons k v xs')
   show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
 qed
 
 subsubsection \<open>@{const map2_val_pair}\<close>
 
 definition map2_val_compat :: "(('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list) \<Rightarrow> bool"
   where "map2_val_compat f \<longleftrightarrow> (\<forall>zs. (oalist_inv_raw zs \<longrightarrow>
                                 (oalist_inv_raw (f zs) \<and> fst ` set (f zs) \<subseteq> fst ` set zs)))"
 
 lemma map2_val_compatI:
   assumes "\<And>zs. oalist_inv_raw zs \<Longrightarrow> oalist_inv_raw (f zs)"
     and "\<And>zs. oalist_inv_raw zs \<Longrightarrow> fst ` set (f zs) \<subseteq> fst ` set zs"
   shows "map2_val_compat f"
   unfolding map2_val_compat_def using assms by blast
 
 lemma map2_val_compatD1:
   assumes "map2_val_compat f" and "oalist_inv_raw zs"
   shows "oalist_inv_raw (f zs)"
   using assms unfolding map2_val_compat_def by blast
 
 lemma map2_val_compatD2:
   assumes "map2_val_compat f" and "oalist_inv_raw zs"
   shows "fst ` set (f zs) \<subseteq> fst ` set zs"
   using assms unfolding map2_val_compat_def by blast
 
 lemma map2_val_compat_Nil:
   assumes "map2_val_compat (f::('a \<times> 'b::zero) list \<Rightarrow> ('a \<times> 'c::zero) list)"
   shows "f [] = []"
 proof -
   from assms oalist_inv_raw_Nil have "fst ` set (f []) \<subseteq> fst ` set ([]::('a \<times> 'b) list)"
     by (rule map2_val_compatD2)
   thus ?thesis by simp
 qed
 
 lemma map2_val_compat_id: "map2_val_compat id"
   by (rule map2_val_compatI, auto)
 
 lemma map2_val_compat_map_val_pair: "map2_val_compat (map_val_pair f)"
 proof (rule map2_val_compatI, erule oalist_inv_raw_map_val_pair)
   fix zs
   from map_pair_subset image_iff show "fst ` set (map_val_pair f zs) \<subseteq> fst ` set zs" by fastforce
 qed
 
 lemma fst_map2_val_pair_subset:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
   assumes "map2_val_compat g" and "map2_val_compat h"
   shows "fst ` set (map2_val_pair f g h xs ys) \<subseteq> fst ` set xs \<union> fst ` set ys"
   using assms
 proof (induct f g h xs ys rule: map2_val_pair.induct)
   case (1 f g h xs)
   show ?case by (simp, rule map2_val_compatD2, fact+)
 next
   case (2 f g h v va)
   show ?case by (simp del: set_simps(2), rule map2_val_compatD2, fact+)
 next
   case (3 f g h kx vx xs ky vy ys)
   from 3(4) have "oalist_inv_raw xs" by (rule oalist_inv_raw_ConsD1)
   from 3(5) have "oalist_inv_raw ys" by (rule oalist_inv_raw_ConsD1)
   show ?case
   proof (simp split: order.split, intro conjI impI)
     assume "comp kx ky = Lt"
     hence "fst ` set (map2_val_pair f g h xs ((ky, vy) # ys)) \<subseteq> fst ` set xs \<union> fst ` set ((ky, vy) # ys)"
       using HOL.refl \<open>oalist_inv_raw xs\<close> 3(5, 6, 7) by (rule 3(2))
     thus "fst ` set (let v = f kx vx 0; aux = map2_val_pair f g h xs ((ky, vy) # ys)
                        in if v = 0 then aux else (kx, v) # aux)
           \<subseteq> insert ky (insert kx (fst ` set xs \<union> fst ` set ys))" by (auto simp: Let_def)
   next
     assume "comp kx ky = Eq"
     hence "fst ` set (map2_val_pair f g h xs ys) \<subseteq> fst ` set xs \<union> fst ` set ys"
       using HOL.refl \<open>oalist_inv_raw xs\<close> \<open>oalist_inv_raw ys\<close> 3(6, 7) by (rule 3(1))
     thus "fst ` set (let v = f kx vx vy; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (kx, v) # aux)
           \<subseteq> insert ky (insert kx (fst ` set xs \<union> fst ` set ys))" by (auto simp: Let_def)
   next
     assume "comp kx ky = Gt"
     hence "fst ` set (map2_val_pair f g h ((kx, vx) # xs) ys) \<subseteq> fst ` set ((kx, vx) # xs) \<union> fst ` set ys"
       using HOL.refl 3(4) \<open>oalist_inv_raw ys\<close> 3(6, 7) by (rule 3(3))
     thus "fst ` set (let v = f ky 0 vy; aux = map2_val_pair f g h ((kx, vx) # xs) ys
                         in if v = 0 then aux else (ky, v) # aux)
           \<subseteq> insert ky (insert kx (fst ` set xs \<union> fst ` set ys))" by (auto simp: Let_def)
   qed
 qed
 
 lemma oalist_inv_raw_map2_val_pair:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
   assumes "map2_val_compat g" and "map2_val_compat h"
   shows "oalist_inv_raw (map2_val_pair f g h xs ys)"
   using assms(1, 2)
 proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
   case Nil
   show ?case
   proof (cases ys)
     case Nil
     show ?thesis by (simp add: Nil, rule map2_val_compatD1, fact assms(3), fact oalist_inv_raw_Nil)
   next
     case (Cons y ys')
     show ?thesis by (simp add: Cons, rule map2_val_compatD1, fact assms(4), simp only: Cons[symmetric], fact Nil)
   qed
 next
   case *: (Cons k v xs)
   from *(6) show ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     show ?case by (simp, rule map2_val_compatD1, fact assms(3), fact *(1))
   next
     case (Cons k' v' ys)
     show ?case
     proof (simp split: order.split, intro conjI impI)
       assume "comp k k' = Lt"
       hence 0: "lt k k'" by (simp only: Lt_lt_conv)
       from Cons(1) have 1: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))" by (rule *(5))
       show "oalist_inv_raw (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
               in if v = 0 then aux else (k, v) # aux)"
       proof (simp add: Let_def, intro conjI impI)
         assume "f k v 0 \<noteq> 0"
         with 1 show "oalist_inv_raw ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys))"
         proof (rule oalist_inv_raw_ConsI)
           define k0 where "k0 = fst (hd (local.map2_val_pair f g h xs ((k', v') # ys)))"
           assume "map2_val_pair f g h xs ((k', v') # ys) \<noteq> []"
           hence "k0 \<in> fst ` set (map2_val_pair f g h xs ((k', v') # ys))" by (simp add: k0_def)
           also from *(2) Cons(1) assms(3, 4) have "... \<subseteq> fst ` set xs \<union> fst ` set ((k', v') # ys)"
             by (rule fst_map2_val_pair_subset)
           finally have "k0 \<in> fst ` set xs \<or> k0 = k' \<or> k0 \<in> fst ` set ys" by auto
           thus "lt k k0"
           proof (elim disjE)
             assume "k0 = k'"
             with 0 show ?thesis by simp
           next
             assume "k0 \<in> fst ` set ys"
             hence "lt k' k0" by (rule Cons(4))
             with 0 show ?thesis by (rule less_trans)
           qed (rule *(4))
         qed
       qed (rule 1)
     next
       assume "comp k k' = Eq"
       hence "k = k'" by (simp only: eq)
       from Cons(2) have 1: "oalist_inv_raw (map2_val_pair f g h xs ys)" by (rule *(5))
       show "oalist_inv_raw (let v = f k v v'; aux = map2_val_pair f g h xs ys in if v = 0 then aux else (k, v) # aux)"
       proof (simp add: Let_def, intro conjI impI)
         assume "f k v v' \<noteq> 0"
         with 1 show "oalist_inv_raw ((k, f k v v') # map2_val_pair f g h xs ys)"
         proof (rule oalist_inv_raw_ConsI)
           define k0 where "k0 = fst (hd (map2_val_pair f g h xs ys))"
           assume "map2_val_pair f g h xs ys \<noteq> []"
           hence "k0 \<in> fst ` set (map2_val_pair f g h xs ys)" by (simp add: k0_def)
           also from *(2) Cons(2) assms(3, 4) have "... \<subseteq> fst ` set xs \<union> fst ` set ys"
             by (rule fst_map2_val_pair_subset)
           finally show "lt k k0"
           proof
             assume "k0 \<in> fst ` set ys"
             hence "lt k' k0" by (rule Cons(4))
             thus ?thesis by (simp only: \<open>k = k'\<close>)
           qed (rule *(4))
         qed
       qed (rule 1)
     next
       assume "comp k k' = Gt"
       hence 0: "lt k' k" by (simp only: Gt_lt_conv)
       show "oalist_inv_raw (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
               in if va = 0 then aux else (k', va) # aux)"
       proof (simp add: Let_def, intro conjI impI)
         assume "f k' 0 v' \<noteq> 0"
         with Cons(5) show "oalist_inv_raw ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys)"
         proof (rule oalist_inv_raw_ConsI)
           define k0 where "k0 = fst (hd (map2_val_pair f g h ((k, v) # xs) ys))"
           assume "map2_val_pair f g h ((k, v) # xs) ys \<noteq> []"
           hence "k0 \<in> fst ` set (map2_val_pair f g h ((k, v) # xs) ys)" by (simp add: k0_def)
           also from *(1) Cons(2) assms(3, 4) have "... \<subseteq> fst ` set ((k, v) # xs) \<union> fst ` set ys"
             by (rule fst_map2_val_pair_subset)
           finally have "k0 = k \<or> k0 \<in> fst ` set xs \<or> k0 \<in> fst ` set ys" by auto
           thus "lt k' k0"
           proof (elim disjE)
             assume "k0 = k"
             with 0 show ?thesis by simp
           next
             assume "k0 \<in> fst ` set xs"
             hence "lt k k0" by (rule *(4))
             with 0 show ?thesis by (rule less_trans)
           qed (rule Cons(4))
         qed
       qed (rule Cons(5))
     qed
   qed
 qed
 
 lemma lookup_pair_map2_val_pair:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
   assumes "map2_val_compat g" and "map2_val_compat h"
   assumes "\<And>zs. oalist_inv_raw zs \<Longrightarrow> g zs = map_val_pair (\<lambda>k v. f k v 0) zs"
     and "\<And>zs. oalist_inv_raw zs \<Longrightarrow> h zs = map_val_pair (\<lambda>k. f k 0) zs"
     and "\<And>k. f k 0 0 = 0"
   shows "lookup_pair (map2_val_pair f g h xs ys) k0 = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
   using assms(1, 2)
 proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
   case Nil
   show ?case
   proof (cases ys)
     case Nil
     show ?thesis by (simp add: Nil map2_val_compat_Nil[OF assms(3)] assms(7))
   next
     case (Cons y ys')
     then obtain k v ys' where ys: "ys = (k, v) # ys'" by fastforce
     from Nil have "lookup_pair (h ys) k0 = lookup_pair (map_val_pair (\<lambda>k. f k 0) ys) k0"
       by (simp only: assms(6))
     also have "... = f k0 0 (lookup_pair ys k0)" by (rule lookup_pair_map_val_pair, fact Nil, fact assms(7))
     finally have "lookup_pair (h ((k, v) # ys')) k0 = f k0 0 (lookup_pair ((k, v) # ys') k0)"
       by (simp only: ys)
     thus ?thesis by (simp add: ys)
   qed
 next
   case *: (Cons k v xs)
   from *(6) show ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     from *(1) have "lookup_pair (g ((k, v) # xs)) k0 = lookup_pair (map_val_pair (\<lambda>k v. f k v 0) ((k, v) # xs)) k0"
       by (simp only: assms(5))
     also have "... = f k0 (lookup_pair ((k, v) # xs) k0) 0"
       by (rule lookup_pair_map_val_pair, fact *(1), fact assms(7))
     finally show ?case by simp
   next
     case (Cons k' v' ys)
     show ?case
     proof (cases "comp k0 k = Lt \<and> comp k0 k' = Lt")
       case True
       hence 1: "comp k0 k = Lt" and 2: "comp k0 k' = Lt" by simp_all
       hence eq: "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0) = 0"
         by (simp add: assms(7))
       from *(1) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
         by (rule oalist_inv_raw_map2_val_pair)
       show ?thesis
       proof (simp only: eq lookup_pair_eq_0[OF inv], rule)
         assume "k0 \<in> fst ` set (local.map2_val_pair f g h ((k, v) # xs) ((k', v') # ys))"
         also from *(1) Cons(1) assms(3, 4) have "... \<subseteq> fst ` set ((k, v) # xs) \<union> fst ` set ((k', v') # ys)"
           by (rule fst_map2_val_pair_subset)
         finally have "k0 \<in> fst ` set xs \<or> k0 \<in> fst ` set ys" using 1 2 by auto
         thus False
         proof
           assume "k0 \<in> fst ` set xs"
           hence "lt k k0" by (rule *(4))
           with 1 show ?thesis by (simp add: Lt_lt_conv)
         next
           assume "k0 \<in> fst ` set ys"
           hence "lt k' k0" by (rule Cons(4))
           with 2 show ?thesis by (simp add: Lt_lt_conv)
         qed
       qed
     next
       case False
       show ?thesis
       proof (simp split: order.split del: lookup_pair.simps, intro conjI impI)
         assume "comp k k' = Lt"
         with False have "comp k0 k \<noteq> Lt" by (auto simp: Lt_lt_conv)
         show "lookup_pair (let v = f k v 0; aux = map2_val_pair f g h xs ((k', v') # ys)
                             in if v = 0 then aux else (k, v) # aux) k0 =
               f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
         proof (cases "comp k0 k")
           case Lt
           with \<open>comp k0 k \<noteq> Lt\<close> show ?thesis ..
         next
           case Eq
           hence "k0 = k" by (simp only: eq)
           with \<open>comp k k' = Lt\<close> have "comp k0 k' = Lt" by simp
           hence eq1: "lookup_pair ((k', v') # ys) k = 0" by (simp add: \<open>k0 = k\<close>)
           have eq2: "lookup_pair ((k, v) # xs) k = v" by simp
           show ?thesis
           proof (simp add: Let_def eq1 eq2 \<open>k0 = k\<close> del: lookup_pair.simps, intro conjI impI)
             from *(2) Cons(1) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ((k', v') # ys))"
               by (rule oalist_inv_raw_map2_val_pair)
             show "lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k = 0"
             proof (simp only: lookup_pair_eq_0[OF inv], rule)
               assume "k \<in> fst ` set (local.map2_val_pair f g h xs ((k', v') # ys))"
               also from *(2) Cons(1) assms(3, 4) have "... \<subseteq> fst ` set xs \<union> fst ` set ((k', v') # ys)"
                 by (rule fst_map2_val_pair_subset)
               finally have "k \<in> fst ` set xs \<or> k \<in> fst ` set ys" using \<open>comp k k' = Lt\<close>
                 by auto
               thus False
               proof
                 assume "k \<in> fst ` set xs"
                 hence "lt k k" by (rule *(4))
                 thus ?thesis by simp
               next
                 assume "k \<in> fst ` set ys"
                 hence "lt k' k" by (rule Cons(4))
                 with \<open>comp k k' = Lt\<close> show ?thesis by (simp add: Lt_lt_conv)
               qed
             qed
           qed simp
         next
           case Gt
           hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
             and eq2: "lookup_pair ((k, f k v 0) # map2_val_pair f g h xs ((k', v') # ys)) k0 =
                   lookup_pair (map2_val_pair f g h xs ((k', v') # ys)) k0" by simp_all
           show ?thesis
             by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule *(5), fact Cons(1))
         qed
       next
         assume "comp k k' = Eq"
         hence "k = k'" by (simp only: eq)
         with False have "comp k0 k' \<noteq> Lt" by (auto simp: Lt_lt_conv)
         show "lookup_pair (let v = f k v v'; aux = map2_val_pair f g h xs ys in
                             if v = 0 then aux else (k, v) # aux) k0 =
               f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
         proof (cases "comp k0 k'")
           case Lt
           with \<open>comp k0 k' \<noteq> Lt\<close> show ?thesis ..
         next
           case Eq
           hence "k0 = k'" by (simp only: eq)
           show ?thesis
           proof (simp add: Let_def \<open>k = k'\<close> \<open>k0 = k'\<close>, intro impI)
             from *(2) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h xs ys)"
               by (rule oalist_inv_raw_map2_val_pair)
             show "lookup_pair (map2_val_pair f g h xs ys) k' = 0"
             proof (simp only: lookup_pair_eq_0[OF inv], rule)
               assume "k' \<in> fst ` set (map2_val_pair f g h xs ys)"
               also from *(2) Cons(2) assms(3, 4) have "... \<subseteq> fst ` set xs \<union> fst ` set ys"
                 by (rule fst_map2_val_pair_subset)
               finally show False
               proof
                 assume "k' \<in> fst ` set ys"
                 hence "lt k' k'" by (rule Cons(4))
                 thus ?thesis by simp
               next
                 assume "k' \<in> fst ` set xs"
                 hence "lt k k'" by (rule *(4))
                 thus ?thesis by (simp add: \<open>k = k'\<close>)
               qed
             qed
           qed
         next
           case Gt
           hence eq1: "lookup_pair ((k, v) # xs) k0 = lookup_pair xs k0"
             and eq2: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
             and eq3: "lookup_pair ((k, f k v v') # map2_val_pair f g h xs ys) k0 =
                   lookup_pair (map2_val_pair f g h xs ys) k0" by (simp_all add: \<open>k = k'\<close>)
           show ?thesis by (simp add: Let_def eq1 eq2 eq3 del: lookup_pair.simps, rule *(5), fact Cons(2))
         qed
       next
         assume "comp k k' = Gt"
         hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
         with False have "comp k0 k' \<noteq> Lt" by (auto simp: Lt_lt_conv)
         show "lookup_pair (let va = f k' 0 v'; aux = map2_val_pair f g h ((k, v) # xs) ys
                             in if va = 0 then aux else (k', va) # aux) k0 =
               f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
         proof (cases "comp k0 k'")
           case Lt
           with \<open>comp k0 k' \<noteq> Lt\<close> show ?thesis ..
         next
           case Eq
           hence "k0 = k'" by (simp only: eq)
           with \<open>comp k' k = Lt\<close> have "comp k0 k = Lt" by simp
           hence eq1: "lookup_pair ((k, v) # xs) k' = 0" by (simp add: \<open>k0 = k'\<close>)
           have eq2: "lookup_pair ((k', v') # ys) k' = v'" by simp
           show ?thesis
           proof (simp add: Let_def eq1 eq2 \<open>k0 = k'\<close> del: lookup_pair.simps, intro conjI impI)
             from *(1) Cons(2) assms(3, 4) have inv: "oalist_inv_raw (map2_val_pair f g h ((k, v) # xs) ys)"
               by (rule oalist_inv_raw_map2_val_pair)
             show "lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k' = 0"
             proof (simp only: lookup_pair_eq_0[OF inv], rule)
               assume "k' \<in> fst ` set (map2_val_pair f g h ((k, v) # xs) ys)"
               also from *(1) Cons(2) assms(3, 4) have "... \<subseteq> fst ` set ((k, v) # xs) \<union> fst ` set ys"
                 by (rule fst_map2_val_pair_subset)
               finally have "k' \<in> fst ` set xs \<or> k' \<in> fst ` set ys" using \<open>comp k' k = Lt\<close>
                 by auto
               thus False
               proof
                 assume "k' \<in> fst ` set ys"
                 hence "lt k' k'" by (rule Cons(4))
                 thus ?thesis by simp
               next
                 assume "k' \<in> fst ` set xs"
                 hence "lt k k'" by (rule *(4))
                 with \<open>comp k' k = Lt\<close> show ?thesis by (simp add: Lt_lt_conv)
               qed
             qed
           qed simp
         next
           case Gt
           hence eq1: "lookup_pair ((k', v') # ys) k0 = lookup_pair ys k0"
             and eq2: "lookup_pair ((k', f k' 0 v') # map2_val_pair f g h ((k, v) # xs) ys) k0 =
                   lookup_pair (map2_val_pair f g h ((k, v) # xs) ys) k0" by simp_all
           show ?thesis by (simp add: Let_def eq1 eq2 del: lookup_pair.simps, rule Cons(5))
         qed
       qed
     qed
   qed
 qed
 
 lemma map2_val_pair_singleton_eq_update_by_fun_pair:
   assumes "oalist_inv_raw xs"
   assumes "\<And>k x. f k x 0 = x" and "\<And>zs. oalist_inv_raw zs \<Longrightarrow> g zs = zs"
     and "h [(k, v)] = map_val_pair (\<lambda>k. f k 0) [(k, v)]"
   shows "map2_val_pair f g h xs [(k, v)] = update_by_fun_pair k (\<lambda>x. f k x v) xs"
   using assms(1)
 proof (induct xs rule: oalist_inv_raw_induct)
   case Nil
   show ?case by (simp add: Let_def assms(4))
 next
   case (Cons k' v' xs)
   show ?case
   proof (cases "comp k' k")
     case Lt
     hence gr: "comp k k' = Gt" by (simp only: Gt_lt_conv Lt_lt_conv)
     show ?thesis by (simp add: Lt gr Let_def assms(2) Cons(3, 5))
   next
     case Eq
     hence eq1: "comp k k' = Eq" and eq2: "k = k'" by (simp_all only: eq)
     show ?thesis by (simp add: Eq eq1 eq2 Let_def assms(3)[OF Cons(2)])
   next
     case Gt
     hence less: "comp k k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
     show ?thesis by (simp add: Gt less Let_def assms(3)[OF Cons(1)])
   qed
 qed
 
 subsubsection \<open>@{const lex_ord_pair}\<close>
 
 lemma lex_ord_pair_EqI:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
     and "\<And>k. k \<in> fst ` set xs \<union> fst ` set ys \<Longrightarrow> f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
   shows "lex_ord_pair f xs ys = Some Eq"
   using assms
 proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
   case Nil
   thus ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     show ?case by simp
   next
     case (Cons k v ys)
     show ?case
     proof (simp add: Let_def, intro conjI impI, rule Cons(5))
       fix k0
       assume "k0 \<in> fst ` set [] \<union> fst ` set ys"
       hence "k0 \<in> fst ` set ys" by simp
       hence "lt k k0" by (rule Cons(4))
       hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = f k0 (lookup_pair [] k0) (lookup_pair ((k, v) # ys) k0)"
         by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
       also have "... = Some Eq" by (rule Cons(6), simp add: \<open>k0 \<in> fst ` set ys\<close>)
       finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
     next
       have "f k 0 v = f k (lookup_pair [] k) (lookup_pair ((k, v) # ys) k)" by simp
       also have "... = Some Eq" by (rule Cons(6), simp)
       finally show "f k 0 v = Some Eq" .
     qed
   qed
 next
   case *: (Cons k v xs)
   from *(6, 7) show ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     show ?case
     proof (simp add: Let_def, intro conjI impI, rule *(5), rule oalist_inv_raw_Nil)
       fix k0
       assume "k0 \<in> fst ` set xs \<union> fst ` set []"
       hence "k0 \<in> fst ` set xs" by simp
       hence "lt k k0" by (rule *(4))
       hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair [] k0)"
         by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
       also have "... = Some Eq" by (rule Nil, simp add: \<open>k0 \<in> fst ` set xs\<close>)
       finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
     next
       have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair [] k)" by simp
       also have "... = Some Eq" by (rule Nil, simp)
       finally show "f k v 0 = Some Eq" .
     qed
   next
     case (Cons k' v' ys)
     show ?case
     proof (simp split: order.split, intro conjI impI)
       assume "comp k k' = Lt"
       show "(let aux = f k v 0 in if aux = Some Eq then lex_ord_pair f xs ((k', v') # ys) else aux) = Some Eq"
       proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(1))
         fix k0
         assume k0_in: "k0 \<in> fst ` set xs \<union> fst ` set ((k', v') # ys)"
         hence "k0 \<in> fst ` set xs \<or> k0 = k' \<or> k0 \<in> fst ` set ys" by auto
         hence "k0 \<noteq> k"
         proof (elim disjE)
           assume "k0 \<in> fst ` set xs"
           hence "lt k k0" by (rule *(4))
           thus ?thesis by simp
         next
           assume "k0 = k'"
           with \<open>comp k k' = Lt\<close> show ?thesis by auto
         next
           assume "k0 \<in> fst ` set ys"
           hence "lt k' k0" by (rule Cons(4))
           with \<open>comp k k' = Lt\<close> show ?thesis by (simp add: Lt_lt_conv)
         qed
         hence "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) =
                 f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
           by (auto simp add: lookup_pair_Cons[OF *(1)] simp del: lookup_pair.simps)
         also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
         finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k', v') # ys) k0) = Some Eq" .
       next
         have "f k v 0 = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
           by (simp add: \<open>comp k k' = Lt\<close>)
         also have "... = Some Eq" by (rule Cons(6), simp)
         finally show "f k v 0 = Some Eq" .
       qed
     next
       assume "comp k k' = Eq"
       hence "k = k'" by (simp only: eq)
       show "(let aux = f k v v' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = Some Eq"
       proof (simp add: Let_def, intro conjI impI, rule *(5), rule Cons(2))
         fix k0
         assume k0_in: "k0 \<in> fst ` set xs \<union> fst ` set ys"
         hence "k0 \<noteq> k'"
         proof
           assume "k0 \<in> fst ` set xs"
           hence "lt k k0" by (rule *(4))
           thus ?thesis by (simp add: \<open>k = k'\<close>)
         next
           assume "k0 \<in> fst ` set ys"
           hence "lt k' k0" by (rule Cons(4))
           thus ?thesis by simp
         qed
         hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
                 f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
           by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
               auto simp: \<open>k = k'\<close>)
         also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
         finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
       next
         have "f k v v' = f k (lookup_pair ((k, v) # xs) k) (lookup_pair ((k', v') # ys) k)"
           by (simp add: \<open>k = k'\<close>)
         also have "... = Some Eq" by (rule Cons(6), simp)
         finally show "f k v v' = Some Eq" .
       qed
     next
       assume "comp k k' = Gt"
       hence "comp k' k = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
       show "(let aux = f k' 0 v' in if aux = Some Eq then lex_ord_pair f ((k, v) # xs) ys else aux) = Some Eq"
       proof (simp add: Let_def, intro conjI impI, rule Cons(5))
         fix k0
         assume k0_in: "k0 \<in> fst ` set ((k, v) # xs) \<union> fst ` set ys"
         hence "k0 \<in> fst ` set xs \<or> k0 = k \<or> k0 \<in> fst ` set ys" by auto
         hence "k0 \<noteq> k'"
         proof (elim disjE)
           assume "k0 \<in> fst ` set xs"
           hence "lt k k0" by (rule *(4))
           with \<open>comp k' k = Lt\<close> show ?thesis by (simp add: Lt_lt_conv)
         next
           assume "k0 = k"
           with \<open>comp k' k = Lt\<close> show ?thesis by auto
         next
           assume "k0 \<in> fst ` set ys"
           hence "lt k' k0" by (rule Cons(4))
           thus ?thesis by simp
         qed
         hence "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) =
                 f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ((k', v') # ys) k0)"
           by (auto simp add: lookup_pair_Cons[OF Cons(1)] simp del: lookup_pair.simps)
         also have "... = Some Eq" by (rule Cons(6), rule rev_subsetD, fact k0_in, auto)
         finally show "f k0 (lookup_pair ((k, v) # xs) k0) (lookup_pair ys k0) = Some Eq" .
       next
         have "f k' 0 v' = f k' (lookup_pair ((k, v) # xs) k') (lookup_pair ((k', v') # ys) k')"
           by (simp add: \<open>comp k' k = Lt\<close>)
         also have "... = Some Eq" by (rule Cons(6), simp)
         finally show "f k' 0 v' = Some Eq" .
       qed
     qed
   qed
 qed
 
 lemma lex_ord_pair_valI:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "aux \<noteq> Some Eq"
   assumes "k \<in> fst ` set xs \<union> fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
     and "\<And>k'. k' \<in> fst ` set xs \<union> fst ` set ys \<Longrightarrow> lt k' k \<Longrightarrow>
               f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
   shows "lex_ord_pair f xs ys = aux"
   using assms(1, 2, 4, 5, 6)
 proof (induct xs arbitrary: ys rule: oalist_inv_raw_induct)
   case Nil
   thus ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     from Nil(1) show ?case by simp
   next
     case (Cons k' v' ys)
     from Cons(6) have "k = k' \<or> k \<in> fst ` set ys" by simp
     thus ?case
     proof
       assume "k = k'"
       with Cons(7) have "f k' 0 v' = aux" by simp
       thus ?thesis by (simp add: Let_def \<open>k = k'\<close> assms(3))
     next
       assume "k \<in> fst `set ys"
       hence "lt k' k" by (rule Cons(4))
       hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
       hence eq1: "lookup_pair ((k', v') # ys) k = lookup_pair ys k" by simp
       have "f k' (lookup_pair [] k') (lookup_pair ((k', v') # ys) k') = Some Eq"
         by (rule Cons(8), simp, fact)
       hence eq2: "f k' 0 v' = Some Eq" by simp
       show ?thesis
       proof (simp add: Let_def eq2, rule Cons(5))
         from \<open>k \<in> fst `set ys\<close> show "k \<in> fst ` set [] \<union> fst ` set ys" by simp
       next
         show "aux = f k (lookup_pair [] k) (lookup_pair ys k)" by (simp only: Cons(7) eq1)
       next
         fix k0
         assume "lt k0 k"
         assume "k0 \<in> fst ` set [] \<union> fst ` set ys"
         hence k0_in: "k0 \<in> fst ` set ys" by simp
         hence "lt k' k0" by (rule Cons(4))
         hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
         hence "f k0 (lookup_pair [] k0) (lookup_pair ys k0) =
                 f k0 (lookup_pair [] k0) (lookup_pair ((k', v') # ys) k0)" by simp
         also have "... = Some Eq" by (rule Cons(8), simp add: k0_in, fact)
         finally show "f k0 (lookup_pair [] k0) (lookup_pair ys k0) = Some Eq" .
       qed
     qed
   qed
 next
   case *: (Cons k' v' xs)
   from *(6, 7, 8, 9) show ?case
   proof (induct ys rule: oalist_inv_raw_induct)
     case Nil
     from Nil(1) have "k = k' \<or> k \<in> fst ` set xs" by simp
     thus ?case
     proof
       assume "k = k'"
       with Nil(2) have "f k' v' 0 = aux" by simp
       thus ?thesis by (simp add: Let_def \<open>k = k'\<close> assms(3))
     next
       assume "k \<in> fst ` set xs"
       hence "lt k' k" by (rule *(4))
       hence "comp k k' = Gt" by (simp add: Gt_lt_conv)
       hence eq1: "lookup_pair ((k', v') # xs) k = lookup_pair xs k" by simp
       have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair [] k') = Some Eq"
         by (rule Nil(3), simp, fact)
       hence eq2: "f k' v' 0 = Some Eq" by simp
       show ?thesis
       proof (simp add: Let_def eq2, rule *(5), fact oalist_inv_raw_Nil)
         from \<open>k \<in> fst `set xs\<close> show "k \<in> fst ` set xs \<union> fst ` set []" by simp
       next
         show "aux = f k (lookup_pair xs k) (lookup_pair [] k)" by (simp only: Nil(2) eq1)
       next
         fix k0
         assume "lt k0 k"
         assume "k0 \<in> fst ` set xs \<union> fst ` set []"
         hence k0_in: "k0 \<in> fst ` set xs" by simp
         hence "lt k' k0" by (rule *(4))
         hence "comp k0 k' = Gt" by (simp add: Gt_lt_conv)
         hence "f k0 (lookup_pair xs k0) (lookup_pair [] k0) =
                 f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair [] k0)" by simp
         also have "... = Some Eq" by (rule Nil(3), simp add: k0_in, fact)
         finally show "f k0 (lookup_pair xs k0) (lookup_pair [] k0) = Some Eq" .
       qed
     qed
   next
     case (Cons k'' v'' ys)
 
     have 0: thesis if 1: "lt k k'" and 2: "lt k k''" for thesis
     proof -
       from 1 have "k \<noteq> k'" by simp
       moreover from 2 have "k \<noteq> k''" by simp
       ultimately have "k \<in> fst ` set xs \<or> k \<in> fst ` set ys" using Cons(6) by simp
       thus ?thesis
       proof
         assume "k \<in> fst ` set xs"
         hence "lt k' k" by (rule *(4))
         with 1 show ?thesis by simp
       next
         assume "k \<in> fst ` set ys"
         hence "lt k'' k" by (rule Cons(4))
         with 2 show ?thesis by simp
       qed
     qed
 
     show ?case
     proof (simp split: order.split, intro conjI impI)
       assume Lt: "comp k' k'' = Lt"
       show "(let aux = f k' v' 0 in if aux = Some Eq then lex_ord_pair f xs ((k'', v'') # ys) else aux) = aux"
       proof (simp add: Let_def split: order.split, intro conjI impI)
         assume "f k' v' 0 = Some Eq"
         have "k \<noteq> k'"
         proof
           assume "k = k'"
           have "aux = f k v' 0" by (simp add: Cons(7) \<open>k = k'\<close> Lt)
           with \<open>f k' v' 0 = Some Eq\<close> assms(3) show False by (simp add: \<open>k = k'\<close>)
         qed
         from Cons(1) show "lex_ord_pair f xs ((k'', v'') # ys) = aux"
         proof (rule *(5))
           from Cons(6) \<open>k \<noteq> k'\<close> show "k \<in> fst ` set xs \<union> fst ` set ((k'', v'') # ys)" by simp
         next
           show "aux = f k (lookup_pair xs k) (lookup_pair ((k'', v'') # ys) k)"
             by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] \<open>k \<noteq> k'\<close>[symmetric] del: lookup_pair.simps)
         next
           fix k0
           assume "lt k0 k"
           assume k0_in: "k0 \<in> fst ` set xs \<union> fst ` set ((k'', v'') # ys)"
           also have "... \<subseteq> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by fastforce
           finally have k0_in': "k0 \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" .
           have "k' \<noteq> k0"
           proof
             assume "k' = k0"
             with k0_in have "k' \<in> fst ` set xs \<union> fst ` set ((k'', v'') # ys)" by simp
             with Lt have "k' \<in> fst ` set xs \<or> k' \<in> fst ` set ys" by auto
             thus False
             proof
               assume "k' \<in> fst ` set xs"
               hence "lt k' k'" by (rule *(4))
               thus ?thesis by simp
             next
               assume "k' \<in> fst ` set ys"
               hence "lt k'' k'" by (rule Cons(4))
               with Lt show ?thesis by (simp add: Lt_lt_conv)
             qed
           qed
           hence "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) =
                   f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
             by (simp add: lookup_pair_Cons[OF *(1)] del: lookup_pair.simps)
           also from k0_in' \<open>lt k0 k\<close> have "... = Some Eq" by (rule Cons(8))
           finally show "f k0 (lookup_pair xs k0) (lookup_pair ((k'', v'') # ys) k0) = Some Eq" .
         qed
       next
         assume "f k' v' 0 \<noteq> Some Eq"
         have "\<not> lt k' k"
         proof
           have "k' \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by simp
           moreover assume "lt k' k"
           ultimately have "f k' (lookup_pair ((k', v') # xs) k') (lookup_pair ((k'', v'') # ys) k') = Some Eq"
             by (rule Cons(8))
           hence "f k' v' 0 = Some Eq" by (simp add: Lt)
           with \<open>f k' v' 0 \<noteq> Some Eq\<close> show False ..
         qed
         moreover have "\<not> lt k k'"
         proof
           assume "lt k k'"
           moreover from this Lt have "lt k k''" by (simp add: Lt_lt_conv)
           ultimately show False by (rule 0)
         qed
         ultimately have "k = k'" by simp
         show "f k' v' 0 = aux" by (simp add: Cons(7) \<open>k = k'\<close> Lt)
       qed
     next
       assume "comp k' k'' = Eq"
       hence "k' = k''" by (simp only: eq)
       show "(let aux = f k' v' v'' in if aux = Some Eq then lex_ord_pair f xs ys else aux) = aux"
       proof (simp add: Let_def \<open>k' = k''\<close> split: order.split, intro conjI impI)
         assume "f k'' v' v'' = Some Eq"
         have "k \<noteq> k''"
         proof
           assume "k = k''"
           have "aux = f k v' v''" by (simp add: Cons(7) \<open>k = k''\<close> \<open>k' = k''\<close>)
           with \<open>f k'' v' v'' = Some Eq\<close> assms(3) show False by (simp add: \<open>k = k''\<close>)
         qed
         from Cons(2) show "lex_ord_pair f xs ys = aux"
         proof (rule *(5))
           from Cons(6) \<open>k \<noteq> k''\<close> show "k \<in> fst ` set xs \<union> fst ` set ys" by (simp add: \<open>k' = k''\<close>)
         next
           show "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
             by (simp add: Cons(7) lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
                 simp add: \<open>k' = k''\<close> \<open>k \<noteq> k''\<close>[symmetric])
         next
           fix k0
           assume "lt k0 k"
           assume k0_in: "k0 \<in> fst ` set xs \<union> fst ` set ys"
           also have "... \<subseteq> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by fastforce
           finally have k0_in': "k0 \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" .
           have "k'' \<noteq> k0"
           proof
             assume "k'' = k0"
             with k0_in have "k'' \<in> fst ` set xs \<union> fst ` set ys" by simp
             thus False
             proof
               assume "k'' \<in> fst ` set xs"
               hence "lt k' k''" by (rule *(4))
               thus ?thesis by (simp add: \<open>k' = k''\<close>)
             next
               assume "k'' \<in> fst ` set ys"
               hence "lt k'' k''" by (rule Cons(4))
               thus ?thesis by simp
             qed
           qed
           hence "f k0 (lookup_pair xs k0) (lookup_pair ys k0) =
                   f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
             by (simp add: lookup_pair_Cons[OF *(1)] lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps,
                 simp add: \<open>k' = k''\<close>)
           also from k0_in' \<open>lt k0 k\<close> have "... = Some Eq" by (rule Cons(8))
           finally show "f k0 (lookup_pair xs k0) (lookup_pair ys k0) = Some Eq" .
         qed
       next
         assume "f k'' v' v'' \<noteq> Some Eq"
         have "\<not> lt k'' k"
         proof
           have "k'' \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by simp
           moreover assume "lt k'' k"
           ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
             by (rule Cons(8))
           hence "f k'' v' v'' = Some Eq" by (simp add: \<open>k' = k''\<close>)
           with \<open>f k'' v' v'' \<noteq> Some Eq\<close> show False ..
         qed
         moreover have "\<not> lt k k''"
         proof
           assume "lt k k''"
           hence "lt k k'" by (simp only: \<open>k' = k''\<close>)
           thus False using \<open>lt k k''\<close> by (rule 0)
         qed
         ultimately have "k = k''" by simp
         show "f k'' v' v'' = aux" by (simp add: Cons(7) \<open>k = k''\<close> \<open>k' = k''\<close>)
       qed
     next
       assume Gt: "comp k' k'' = Gt"
       hence Lt: "comp k'' k' = Lt" by (simp only: Gt_lt_conv Lt_lt_conv)
       show "(let aux = f k'' 0 v'' in if aux = Some Eq then lex_ord_pair f ((k', v') # xs) ys else aux) = aux"
       proof (simp add: Let_def split: order.split, intro conjI impI)
         assume "f k'' 0 v'' = Some Eq"
         have "k \<noteq> k''"
         proof
           assume "k = k''"
           have "aux = f k 0 v''" by (simp add: Cons(7) \<open>k = k''\<close> Lt)
           with \<open>f k'' 0 v'' = Some Eq\<close> assms(3) show False by (simp add: \<open>k = k''\<close>)
         qed
         show "lex_ord_pair f ((k', v') # xs) ys = aux"
         proof (rule Cons(5))
           from Cons(6) \<open>k \<noteq> k''\<close> show "k \<in> fst ` set ((k', v') # xs) \<union> fst ` set ys" by simp
         next
           show "aux = f k (lookup_pair ((k', v') # xs) k) (lookup_pair ys k)"
             by (simp add: Cons(7) lookup_pair_Cons[OF Cons(1)] \<open>k \<noteq> k''\<close>[symmetric] del: lookup_pair.simps)
         next
           fix k0
           assume "lt k0 k"
           assume k0_in: "k0 \<in> fst ` set ((k', v') # xs) \<union> fst ` set ys"
           also have "... \<subseteq> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by fastforce
           finally have k0_in': "k0 \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" .
           have "k'' \<noteq> k0"
           proof
             assume "k'' = k0"
             with k0_in have "k'' \<in> fst ` set ((k', v') # xs) \<union> fst ` set ys" by simp
             with Lt have "k'' \<in> fst ` set xs \<or> k'' \<in> fst ` set ys" by auto
             thus False
             proof
               assume "k'' \<in> fst ` set xs"
               hence "lt k' k''" by (rule *(4))
               with Lt show ?thesis by (simp add: Lt_lt_conv)
             next
               assume "k'' \<in> fst ` set ys"
               hence "lt k'' k''" by (rule Cons(4))
               thus ?thesis by simp
             qed
           qed
           hence "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) =
                   f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ((k'', v'') # ys) k0)"
             by (simp add: lookup_pair_Cons[OF Cons(1)] del: lookup_pair.simps)
           also from k0_in' \<open>lt k0 k\<close> have "... = Some Eq" by (rule Cons(8))
           finally show "f k0 (lookup_pair ((k', v') # xs) k0) (lookup_pair ys k0) = Some Eq" .
         qed
       next
         assume "f k'' 0 v'' \<noteq> Some Eq"
         have "\<not> lt k'' k"
         proof
           have "k'' \<in> fst ` set ((k', v') # xs) \<union> fst ` set ((k'', v'') # ys)" by simp
           moreover assume "lt k'' k"
           ultimately have "f k'' (lookup_pair ((k', v') # xs) k'') (lookup_pair ((k'', v'') # ys) k'') = Some Eq"
             by (rule Cons(8))
           hence "f k'' 0 v'' = Some Eq" by (simp add: Lt)
           with \<open>f k'' 0 v'' \<noteq> Some Eq\<close> show False ..
         qed
         moreover have "\<not> lt k k''"
         proof
           assume "lt k k''"
           with Lt have "lt k k'" by (simp add: Lt_lt_conv)
           thus False using \<open>lt k k''\<close> by (rule 0)
         qed
         ultimately have "k = k''" by simp
         show "f k'' 0 v'' = aux" by (simp add: Cons(7) \<open>k = k''\<close> Lt)
       qed
     qed
   qed
 qed
 
 lemma lex_ord_pair_EqD:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = Some Eq"
     and "k \<in> fst ` set xs \<union> fst ` set ys"
   shows "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
 proof (rule ccontr)
   let ?A = "(fst ` set xs \<union> fst ` set ys) \<inter> {k. f k (lookup_pair xs k) (lookup_pair ys k) \<noteq> Some Eq}"
   define k0 where "k0 = Min ?A"
   have "finite ?A" by auto
   assume "f k (lookup_pair xs k) (lookup_pair ys k) \<noteq> Some Eq"
   with assms(4) have "k \<in> ?A" by simp
   hence "?A \<noteq> {}" by blast
   with \<open>finite ?A\<close> have "k0 \<in> ?A" unfolding k0_def by (rule Min_in)
   hence k0_in: "k0 \<in> fst ` set xs \<union> fst ` set ys"
     and neq: "f k0 (lookup_pair xs k0) (lookup_pair ys k0) \<noteq> Some Eq" by simp_all
   have "le k0 k'" if "k' \<in> ?A" for k' unfolding k0_def using \<open>finite ?A\<close> that
     by (rule Min_le)
   hence "f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
     if "k' \<in> fst ` set xs \<union> fst ` set ys" and "lt k' k0" for k' using that by fastforce
   with assms(1, 2) neq k0_in HOL.refl have "lex_ord_pair f xs ys = f k0 (lookup_pair xs k0) (lookup_pair ys k0)"
     by (rule lex_ord_pair_valI)
   with assms(3) neq show False by simp
 qed
 
 lemma lex_ord_pair_valE:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "lex_ord_pair f xs ys = aux"
     and "aux \<noteq> Some Eq"
   obtains k where "k \<in> fst ` set xs \<union> fst ` set ys" and "aux = f k (lookup_pair xs k) (lookup_pair ys k)"
     and "\<And>k'. k' \<in> fst ` set xs \<union> fst ` set ys \<Longrightarrow> lt k' k \<Longrightarrow>
             f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq"
 proof -
   let ?A = "(fst ` set xs \<union> fst ` set ys) \<inter> {k. f k (lookup_pair xs k) (lookup_pair ys k) \<noteq> Some Eq}"
   define k where "k = Min ?A"
   have "finite ?A" by auto
   have "\<exists>k \<in> fst ` set xs \<union> fst ` set ys. f k (lookup_pair xs k) (lookup_pair ys k) \<noteq> Some Eq" (is ?prop)
   proof (rule ccontr)
     assume "\<not> ?prop"
     hence "f k (lookup_pair xs k) (lookup_pair ys k) = Some Eq"
       if "k \<in> fst ` set xs \<union> fst ` set ys" for k using that by auto
     with assms(1, 2) have "lex_ord_pair f xs ys = Some Eq" by (rule lex_ord_pair_EqI)
     with assms(3, 4) show False by simp
   qed
   then obtain k0 where "k0 \<in> fst ` set xs \<union> fst ` set ys"
     and "f k0 (lookup_pair xs k0) (lookup_pair ys k0) \<noteq> Some Eq" ..
   hence "k0 \<in> ?A" by simp
   hence "?A \<noteq> {}" by blast
   with \<open>finite ?A\<close> have "k \<in> ?A" unfolding k_def by (rule Min_in)
   hence k_in: "k \<in> fst ` set xs \<union> fst ` set ys"
     and neq: "f k (lookup_pair xs k) (lookup_pair ys k) \<noteq> Some Eq" by simp_all
   have "le k k'" if "k' \<in> ?A" for k' unfolding k_def using \<open>finite ?A\<close> that
     by (rule Min_le)
   hence *: "\<And>k'. k' \<in> fst ` set xs \<union> fst ` set ys \<Longrightarrow> lt k' k \<Longrightarrow>
             f k' (lookup_pair xs k') (lookup_pair ys k') = Some Eq" by fastforce
   with assms(1, 2) neq k_in HOL.refl have "lex_ord_pair f xs ys = f k (lookup_pair xs k) (lookup_pair ys k)"
     by (rule lex_ord_pair_valI)
   hence "aux = f k (lookup_pair xs k) (lookup_pair ys k)" by (simp only: assms(3))
   with k_in show ?thesis using * ..
 qed
 
 subsubsection \<open>@{const prod_ord_pair}\<close>
 
 lemma prod_ord_pair_eq_lex_ord_pair:
   "prod_ord_pair P xs ys = (lex_ord_pair (\<lambda>k x y. if P k x y then Some Eq else None) xs ys = Some Eq)"
 proof (induct P xs ys rule: prod_ord_pair.induct)
   case (1 P)
   show ?case by simp
 next
   case (2 P ky vy ys)
   thus ?case by simp
 next
   case (3 P kx vx xs)
   thus ?case by simp
 next
   case (4 P kx vx xs ky vy ys)
   show ?case
   proof (cases "comp kx ky")
     case Lt
     thus ?thesis by (simp add: 4(2)[OF Lt])
   next
     case Eq
     thus ?thesis by (simp add: 4(1)[OF Eq])
   next
     case Gt
     thus ?thesis by (simp add: 4(3)[OF Gt])
   qed
 qed
 
 lemma prod_ord_pairI:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
     and "\<And>k. k \<in> fst ` set xs \<union> fst ` set ys \<Longrightarrow> P k (lookup_pair xs k) (lookup_pair ys k)"
   shows "prod_ord_pair P xs ys"
   unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqI, fact, fact, simp add: assms(3))
 
 lemma prod_ord_pairD:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys" and "prod_ord_pair P xs ys"
     and "k \<in> fst ` set xs \<union> fst ` set ys"
   shows "P k (lookup_pair xs k) (lookup_pair ys k)"
 proof -
   from assms have "(if P k (lookup_pair xs k) (lookup_pair ys k) then Some Eq else None) = Some Eq"
     unfolding prod_ord_pair_eq_lex_ord_pair by (rule lex_ord_pair_EqD)
   thus ?thesis by (simp split: if_splits)
 qed
 
 corollary prod_ord_pair_alt:
   assumes "oalist_inv_raw xs" and "oalist_inv_raw ys"
   shows "(prod_ord_pair P xs ys) \<longleftrightarrow> (\<forall>k\<in>fst ` set xs \<union> fst ` set ys. P k (lookup_pair xs k) (lookup_pair ys k))"
   using prod_ord_pairI[OF assms] prod_ord_pairD[OF assms] by meson
 
 subsubsection \<open>@{const sort_oalist}\<close>
 
 lemma oalist_inv_raw_foldr_update_by_pair:
   assumes "oalist_inv_raw ys"
   shows "oalist_inv_raw (foldr update_by_pair xs ys)"
 proof (induct xs)
   case Nil
   from assms show ?case by simp
 next
   case (Cons x xs)
   hence "oalist_inv_raw (update_by_pair x (foldr update_by_pair xs ys))"
     by (rule oalist_inv_raw_update_by_pair)
   thus ?case by simp
 qed
 
 corollary oalist_inv_raw_sort_oalist: "oalist_inv_raw (sort_oalist xs)"
 proof -
   from oalist_inv_raw_Nil have "oalist_inv_raw (foldr local.update_by_pair xs [])"
     by (rule oalist_inv_raw_foldr_update_by_pair)
   thus "oalist_inv_raw (sort_oalist xs)" by (simp only: sort_oalist_def)
 qed
 
 lemma sort_oalist_id:
   assumes "oalist_inv_raw xs"
   shows "sort_oalist xs = xs"
 proof -
   have "foldr update_by_pair xs ys = xs @ ys" if "oalist_inv_raw (xs @ ys)" for ys using assms that
   proof (induct xs rule: oalist_inv_raw_induct)
     case Nil
     show ?case by simp
   next
     case (Cons k v xs)
     from Cons(6) have *: "oalist_inv_raw ((k, v) # (xs @ ys))" by simp
     hence 1: "oalist_inv_raw (xs @ ys)" by (rule oalist_inv_raw_ConsD1)
     hence 2: "foldr update_by_pair xs ys = xs @ ys" by (rule Cons(5))
     show ?case
     proof (simp add: 2, rule update_by_pair_less)
       from * show "v \<noteq> 0" by (auto simp: oalist_inv_raw_def)
     next
       have "comp k (fst (hd (xs @ ys))) = Lt \<or> xs @ ys = []"
       proof (rule disjCI)
         assume "xs @ ys \<noteq> []"
         then obtain k'' v'' zs where eq0: "xs @ ys = (k'', v'') # zs"
           using list.exhaust prod.exhaust by metis
         from * have "lt k k''" by (simp add: eq0 oalist_inv_raw_def)
         thus "comp k (fst (hd (xs @ ys))) = Lt" by (simp add: eq0 Lt_lt_conv)
       qed
       thus "xs @ ys = [] \<or> comp k (fst (hd (xs @ ys))) = Lt" by auto
     qed
   qed
   with assms show ?thesis by (simp add: sort_oalist_def)
 qed
 
 lemma set_sort_oalist:
   assumes "distinct (map fst xs)"
   shows "set (sort_oalist xs) = {kv. kv \<in> set xs \<and> snd kv \<noteq> 0}"
   using assms
 proof (induct xs)
   case Nil
   show ?case by (simp add: sort_oalist_def)
 next
   case (Cons x xs)
   obtain k v where x: "x = (k, v)" by fastforce
   from Cons(2) have "distinct (map fst xs)" and "k \<notin> fst ` set xs" by (simp_all add: x)
   from this(1) have "set (sort_oalist xs) = {kv \<in> set xs. snd kv \<noteq> 0}" by (rule Cons(1))
   with \<open>k \<notin> fst ` set xs\<close> have eq: "set (sort_oalist xs) - range (Pair k) = {kv \<in> set xs. snd kv \<noteq> 0}"
     by (auto simp: image_iff)
   have "set (sort_oalist (x # xs)) = set (update_by_pair (k, v) (sort_oalist xs))"
     by (simp add: sort_oalist_def x)
   also have "... = {kv \<in> set (x # xs). snd kv \<noteq> 0}"
   proof (cases "v = 0")
     case True
     have "set (update_by_pair (k, v) (sort_oalist xs)) = set (sort_oalist xs) - range (Pair k)"
       unfolding True using oalist_inv_raw_sort_oalist by (rule set_update_by_pair_zero)
     also have "... = {kv \<in> set (x # xs). snd kv \<noteq> 0}" by (auto simp: eq x True)
     finally show ?thesis .
   next
     case False
     with oalist_inv_raw_sort_oalist
     have "set (update_by_pair (k, v) (sort_oalist xs)) = insert (k, v) (set (sort_oalist xs) - range (Pair k))"
       by (rule set_update_by_pair)
     also have "... = {kv \<in> set (x # xs). snd kv \<noteq> 0}" by (auto simp: eq x False)
     finally show ?thesis .
   qed
   finally show ?case .
 qed
 
 lemma lookup_pair_sort_oalist':
   assumes "distinct (map fst xs)"
   shows "lookup_pair (sort_oalist xs) = lookup_dflt xs"
   using assms
 proof (induct xs)
   case Nil
   show ?case by (simp add: sort_oalist_def lookup_dflt_def)
 next
   case (Cons x xs)
   obtain k v where x: "x = (k, v)" by fastforce
   from Cons(2) have "distinct (map fst xs)" and "k \<notin> fst ` set xs" by (simp_all add: x)
   from this(1) have eq1: "lookup_pair (sort_oalist xs) = lookup_dflt xs" by (rule Cons(1))
   have eq2: "sort_oalist (x # xs) = update_by_pair (k, v) (sort_oalist xs)" by (simp add: x sort_oalist_def)
   show ?case
   proof
     fix k'
     have "lookup_pair (sort_oalist (x # xs)) k' = (if k = k' then v else lookup_dflt xs k')"
       by (simp add: eq1 eq2 lookup_pair_update_by_pair[OF oalist_inv_raw_sort_oalist])
     also have "... = lookup_dflt (x # xs) k'" by (simp add: x lookup_dflt_def)
     finally show "lookup_pair (sort_oalist (x # xs)) k' = lookup_dflt (x # xs) k'" .
   qed
 qed
 
 end
 
 locale comparator2 = comparator comp1 + cmp2: comparator comp2 for comp1 comp2 :: "'a comparator"
 begin
 
 lemma set_sort_oalist:
   assumes "cmp2.oalist_inv_raw xs"
   shows "set (sort_oalist xs) = set xs"
 proof -
   have rl: "set (foldr update_by_pair xs ys) = set xs \<union> set ys"
     if "oalist_inv_raw ys" and "fst ` set xs \<inter> fst ` set ys = {}" for ys
     using assms that(2)
   proof (induct xs rule: cmp2.oalist_inv_raw_induct)
     case Nil
     show ?case by simp
   next
     case (Cons k v xs)
     from Cons(6) have "k \<notin> fst ` set ys" and "fst ` set xs \<inter> fst ` set ys = {}" by simp_all
     from this(2) have eq1: "set (foldr update_by_pair xs ys) = set xs \<union> set ys" by (rule Cons(5))
     have "\<not> cmp2.lt k k" by auto
     with Cons(4) have "k \<notin> fst ` set xs" by blast
     with \<open>k \<notin> fst ` set ys\<close> have "k \<notin> fst ` (set xs \<union> set ys)" by (simp add: image_Un)
     hence "(set xs \<union> set ys) \<inter> range (Pair k) = {}" by (smt Int_emptyI fstI image_iff)
     hence eq2: "(set xs \<union> set ys) - range (Pair k) = set xs \<union> set ys" by (rule Diff_triv)
     from \<open>oalist_inv_raw ys\<close> have "oalist_inv_raw (foldr update_by_pair xs ys)"
       by (rule oalist_inv_raw_foldr_update_by_pair)
     hence "set (update_by_pair (k, v) (foldr update_by_pair xs ys)) =
             insert (k, v) (set (foldr update_by_pair xs ys) - range (Pair k))"
       using Cons(3) by (rule set_update_by_pair)
     also have "... = insert (k, v) (set xs \<union> set ys)" by (simp only: eq1 eq2)
     finally show ?case by simp
   qed
   have "set (foldr update_by_pair xs []) = set xs \<union> set []"
     by (rule rl, fact oalist_inv_raw_Nil, simp)
   thus ?thesis by (simp add: sort_oalist_def)
 qed
 
 lemma lookup_pair_eqI:
   assumes "oalist_inv_raw xs" and "cmp2.oalist_inv_raw ys" and "set xs = set ys"
   shows "lookup_pair xs = cmp2.lookup_pair ys"
 proof
   fix k
   show "lookup_pair xs k = cmp2.lookup_pair ys k"
   proof (cases "cmp2.lookup_pair ys k = 0")
     case True
     with assms(2) have "k \<notin> fst ` set ys" by (simp add: cmp2.lookup_pair_eq_0)
     with assms(1) show ?thesis by (simp add: True assms(3)[symmetric] lookup_pair_eq_0)
   next
     case False
     define v where "v = cmp2.lookup_pair ys k"
     from False have "v \<noteq> 0" by (simp add: v_def)
     with assms(2) v_def[symmetric] have "(k, v) \<in> set ys" by (simp add: cmp2.lookup_pair_eq_value)
     with assms(1) \<open>v \<noteq> 0\<close> have "lookup_pair xs k = v"
       by (simp add: assms(3)[symmetric] lookup_pair_eq_value)
     thus ?thesis by (simp only: v_def)
   qed
 qed
 
 corollary lookup_pair_sort_oalist:
   assumes "cmp2.oalist_inv_raw xs"
   shows "lookup_pair (sort_oalist xs) = cmp2.lookup_pair xs"
   by (rule lookup_pair_eqI, rule oalist_inv_raw_sort_oalist, fact, rule set_sort_oalist, fact)
 
 end (* comparator2 *)
 
 subsection \<open>Invariant on Pairs\<close>
 
 type_synonym ('a, 'b, 'c) oalist_raw = "('a \<times> 'b) list \<times> 'c"
 
 locale oalist_raw = fixes rep_key_order::"'o \<Rightarrow> 'a key_order"
 begin
 
 sublocale comparator "key_compare (rep_key_order x)"
   by (fact comparator_key_compare)
 
 definition oalist_inv :: "('a, 'b::zero, 'o) oalist_raw \<Rightarrow> bool"
   where "oalist_inv xs \<longleftrightarrow> oalist_inv_raw (snd xs) (fst xs)"
 
 lemma oalist_inv_alt: "oalist_inv (xs, ko) \<longleftrightarrow> oalist_inv_raw ko xs"
   by (simp add: oalist_inv_def)
 
 subsection \<open>Operations on Raw Ordered Associative Lists\<close>
 
 fun sort_oalist_aux :: "'o \<Rightarrow> ('a, 'b, 'o) oalist_raw \<Rightarrow> ('a \<times> 'b::zero) list"
   where "sort_oalist_aux ko (xs, ox) = (if ko = ox then xs else sort_oalist ko xs)"
 
 fun lookup_raw :: "('a, 'b, 'o) oalist_raw \<Rightarrow> 'a \<Rightarrow> 'b::zero"
   where "lookup_raw (xs, ko) = lookup_pair ko xs"
 
 definition sorted_domain_raw :: "'o \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw \<Rightarrow> 'a list"
   where "sorted_domain_raw ko xs = map fst (sort_oalist_aux ko xs)"
 
 fun tl_raw :: "('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   where "tl_raw (xs, ko) = (List.tl xs, ko)"
 
 fun min_key_val_raw :: "'o \<Rightarrow> ('a, 'b, 'o) oalist_raw \<Rightarrow> ('a \<times> 'b::zero)"
   where "min_key_val_raw ko (xs, ox) =
       (if ko = ox then List.hd else min_list_param (\<lambda>x y. le ko (fst x) (fst y))) xs"
 
 fun update_by_raw :: "('a \<times> 'b) \<Rightarrow> ('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   where "update_by_raw kv (xs, ko) = (update_by_pair ko kv xs, ko)"
 
 fun update_by_fun_raw :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   where "update_by_fun_raw k f (xs, ko) = (update_by_fun_pair ko k f xs, ko)"
 
 fun update_by_fun_gr_raw :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   where "update_by_fun_gr_raw k f (xs, ko) = (update_by_fun_gr_pair ko k f xs, ko)"
 
 fun (in -) filter_raw :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'b) \<Rightarrow> ('a list \<times> 'b)"
   where "filter_raw P (xs, ko) = (filter P xs, ko)"
 
 fun (in -) map_raw :: "(('a \<times> 'b) \<Rightarrow> ('a \<times> 'c)) \<Rightarrow> (('a \<times> 'b::zero) list \<times> 'd) \<Rightarrow> ('a \<times> 'c::zero) list \<times> 'd"
   where "map_raw f (xs, ko) = (map_pair f xs, ko)"
 
 abbreviation (in -) "map_val_raw f \<equiv> map_raw (\<lambda>(k, v). (k, f k v))"
 
 fun map2_val_raw :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> (('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'd, 'o) oalist_raw) \<Rightarrow>
                       (('a, 'c, 'o) oalist_raw \<Rightarrow> ('a, 'd, 'o) oalist_raw) \<Rightarrow>
                       ('a, 'b::zero, 'o) oalist_raw \<Rightarrow> ('a, 'c::zero, 'o) oalist_raw \<Rightarrow>
                       ('a, 'd::zero, 'o) oalist_raw"
   where "map2_val_raw f g h (xs, ox) ys =
             (map2_val_pair ox f (\<lambda>zs. fst (g (zs, ox))) (\<lambda>zs. fst (h (zs, ox)))
                     xs (sort_oalist_aux ox ys), ox)"
 
 definition lex_ord_raw :: "'o \<Rightarrow> ('a \<Rightarrow> (('b, 'c) comp_opt)) \<Rightarrow>
                       (('a, 'b::zero, 'o) oalist_raw, ('a, 'c::zero, 'o) oalist_raw) comp_opt"
   where "lex_ord_raw ko f xs ys = lex_ord_pair ko f (sort_oalist_aux ko xs) (sort_oalist_aux ko ys)"
 
 fun prod_ord_raw :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw \<Rightarrow>
                       ('a, 'c::zero, 'o) oalist_raw \<Rightarrow> bool"
   where "prod_ord_raw f (xs, ox) ys = prod_ord_pair ox f xs (sort_oalist_aux ox ys)"
 
 fun oalist_eq_raw :: "('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw \<Rightarrow> bool"
   where "oalist_eq_raw (xs, ox) ys = (xs = (sort_oalist_aux ox ys))"
 
 fun sort_oalist_raw :: "('a, 'b, 'o) oalist_raw \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   where "sort_oalist_raw (xs, ko) = (sort_oalist ko xs, ko)"
 
 subsubsection \<open>@{const sort_oalist_aux}\<close>
 
 lemma set_sort_oalist_aux:
   assumes "oalist_inv xs"
   shows "set (sort_oalist_aux ko xs) = set (fst xs)"
 proof -
   obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
   interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
   from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.set_sort_oalist)
 qed
 
 lemma oalist_inv_raw_sort_oalist_aux:
   assumes "oalist_inv xs"
   shows "oalist_inv_raw ko (sort_oalist_aux ko xs)"
 proof -
   obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
   from assms show ?thesis by (simp add: xs oalist_inv_alt oalist_inv_raw_sort_oalist)
 qed
 
 lemma oalist_inv_sort_oalist_aux:
   assumes "oalist_inv xs"
   shows "oalist_inv (sort_oalist_aux ko xs, ko)"
   unfolding oalist_inv_alt using assms by (rule oalist_inv_raw_sort_oalist_aux)
 
 lemma lookup_pair_sort_oalist_aux:
   assumes "oalist_inv xs"
   shows "lookup_pair ko (sort_oalist_aux ko xs) = lookup_raw xs"
 proof -
   obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
   interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ko')" ..
   from assms show ?thesis by (simp add: xs oalist_inv_alt ko2.lookup_pair_sort_oalist)
 qed
 
 subsubsection \<open>@{const lookup_raw}\<close>
 
 lemma lookup_raw_eq_value:
   assumes "oalist_inv xs" and "v \<noteq> 0"
   shows "lookup_raw xs k = v \<longleftrightarrow> ((k, v) \<in> set (fst xs))"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
   show ?thesis by (simp add: xs, rule lookup_pair_eq_value, fact+)
 qed
 
 lemma lookup_raw_eq_valueI:
   assumes "oalist_inv xs" and "(k, v) \<in> set (fst xs)"
   shows "lookup_raw xs k = v"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_def)
   from assms(2) have "(k, v) \<in> set xs'" by (simp add: xs)
   show ?thesis by (simp add: xs, rule lookup_pair_eq_valueI, fact+)
 qed
 
 lemma lookup_raw_inj:
   assumes "oalist_inv (xs, ko)" and "oalist_inv (ys, ko)" and "lookup_raw (xs, ko) = lookup_raw (ys, ko)"
   shows "xs = ys"
   using assms unfolding lookup_raw.simps oalist_inv_alt by (rule lookup_pair_inj)
 
 subsubsection \<open>@{const sorted_domain_raw}\<close>
 
 lemma set_sorted_domain_raw:
   assumes "oalist_inv xs"
   shows "set (sorted_domain_raw ko xs) = fst ` set (fst xs)"
   using assms by (simp add: sorted_domain_raw_def set_sort_oalist_aux)
 
 corollary in_sorted_domain_raw_iff_lookup_raw:
   assumes "oalist_inv xs"
   shows "k \<in> set (sorted_domain_raw ko xs) \<longleftrightarrow> (lookup_raw xs k \<noteq> 0)"
   unfolding set_sorted_domain_raw[OF assms]
 proof -
   obtain xs' ko' where xs: "xs = (xs', ko')" by fastforce
   from assms show "k \<in> fst ` set (fst xs) \<longleftrightarrow> (lookup_raw xs k \<noteq> 0)"
     by (simp add: xs oalist_inv_alt lookup_pair_eq_0)
 qed
 
 lemma sorted_sorted_domain_raw:
   assumes "oalist_inv xs"
   shows "sorted_wrt (lt_of_key_order (rep_key_order ko)) (sorted_domain_raw ko xs)"
   unfolding sorted_domain_raw_def oalist_inv_alt lt_of_key_order.rep_eq
   by (rule oalist_inv_rawD2, rule oalist_inv_raw_sort_oalist_aux, fact)
 
 subsubsection \<open>@{const tl_raw}\<close>
 
 lemma oalist_inv_tl_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (tl_raw xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs tl_raw.simps oalist_inv_alt by (rule oalist_inv_raw_tl)
 qed
 
 lemma lookup_raw_tl_raw:
   assumes "oalist_inv xs"
   shows "lookup_raw (tl_raw xs) k =
           (if (\<forall>k'\<in>fst ` set (fst xs). le (snd xs) k k') then 0 else lookup_raw xs k)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis by (simp add: xs lookup_pair_tl oalist_inv_alt split del: if_split cong: if_cong)
 qed
 
 lemma lookup_raw_tl_raw':
   assumes "oalist_inv xs"
   shows "lookup_raw (tl_raw xs) k = (if k = fst (List.hd (fst xs)) then 0 else lookup_raw xs k)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis by (simp add: xs lookup_pair_tl' oalist_inv_alt)
 qed
 
 subsubsection \<open>@{const min_key_val_raw}\<close>
 
 lemma min_key_val_raw_alt:
   assumes "oalist_inv xs" and "fst xs \<noteq> []"
   shows "min_key_val_raw ko xs = List.hd (sort_oalist_aux ko xs)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(2) have "xs' \<noteq> []" by (simp add: xs)
   interpret ko2: comparator2 "key_compare (rep_key_order ko)" "key_compare (rep_key_order ox)" ..
   from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
   hence set_sort: "set (sort_oalist ko xs') = set xs'" by (rule ko2.set_sort_oalist)
   also from \<open>xs' \<noteq> []\<close> have "... \<noteq> {}" by simp
   finally have "sort_oalist ko xs' \<noteq> []" by simp
   then obtain k v xs'' where eq: "sort_oalist ko xs' = (k, v) # xs''"
     using prod.exhaust list.exhaust by metis
   hence "(k, v) \<in> set xs'" by (simp add: set_sort[symmetric])
   have *: "le ko k k'" if "k' \<in> fst ` set xs'" for k'
   proof -
     from that have "k' = k \<or> k' \<in> fst ` set xs''" by (simp add: set_sort[symmetric] eq)
     thus ?thesis
     proof
       assume "k' = k"
       thus ?thesis by simp
     next
       have "oalist_inv_raw ko ((k, v) # xs'')" unfolding eq[symmetric] by (fact oalist_inv_raw_sort_oalist)
       moreover assume "k' \<in> fst ` set xs''"
       ultimately have "lt ko k k'" by (rule oalist_inv_raw_ConsD3)
       thus ?thesis by simp
     qed
   qed
   from \<open>xs' \<noteq> []\<close> have "min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs' \<in> set xs'" by (rule min_list_param_in)
   with \<open>oalist_inv_raw ox xs'\<close> have "lookup_pair ox xs' (fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs')) =
     snd (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs')" by (auto intro: lookup_pair_eq_valueI)
   moreover have 1: "fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs') = k"
   proof (rule antisym)
     from order_trans
     have "transp (\<lambda>x y. le ko (fst x) (fst y))" by (rule transpI)
     hence "le ko (fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs')) (fst (k, v))"
       using linear \<open>(k, v) \<in> set xs'\<close> by (rule min_list_param_minimal)
     thus "le ko (fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs')) k" by simp
   next
     show "le ko k (fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs'))" by (rule *, rule imageI, fact)
   qed
   ultimately have "snd (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs') = lookup_pair ox xs' k"
     by simp
   also from \<open>oalist_inv_raw ox xs'\<close> \<open>(k, v) \<in> set xs'\<close> have "... = v" by (rule lookup_pair_eq_valueI)
   finally have "snd (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs') = v" .
   with 1 have "min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs' = (k, v)" by auto
   thus ?thesis by (simp add: xs eq)
 qed
 
 lemma min_key_val_raw_in:
   assumes "fst xs \<noteq> []"
   shows "min_key_val_raw ko xs \<in> set (fst xs)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms have "xs' \<noteq> []" by (simp add: xs)
   show ?thesis unfolding xs
   proof (simp, intro conjI impI)
     from \<open>xs' \<noteq> []\<close> show "hd xs' \<in> set xs'" by simp
   next
     from \<open>xs' \<noteq> []\<close> show "min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs' \<in> set xs'"
       by (rule min_list_param_in)
   qed
 qed
 
 lemma snd_min_key_val_raw:
   assumes "oalist_inv xs" and "fst xs \<noteq> []"
   shows "snd (min_key_val_raw ko xs) = lookup_raw xs (fst (min_key_val_raw ko xs))"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
   from assms(2) have "min_key_val_raw ko xs \<in> set (fst xs)" by (rule min_key_val_raw_in)
   hence *: "min_key_val_raw ko (xs', ox) \<in> set xs'" by (simp add: xs)
   show ?thesis unfolding xs lookup_raw.simps
     by (rule HOL.sym, rule lookup_pair_eq_valueI, fact, simp add: * del: min_key_val_raw.simps)
 qed
 
 lemma min_key_val_raw_minimal:
   assumes "oalist_inv xs" and "z \<in> set (fst xs)"
   shows "le ko (fst (min_key_val_raw ko xs)) (fst z)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms have "oalist_inv (xs', ox)" and "z \<in> set xs'" by (simp_all add: xs)
   show ?thesis unfolding xs
   proof (simp, intro conjI impI)
     from \<open>z \<in> set xs'\<close> have "xs' \<noteq> []" by auto
     then obtain k v ys where xs': "xs' = (k, v) # ys" using prod.exhaust list.exhaust by metis
     from \<open>z \<in> set xs'\<close> have "z = (k, v) \<or> z \<in> set ys" by (simp add: xs')
     thus "le ox (fst (hd xs')) (fst z)"
     proof
       assume "z = (k, v)"
       show ?thesis by (simp add: xs' \<open>z = (k, v)\<close>)
     next
       assume "z \<in> set ys"
       hence "fst z \<in> fst ` set ys" by fastforce
       with \<open>oalist_inv (xs', ox)\<close> have "lt ox k (fst z)"
         unfolding xs' oalist_inv_alt lt_of_key_order.rep_eq by (rule oalist_inv_raw_ConsD3)
       thus ?thesis by (simp add: xs')
     qed
   next
     show "le ko (fst (min_list_param (\<lambda>x y. le ko (fst x) (fst y)) xs')) (fst z)"
     proof (rule min_list_param_minimal[of "\<lambda>x y. le ko (fst x) (fst y)"])
       thm trans local.trans order.trans local.order_trans
       print_context
       show "transp (\<lambda>x y. le ko (fst x) (fst y))" by (metis (no_types, lifting) order_trans transpI)
     qed (auto intro: \<open>z \<in> set xs'\<close>)
   qed
 qed
 
 subsubsection \<open>@{const filter_raw}\<close>
 
 lemma oalist_inv_filter_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (filter_raw P xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs filter_raw.simps oalist_inv_alt
     by (rule oalist_inv_raw_filter)
 qed
 
 lemma lookup_raw_filter_raw:
   assumes "oalist_inv xs"
   shows "lookup_raw (filter_raw P xs) k = (let v = lookup_raw xs k in if P (k, v) then v else 0)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs lookup_raw.simps filter_raw.simps oalist_inv_alt
     by (rule lookup_pair_filter)
 qed
 
 subsubsection \<open>@{const update_by_raw}\<close>
 
 lemma oalist_inv_update_by_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (update_by_raw kv xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs update_by_raw.simps oalist_inv_alt
     by (rule oalist_inv_raw_update_by_pair)
 qed
 
 lemma lookup_raw_update_by_raw:
   assumes "oalist_inv xs"
   shows "lookup_raw (update_by_raw (k1, v) xs) k2 = (if k1 = k2 then v else lookup_raw xs k2)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs lookup_raw.simps update_by_raw.simps oalist_inv_alt
     by (rule lookup_pair_update_by_pair)
 qed
 
 subsubsection \<open>@{const update_by_fun_raw} and @{const update_by_fun_gr_raw}\<close>
 
 lemma update_by_fun_raw_eq_update_by_raw:
   assumes "oalist_inv xs"
   shows "update_by_fun_raw k f xs = update_by_raw (k, f (lookup_raw xs k)) xs"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
   show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_raw.simps
     by (rule, rule conjI, rule update_by_fun_pair_eq_update_by_pair, fact, fact HOL.refl)
 qed
 
 corollary oalist_inv_update_by_fun_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (update_by_fun_raw k f xs)"
   unfolding update_by_fun_raw_eq_update_by_raw[OF assms] using assms by (rule oalist_inv_update_by_raw)
 
 corollary lookup_raw_update_by_fun_raw:
   assumes "oalist_inv xs"
   shows "lookup_raw (update_by_fun_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
   using assms by (simp add: update_by_fun_raw_eq_update_by_raw lookup_raw_update_by_raw)
 
 lemma update_by_fun_gr_raw_eq_update_by_fun_raw:
   assumes "oalist_inv xs"
   shows "update_by_fun_gr_raw k f xs = update_by_fun_raw k f xs"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
   show ?thesis unfolding xs update_by_fun_raw.simps lookup_raw.simps update_by_fun_gr_raw.simps
     by (rule, rule conjI, rule update_by_fun_gr_pair_eq_update_by_fun_pair, fact, fact HOL.refl)
 qed
 
 corollary oalist_inv_update_by_fun_gr_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (update_by_fun_gr_raw k f xs)"
   unfolding update_by_fun_gr_raw_eq_update_by_fun_raw[OF assms] using assms by (rule oalist_inv_update_by_fun_raw)
 
 corollary lookup_raw_update_by_fun_gr_raw:
   assumes "oalist_inv xs"
   shows "lookup_raw (update_by_fun_gr_raw k1 f xs) k2 = (if k1 = k2 then f else id) (lookup_raw xs k2)"
   using assms by (simp add: update_by_fun_gr_raw_eq_update_by_fun_raw lookup_raw_update_by_fun_raw)
 
 subsubsection \<open>@{const map_raw} and @{const map_val_raw}\<close>
 
 lemma map_raw_cong:
   assumes "\<And>kv. kv \<in> set (fst xs) \<Longrightarrow> f kv = g kv"
   shows "map_raw f xs = map_raw g xs"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "f kv = g kv" if "kv \<in> set xs'" for kv using that by (simp add: xs)
   thus ?thesis by (simp add: xs, rule map_pair_cong)
 qed
 
 lemma map_raw_subset: "set (fst (map_raw f xs)) \<subseteq> f ` set (fst xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   show ?thesis by (simp add: xs map_pair_subset)
 qed
 
 lemma oalist_inv_map_raw:
   assumes "oalist_inv xs"
     and "\<And>a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
   shows "oalist_inv (map_raw f xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
   moreover from assms(2)
   have "\<And>a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
     by (simp add: xs)
   ultimately show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_pair)
 qed
 
 lemma lookup_raw_map_raw:
   assumes "oalist_inv xs" and "snd (f (k, 0)) = 0"
     and "\<And>a b. key_compare (rep_key_order (snd xs)) (fst (f a)) (fst (f b)) = key_compare (rep_key_order (snd xs)) (fst a) (fst b)"
   shows "lookup_raw (map_raw f xs) (fst (f (k, v))) = snd (f (k, lookup_raw xs k))"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms(1) have "oalist_inv (xs', ko)" by (simp only: xs)
   moreover note assms(2)
   moreover from assms(3)
   have "\<And>a b. key_compare (rep_key_order ko) (fst (f a)) (fst (f b)) = key_compare (rep_key_order ko) (fst a) (fst b)"
     by (simp add: xs)
   ultimately show ?thesis unfolding xs lookup_raw.simps map_raw.simps oalist_inv_alt
     by (rule lookup_pair_map_pair)
 qed
 
 lemma map_raw_id:
   assumes "oalist_inv xs"
   shows "map_raw id xs = xs"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
   hence "map_pair id xs' = xs'"
   proof (induct xs' rule: oalist_inv_raw_induct)
     case Nil
     show ?case by simp
   next
     case (Cons k v xs')
     show ?case by (simp add: Let_def Cons(3, 5) id_def[symmetric])
   qed
   thus ?thesis by (simp add: xs)
 qed
 
 lemma map_val_raw_cong:
   assumes "\<And>k v. (k, v) \<in> set (fst xs) \<Longrightarrow> f k v = g k v"
   shows "map_val_raw f xs = map_val_raw g xs"
 proof (rule map_raw_cong)
   fix kv
   assume "kv \<in> set (fst xs)"
   moreover obtain k v where "kv = (k, v)" by fastforce
   ultimately show "(case kv of (k, v) \<Rightarrow> (k, f k v)) = (case kv of (k, v) \<Rightarrow> (k, g k v))"
     by (simp add: assms)
 qed
 
 lemma oalist_inv_map_val_raw:
   assumes "oalist_inv xs"
   shows "oalist_inv (map_val_raw f xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs map_raw.simps oalist_inv_alt by (rule oalist_inv_raw_map_val_pair)
 qed
 
 lemma lookup_raw_map_val_raw:
   assumes "oalist_inv xs" and "f k 0 = 0"
   shows "lookup_raw (map_val_raw f xs) k = f k (lookup_raw xs k)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms show ?thesis unfolding xs map_raw.simps lookup_raw.simps oalist_inv_alt
     by (rule lookup_pair_map_val_pair)
 qed
 
 subsubsection \<open>@{const map2_val_raw}\<close>
 
 definition map2_val_compat' :: "(('a, 'b::zero, 'o) oalist_raw \<Rightarrow> ('a, 'c::zero, 'o) oalist_raw) \<Rightarrow> bool"
   where "map2_val_compat' f \<longleftrightarrow>
       (\<forall>zs. (oalist_inv zs \<longrightarrow> (oalist_inv (f zs) \<and> snd (f zs) = snd zs \<and> fst ` set (fst (f zs)) \<subseteq> fst ` set (fst zs))))"
 
 lemma map2_val_compat'I:
   assumes "\<And>zs. oalist_inv zs \<Longrightarrow> oalist_inv (f zs)"
     and "\<And>zs. oalist_inv zs \<Longrightarrow> snd (f zs) = snd zs"
     and "\<And>zs. oalist_inv zs \<Longrightarrow> fst ` set (fst (f zs)) \<subseteq> fst ` set (fst zs)"
   shows "map2_val_compat' f"
   unfolding map2_val_compat'_def using assms by blast
 
 lemma map2_val_compat'D1:
   assumes "map2_val_compat' f" and "oalist_inv zs"
   shows "oalist_inv (f zs)"
   using assms unfolding map2_val_compat'_def by blast
 
 lemma map2_val_compat'D2:
   assumes "map2_val_compat' f" and "oalist_inv zs"
   shows "snd (f zs) = snd zs"
   using assms unfolding map2_val_compat'_def by blast
 
 lemma map2_val_compat'D3:
   assumes "map2_val_compat' f" and "oalist_inv zs"
   shows "fst ` set (fst (f zs)) \<subseteq> fst ` set (fst zs)"
   using assms unfolding map2_val_compat'_def by blast
 
 lemma map2_val_compat'_map_val_raw: "map2_val_compat' (map_val_raw f)"
 proof (rule map2_val_compat'I, erule oalist_inv_map_val_raw)
   fix zs::"('a, 'b, 'o) oalist_raw"
   obtain zs' ko where "zs = (zs', ko)" by fastforce
   thus "snd (map_val_raw f zs) = snd zs" by simp
 next
   fix zs::"('a, 'b, 'o) oalist_raw"
   obtain zs' ko where zs: "zs = (zs', ko)" by fastforce
   show "fst ` set (fst (map_val_raw f zs)) \<subseteq> fst ` set (fst zs)"
   proof (simp add: zs)
     from map_pair_subset have "fst ` set (map_val_pair f zs') \<subseteq> fst ` (\<lambda>(k, v). (k, f k v)) ` set zs'"
       by (rule image_mono)
     also have "... = fst ` set zs'" by force
     finally show "fst ` set (map_val_pair f zs') \<subseteq> fst ` set zs'" .
   qed
 qed
 
 lemma map2_val_compat'_id: "map2_val_compat' id"
   by (rule map2_val_compat'I, auto)
 
 lemma map2_val_compat'_imp_map2_val_compat:
   assumes "map2_val_compat' g"
   shows "map2_val_compat ko (\<lambda>zs. fst (g (zs, ko)))"
 proof (rule map2_val_compatI)
   fix zs::"('a \<times> 'b) list"
   assume a: "oalist_inv_raw ko zs"
   hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
   with assms have "oalist_inv (g (zs, ko))" by (rule map2_val_compat'D1)
   hence "oalist_inv (fst (g (zs, ko)), snd (g (zs, ko)))" by simp
   thus "oalist_inv_raw ko (fst (g (zs, ko)))" using assms a by (simp add: oalist_inv_alt map2_val_compat'D2)
 next
   fix zs::"('a \<times> 'b) list"
   assume a: "oalist_inv_raw ko zs"
   hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
   with assms have "fst ` set (fst (g (zs, ko))) \<subseteq> fst ` set (fst (zs, ko))" by (rule map2_val_compat'D3)
   thus "fst ` set (fst (g (zs, ko))) \<subseteq> fst ` set zs" by simp
 qed
 
 lemma oalist_inv_map2_val_raw:
   assumes "oalist_inv xs" and "oalist_inv ys"
   assumes "map2_val_compat' g" and "map2_val_compat' h"
   shows "oalist_inv (map2_val_raw f g h xs ys)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   let ?ys = "sort_oalist_aux ox ys"
   from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
   moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)"
     by (rule oalist_inv_raw_sort_oalist_aux)
   moreover from assms(3) have "map2_val_compat ko (\<lambda>zs. fst (g (zs, ko)))" for ko
     by (rule map2_val_compat'_imp_map2_val_compat)
   moreover from assms(4) have "map2_val_compat ko (\<lambda>zs. fst (h (zs, ko)))" for ko
     by (rule map2_val_compat'_imp_map2_val_compat)
   ultimately have "oalist_inv_raw ox (map2_val_pair ox f (\<lambda>zs. fst (g (zs, ox))) (\<lambda>zs. fst (h (zs, ox))) xs' ?ys)"
     by (rule oalist_inv_raw_map2_val_pair)
   thus ?thesis by (simp add: xs oalist_inv_alt)
 qed
 
 lemma lookup_raw_map2_val_raw:
   assumes "oalist_inv xs" and "oalist_inv ys"
   assumes "map2_val_compat' g" and "map2_val_compat' h"
   assumes "\<And>zs. oalist_inv zs \<Longrightarrow> g zs = map_val_raw (\<lambda>k v. f k v 0) zs"
     and "\<And>zs. oalist_inv zs \<Longrightarrow> h zs = map_val_raw (\<lambda>k. f k 0) zs"
     and "\<And>k. f k 0 0 = 0"
   shows "lookup_raw (map2_val_raw f g h xs ys) k0 = f k0 (lookup_raw xs k0) (lookup_raw ys k0)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   let ?ys = "sort_oalist_aux ox ys"
   from assms(1) have "oalist_inv_raw ox xs'" by (simp add: xs oalist_inv_alt)
   moreover from assms(2) have "oalist_inv_raw ox (sort_oalist_aux ox ys)" by (rule oalist_inv_raw_sort_oalist_aux)
   moreover from assms(3) have "map2_val_compat ko (\<lambda>zs. fst (g (zs, ko)))" for ko
     by (rule map2_val_compat'_imp_map2_val_compat)
   moreover from assms(4) have "map2_val_compat ko (\<lambda>zs. fst (h (zs, ko)))" for ko
     by (rule map2_val_compat'_imp_map2_val_compat)
   ultimately have "lookup_pair ox (map2_val_pair ox f (\<lambda>zs. fst (g (zs, ox))) (\<lambda>zs. fst (h (zs, ox))) xs' ?ys) k0 =
                       f k0 (lookup_pair ox xs' k0) (lookup_pair ox ?ys k0)" using _ _ assms(7)
   proof (rule lookup_pair_map2_val_pair)
     fix zs::"('a \<times> 'b) list"
     assume "oalist_inv_raw ox zs"
     hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
     hence "g (zs, ox) = map_val_raw (\<lambda>k v. f k v 0) (zs, ox)" by (rule assms(5))
     thus "fst (g (zs, ox)) = map_val_pair (\<lambda>k v. f k v 0) zs" by simp
   next
     fix zs::"('a \<times> 'c) list"
     assume "oalist_inv_raw ox zs"
     hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
     hence "h (zs, ox) = map_val_raw (\<lambda>k. f k 0) (zs, ox)" by (rule assms(6))
     thus "fst (h (zs, ox)) = map_val_pair (\<lambda>k. f k 0) zs" by simp
   qed
   also from assms(2) have "... = f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)"
     by (simp only: lookup_pair_sort_oalist_aux)
   finally have *: "lookup_pair ox (map2_val_pair ox f (\<lambda>zs. fst (g (zs, ox))) (\<lambda>zs. fst (h (zs, ox))) xs' ?ys) k0 =
                     f k0 (lookup_pair ox xs' k0) (lookup_raw ys k0)" .
   thus ?thesis by (simp add: xs)
 qed
 
 lemma map2_val_raw_singleton_eq_update_by_fun_raw:
   assumes "oalist_inv xs"
   assumes "\<And>k x. f k x 0 = x" and "\<And>zs. oalist_inv zs \<Longrightarrow> g zs = zs"
     and "\<And>ko. h ([(k, v)], ko) = map_val_raw (\<lambda>k. f k 0) ([(k, v)], ko)"
   shows "map2_val_raw f g h xs ([(k, v)], ko) = update_by_fun_raw k (\<lambda>x. f k x v) xs"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   let ?ys = "sort_oalist ox [(k, v)]"
   from assms(1) have inv: "oalist_inv (xs', ox)" by (simp only: xs)
   hence inv_raw: "oalist_inv_raw ox xs'" by (simp only: oalist_inv_alt)
   show ?thesis
   proof (simp add: xs, intro conjI impI)
     assume "ox = ko"
     from inv_raw have "oalist_inv_raw ko xs'" by (simp only: \<open>ox = ko\<close>)
     thus "map2_val_pair ko f (\<lambda>zs. fst (g (zs, ko))) (\<lambda>zs. fst (h (zs, ko))) xs' [(k, v)] =
               update_by_fun_pair ko k (\<lambda>x. f k x v) xs'"
       using assms(2)
     proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
       fix zs::"('a \<times> 'b) list"
       assume "oalist_inv_raw ko zs"
       hence "oalist_inv (zs, ko)" by (simp only: oalist_inv_alt)
       hence "g (zs, ko) = (zs, ko)" by (rule assms(3))
       thus "fst (g (zs, ko)) = zs" by simp
     next
       show "fst (h ([(k, v)], ko)) = map_val_pair (\<lambda>k. f k 0) [(k, v)]" by (simp add: assms(4))
     qed
   next
     show "map2_val_pair ox f (\<lambda>zs. fst (g (zs, ox))) (\<lambda>zs. fst (h (zs, ox))) xs' (sort_oalist ox [(k, v)]) =
           update_by_fun_pair ox k (\<lambda>x. f k x v) xs'"
     proof (cases "v = 0")
       case True
       have eq1: "sort_oalist ox [(k, 0)] = []" by (simp add: sort_oalist_def)
       from inv have eq2: "g (xs', ox) = (xs', ox)" by (rule assms(3))
       show ?thesis
         by (simp add: True eq1 eq2 assms(2) update_by_fun_pair_eq_update_by_pair[OF inv_raw],
             rule HOL.sym, rule update_by_pair_id, fact inv_raw, fact HOL.refl)
     next
       case False
       hence "oalist_inv_raw ox [(k, v)]" by (simp add: oalist_inv_raw_singleton)
       hence eq: "sort_oalist ox [(k, v)] = [(k, v)]" by (rule sort_oalist_id)
       show ?thesis unfolding eq using inv_raw assms(2)
       proof (rule map2_val_pair_singleton_eq_update_by_fun_pair)
         fix zs::"('a \<times> 'b) list"
         assume "oalist_inv_raw ox zs"
         hence "oalist_inv (zs, ox)" by (simp only: oalist_inv_alt)
         hence "g (zs, ox) = (zs, ox)" by (rule assms(3))
         thus "fst (g (zs, ox)) = zs" by simp
       next
         show "fst (h ([(k, v)], ox)) = map_val_pair (\<lambda>k. f k 0) [(k, v)]" by (simp add: assms(4))
       qed
     qed
   qed
 qed
 
 subsubsection \<open>@{const lex_ord_raw}\<close>
 
 lemma lex_ord_raw_EqI:
   assumes "oalist_inv xs" and "oalist_inv ys"
     and "\<And>k. k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys) \<Longrightarrow> f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
   shows "lex_ord_raw ko f xs ys = Some Eq"
   unfolding lex_ord_raw_def
   by (rule lex_ord_pair_EqI, simp_all add: assms oalist_inv_raw_sort_oalist_aux lookup_pair_sort_oalist_aux set_sort_oalist_aux)
 
 lemma lex_ord_raw_valI:
   assumes "oalist_inv xs" and "oalist_inv ys" and "aux \<noteq> Some Eq"
   assumes "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)" and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
     and "\<And>k'. k' \<in> fst ` set (fst xs) \<union> fst ` set (fst ys) \<Longrightarrow> lt ko k' k \<Longrightarrow>
               f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
   shows "lex_ord_raw ko f xs ys = aux"
   unfolding lex_ord_raw_def
   using oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_raw_sort_oalist_aux[OF assms(2)] assms(3)
   unfolding oalist_inv_alt
 proof (rule lex_ord_pair_valI)
   from assms(1, 2, 4) show "k \<in> fst ` set (sort_oalist_aux ko xs) \<union> fst ` set (sort_oalist_aux ko ys)"
     by (simp add: set_sort_oalist_aux)
 next
   from assms(1, 2, 5) show "aux = f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k)"
     by (simp add: lookup_pair_sort_oalist_aux)
 next
   fix k'
   assume "k' \<in> fst ` set (sort_oalist_aux ko xs) \<union> fst ` set (sort_oalist_aux ko ys)"
   with assms(1, 2) have "k' \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)" by (simp add: set_sort_oalist_aux)
   moreover assume "lt ko k' k"
   ultimately have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq" by (rule assms(6))
   with assms(1, 2) show "f k' (lookup_pair ko (sort_oalist_aux ko xs) k') (lookup_pair ko (sort_oalist_aux ko ys) k') = Some Eq"
     by (simp add: lookup_pair_sort_oalist_aux)
 qed
 
 lemma lex_ord_raw_EqD:
   assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = Some Eq"
     and "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)"
   shows "f k (lookup_raw xs k) (lookup_raw ys k) = Some Eq"
 proof -
   have "f k (lookup_pair ko (sort_oalist_aux ko xs) k) (lookup_pair ko (sort_oalist_aux ko ys) k) = Some Eq"
     by (rule lex_ord_pair_EqD[where f=f],
         simp_all add: oalist_inv_raw_sort_oalist_aux assms lex_ord_raw_def[symmetric] set_sort_oalist_aux del: Un_iff)
   with assms(1, 2) show ?thesis by (simp add: lookup_pair_sort_oalist_aux)
 qed
 
 lemma lex_ord_raw_valE:
   assumes "oalist_inv xs" and "oalist_inv ys" and "lex_ord_raw ko f xs ys = aux"
     and "aux \<noteq> Some Eq"
   obtains k where "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)"
     and "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
     and "\<And>k'. k' \<in> fst ` set (fst xs) \<union> fst ` set (fst ys) \<Longrightarrow> lt ko k' k \<Longrightarrow>
             f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
 proof -
   let ?xs = "sort_oalist_aux ko xs"
   let ?ys = "sort_oalist_aux ko ys"
   from assms(3) have "lex_ord_pair ko f ?xs ?ys = aux" by (simp only: lex_ord_raw_def)
   with oalist_inv_sort_oalist_aux[OF assms(1)] oalist_inv_sort_oalist_aux[OF assms(2)]
   obtain k where a: "k \<in> fst ` set ?xs \<union> fst ` set ?ys"
     and b: "aux = f k (lookup_pair ko ?xs k) (lookup_pair ko ?ys k)"
     and c: "\<And>k'. k' \<in> fst ` set ?xs \<union> fst ` set ?ys \<Longrightarrow> lt ko k' k \<Longrightarrow>
             f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k') = Some Eq"
     using assms(4) unfolding oalist_inv_alt by (rule lex_ord_pair_valE, blast)
   from a have "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)"
     by (simp add: set_sort_oalist_aux assms(1, 2))
   moreover from b have "aux = f k (lookup_raw xs k) (lookup_raw ys k)"
     by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
   moreover have "f k' (lookup_raw xs k') (lookup_raw ys k') = Some Eq"
     if k'_in: "k' \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)" and k'_less: "lt ko k' k" for k'
   proof -
     have "f k' (lookup_raw xs k') (lookup_raw ys k') = f k' (lookup_pair ko ?xs k') (lookup_pair ko ?ys k')"
       by (simp add: lookup_pair_sort_oalist_aux assms(1, 2))
     also have "... = Some Eq"
     proof (rule c)
       from k'_in show "k' \<in> fst ` set ?xs \<union> fst ` set ?ys"
         by (simp add:  set_sort_oalist_aux assms(1, 2))
     next
       from k'_less show "lt ko k' k" by (simp only: lt_of_key_order.rep_eq)
     qed
     finally show ?thesis .
   qed
   ultimately show ?thesis ..
 qed
 
 subsubsection \<open>@{const prod_ord_raw}\<close>
 
 lemma prod_ord_rawI:
   assumes "oalist_inv xs" and "oalist_inv ys"
     and "\<And>k. k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys) \<Longrightarrow> P k (lookup_raw xs k) (lookup_raw ys k)"
   shows "prod_ord_raw P xs ys"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
   hence *: "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" using oalist_inv_raw_sort_oalist_aux
   proof (rule prod_ord_pairI)
     fix k
     assume "k \<in> fst ` set xs' \<union> fst ` set (sort_oalist_aux ox ys)"
     hence "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
     hence "P k (lookup_raw xs k) (lookup_raw ys k)" by (rule assms(3))
     thus "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
       by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
   qed fact
   thus ?thesis by (simp add: xs)
 qed
 
 lemma prod_ord_rawD:
   assumes "oalist_inv xs" and "oalist_inv ys" and "prod_ord_raw P xs ys"
     and "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)"
   shows "P k (lookup_raw xs k) (lookup_raw ys k)"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
   moreover note oalist_inv_raw_sort_oalist_aux[OF assms(2)]
   moreover from assms(3) have "prod_ord_pair ox P xs' (sort_oalist_aux ox ys)" by (simp add: xs)
   moreover from assms(4) have "k \<in> fst ` set xs' \<union> fst ` set (sort_oalist_aux ox ys)"
     by (simp add: xs set_sort_oalist_aux assms(2))
   ultimately have *: "P k (lookup_pair ox xs' k) (lookup_pair ox (sort_oalist_aux ox ys) k)"
     by (rule prod_ord_pairD)
   thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
 qed
 
 corollary prod_ord_raw_alt:
   assumes "oalist_inv xs" and "oalist_inv ys"
   shows "prod_ord_raw P xs ys \<longleftrightarrow>
           (\<forall>k\<in>fst ` set (fst xs) \<union> fst ` set (fst ys). P k (lookup_raw xs k) (lookup_raw ys k))"
   using prod_ord_rawI[OF assms] prod_ord_rawD[OF assms] by meson
 
 subsubsection \<open>@{const oalist_eq_raw}\<close>
 
 lemma oalist_eq_rawI:
   assumes "oalist_inv xs" and "oalist_inv ys"
     and "\<And>k. k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys) \<Longrightarrow> lookup_raw xs k = lookup_raw ys k"
   shows "oalist_eq_raw xs ys"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(1) have "oalist_inv_raw ox xs'" by (simp only: xs oalist_inv_alt)
   hence *: "xs' = sort_oalist_aux ox ys" using oalist_inv_raw_sort_oalist_aux[OF assms(2)]
   proof (rule lookup_pair_inj)
     show "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)"
     proof
       fix k
       show "lookup_pair ox xs' k = lookup_pair ox (sort_oalist_aux ox ys) k"
       proof (cases "k \<in> fst ` set xs' \<union> fst ` set (sort_oalist_aux ox ys)")
         case True
         hence "k \<in> fst ` set (fst xs) \<union> fst ` set (fst ys)" by (simp add: xs set_sort_oalist_aux assms(2))
         hence "lookup_raw xs k = lookup_raw ys k" by (rule assms(3))
         thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(2))
       next
         case False
         hence "k \<notin> fst ` set xs'" and "k \<notin> fst ` set (sort_oalist_aux ox ys)" by simp_all
         with \<open>oalist_inv_raw ox xs'\<close> oalist_inv_raw_sort_oalist_aux[OF assms(2)]
         have "lookup_pair ox xs' k = 0" and "lookup_pair ox (sort_oalist_aux ox ys) k = 0"
           by (simp_all add: lookup_pair_eq_0)
         thus ?thesis by simp
       qed
     qed
   qed
   thus ?thesis by (simp add: xs)
 qed
 
 lemma oalist_eq_rawD:
   assumes "oalist_inv ys" and "oalist_eq_raw xs ys"
   shows "lookup_raw xs = lookup_raw ys"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms(2) have "xs' = sort_oalist_aux ox ys" by (simp add: xs)
   hence "lookup_pair ox xs' = lookup_pair ox (sort_oalist_aux ox ys)" by simp
   thus ?thesis by (simp add: xs lookup_pair_sort_oalist_aux assms(1))
 qed
 
 lemma oalist_eq_raw_alt:
   assumes "oalist_inv xs" and "oalist_inv ys"
   shows "oalist_eq_raw xs ys \<longleftrightarrow> (lookup_raw xs = lookup_raw ys)"
   using oalist_eq_rawI[OF assms] oalist_eq_rawD[OF assms(2)] by metis
 
 subsubsection \<open>@{const sort_oalist_raw}\<close>
 
 lemma oalist_inv_sort_oalist_raw: "oalist_inv (sort_oalist_raw xs)"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   show ?thesis by (simp add: xs oalist_inv_raw_sort_oalist oalist_inv_alt)
 qed
 
 lemma sort_oalist_raw_id:
   assumes "oalist_inv xs"
   shows "sort_oalist_raw xs = xs"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "oalist_inv_raw ko xs'" by (simp only: xs oalist_inv_alt)
   hence "sort_oalist ko xs' = xs'" by (rule sort_oalist_id)
   thus ?thesis by (simp add: xs)
 qed
 
 lemma set_sort_oalist_raw:
   assumes "distinct (map fst (fst xs))"
   shows "set (fst (sort_oalist_raw xs)) = {kv. kv \<in> set (fst xs) \<and> snd kv \<noteq> 0}"
 proof -
   obtain xs' ko where xs: "xs = (xs', ko)" by fastforce
   from assms have "distinct (map fst xs')" by (simp add: xs)
   hence "set (sort_oalist ko xs') = {kv \<in> set xs'. snd kv \<noteq> 0}" by (rule set_sort_oalist)
   thus ?thesis by (simp add: xs)
 qed
 
 end (* oalist_raw *)
 
 subsection \<open>Fundamental Operations on One List\<close>
 
 locale oalist_abstract = oalist_raw rep_key_order for rep_key_order::"'o \<Rightarrow> 'a key_order" +
   fixes list_of_oalist :: "'x \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   fixes oalist_of_list :: "('a, 'b, 'o) oalist_raw \<Rightarrow> 'x"
   assumes oalist_inv_list_of_oalist: "oalist_inv (list_of_oalist x)"
   and list_of_oalist_of_list: "list_of_oalist (oalist_of_list xs) = sort_oalist_raw xs"
   and oalist_of_list_of_oalist: "oalist_of_list (list_of_oalist x) = x"
 begin
 
 lemma list_of_oalist_of_list_id:
   assumes "oalist_inv xs"
   shows "list_of_oalist (oalist_of_list xs) = xs"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   from assms show ?thesis by (simp add: xs list_of_oalist_of_list sort_oalist_id oalist_inv_alt)
 qed
 
 definition lookup :: "'x \<Rightarrow> 'a \<Rightarrow> 'b"
   where "lookup xs = lookup_raw (list_of_oalist xs)"
 
 definition sorted_domain :: "'o \<Rightarrow> 'x \<Rightarrow> 'a list"
   where "sorted_domain ko xs = sorted_domain_raw ko (list_of_oalist xs)"
 
 definition empty :: "'o \<Rightarrow> 'x"
   where "empty ko = oalist_of_list ([], ko)"
 
 definition reorder :: "'o \<Rightarrow> 'x \<Rightarrow> 'x"
   where "reorder ko xs = oalist_of_list (sort_oalist_aux ko (list_of_oalist xs), ko)"
 
 definition tl :: "'x \<Rightarrow> 'x"
   where "tl xs = oalist_of_list (tl_raw (list_of_oalist xs))"
 
 definition hd :: "'x \<Rightarrow> ('a \<times> 'b)"
   where "hd xs = List.hd (fst (list_of_oalist xs))"
 
 definition except_min :: "'o \<Rightarrow> 'x \<Rightarrow> 'x"
   where "except_min ko xs = tl (reorder ko xs)"
 
 definition min_key_val :: "'o \<Rightarrow> 'x \<Rightarrow> ('a \<times> 'b)"
   where "min_key_val ko xs = min_key_val_raw ko (list_of_oalist xs)"
 
 definition insert :: "('a \<times> 'b) \<Rightarrow> 'x \<Rightarrow> 'x"
   where "insert x xs = oalist_of_list (update_by_raw x (list_of_oalist xs))"
 
 definition update_by_fun :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'x \<Rightarrow> 'x"
   where "update_by_fun k f xs = oalist_of_list (update_by_fun_raw k f (list_of_oalist xs))"
 
 definition update_by_fun_gr :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> 'x \<Rightarrow> 'x"
   where "update_by_fun_gr k f xs = oalist_of_list (update_by_fun_gr_raw k f (list_of_oalist xs))"
 
 definition filter :: "(('a \<times> 'b) \<Rightarrow> bool) \<Rightarrow> 'x \<Rightarrow> 'x"
   where "filter P xs = oalist_of_list (filter_raw P (list_of_oalist xs))"
 
 definition map2_val_neutr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'x \<Rightarrow> 'x \<Rightarrow> 'x"
   where "map2_val_neutr f xs ys = oalist_of_list (map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys))"
 
 definition oalist_eq :: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   where "oalist_eq xs ys = oalist_eq_raw (list_of_oalist xs) (list_of_oalist ys)"
 
 subsubsection \<open>Invariant\<close>
 
 lemma zero_notin_list_of_oalist: "0 \<notin> snd ` set (fst (list_of_oalist xs))"
 proof -
   from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
     by (simp only: oalist_inv_def)
   thus ?thesis by (rule oalist_inv_rawD1)
 qed
 
 lemma list_of_oalist_sorted: "sorted_wrt (lt (snd (list_of_oalist xs))) (map fst (fst (list_of_oalist xs)))"
 proof -
   from oalist_inv_list_of_oalist have "oalist_inv_raw (snd (list_of_oalist xs)) (fst (list_of_oalist xs))"
     by (simp only: oalist_inv_def)
   thus ?thesis by (rule oalist_inv_rawD2)
 qed
 
 subsubsection \<open>@{const lookup}\<close>
 
 lemma lookup_eq_value: "v \<noteq> 0 \<Longrightarrow> lookup xs k = v \<longleftrightarrow> ((k, v) \<in> set (fst (list_of_oalist xs)))"
   unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_value)
 
 lemma lookup_eq_valueI: "(k, v) \<in> set (fst (list_of_oalist xs)) \<Longrightarrow> lookup xs k = v"
   unfolding lookup_def using oalist_inv_list_of_oalist by (rule lookup_raw_eq_valueI)
 
 lemma lookup_oalist_of_list:
   "distinct (map fst xs) \<Longrightarrow> lookup (oalist_of_list (xs, ko)) = lookup_dflt xs"
   by (simp add: list_of_oalist_of_list lookup_def lookup_pair_sort_oalist')
 
 subsubsection \<open>@{const sorted_domain}\<close>
 
 lemma set_sorted_domain: "set (sorted_domain ko xs) = fst ` set (fst (list_of_oalist xs))"
   unfolding sorted_domain_def using oalist_inv_list_of_oalist by (rule set_sorted_domain_raw)
 
 lemma in_sorted_domain_iff_lookup: "k \<in> set (sorted_domain ko xs) \<longleftrightarrow> (lookup xs k \<noteq> 0)"
   unfolding sorted_domain_def lookup_def using oalist_inv_list_of_oalist
   by (rule in_sorted_domain_raw_iff_lookup_raw)
 
 lemma sorted_sorted_domain: "sorted_wrt (lt ko) (sorted_domain ko xs)"
   unfolding sorted_domain_def lt_of_key_order.rep_eq[symmetric]
   using oalist_inv_list_of_oalist by (rule sorted_sorted_domain_raw)
 
 subsubsection \<open>@{const empty} and Singletons\<close>
 
 lemma list_of_oalist_empty [simp, code abstract]: "list_of_oalist (empty ko) = ([], ko)"
   by (simp add: empty_def sort_oalist_def list_of_oalist_of_list)
 
 lemma lookup_empty: "lookup (empty ko) k = 0"
   by (simp add: lookup_def)
 
 lemma lookup_oalist_of_list_single:
   "lookup (oalist_of_list ([(k, v)], ko)) k' = (if k = k' then v else 0)"
   by (simp add: lookup_def list_of_oalist_of_list sort_oalist_def key_compare_Eq split: order.split)
 
 subsubsection \<open>@{const reorder}\<close>
 
 lemma list_of_oalist_reorder [simp, code abstract]:
   "list_of_oalist (reorder ko xs) = (sort_oalist_aux ko (list_of_oalist xs), ko)"
   unfolding reorder_def
   by (rule list_of_oalist_of_list_id, simp add: oalist_inv_def, rule oalist_inv_raw_sort_oalist_aux, fact oalist_inv_list_of_oalist)
 
 lemma lookup_reorder: "lookup (reorder ko xs) k = lookup xs k"
   by (simp add: lookup_def lookup_pair_sort_oalist_aux oalist_inv_list_of_oalist)
 
 subsubsection \<open>@{const hd} and @{const tl}\<close>
 
 lemma list_of_oalist_tl [simp, code abstract]: "list_of_oalist (tl xs) = tl_raw (list_of_oalist xs)"
   unfolding tl_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_tl_raw, fact oalist_inv_list_of_oalist)
 
 lemma lookup_tl:
   "lookup (tl xs) k =
         (if (\<forall>k'\<in>fst ` set (fst (list_of_oalist xs)). le (snd (list_of_oalist xs)) k k') then 0 else lookup xs k)"
   by (simp add: lookup_def lookup_raw_tl_raw oalist_inv_list_of_oalist)
 
 lemma hd_in:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "hd xs \<in> set (fst (list_of_oalist xs))"
   unfolding hd_def using assms by (rule hd_in_set)
 
 lemma snd_hd:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "snd (hd xs) = lookup xs (fst (hd xs))"
 proof -
   from assms have *: "hd xs \<in> set (fst (list_of_oalist xs))" by (rule hd_in)
   show ?thesis by (rule HOL.sym, rule lookup_eq_valueI, simp add: *)
 qed
 
 lemma lookup_tl': "lookup (tl xs) k = (if k = fst (hd xs) then 0 else lookup xs k)"
   by (simp add: lookup_def lookup_raw_tl_raw' oalist_inv_list_of_oalist hd_def)
 
 lemma hd_tl:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "list_of_oalist xs = ((hd xs) # (fst (list_of_oalist (tl xs))), snd (list_of_oalist (tl xs)))"
 proof -
   obtain xs' ko where xs: "list_of_oalist xs = (xs', ko)" by fastforce
   from assms obtain x xs'' where xs': "xs' = x # xs''" unfolding xs fst_conv using list.exhaust by blast
   show ?thesis by (simp add: xs xs' hd_def)
 qed
 
 subsubsection \<open>@{const min_key_val}\<close>
 
 lemma min_key_val_alt:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "min_key_val ko xs = hd (reorder ko xs)"
   using assms oalist_inv_list_of_oalist by (simp add: min_key_val_def hd_def min_key_val_raw_alt)
 
 lemma min_key_val_in:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "min_key_val ko xs \<in> set (fst (list_of_oalist xs))"
   unfolding min_key_val_def using assms by (rule min_key_val_raw_in)
 
 lemma snd_min_key_val:
   assumes "fst (list_of_oalist xs) \<noteq> []"
   shows "snd (min_key_val ko xs) = lookup xs (fst (min_key_val ko xs))"
   unfolding lookup_def min_key_val_def using oalist_inv_list_of_oalist assms by (rule snd_min_key_val_raw)
 
 lemma min_key_val_minimal:
   assumes "z \<in> set (fst (list_of_oalist xs))"
   shows "le ko (fst (min_key_val ko xs)) (fst z)"
   unfolding min_key_val_def
   by (rule min_key_val_raw_minimal, fact oalist_inv_list_of_oalist, fact)
 
 subsubsection \<open>@{const except_min}\<close>
 
 lemma list_of_oalist_except_min [simp, code abstract]:
   "list_of_oalist (except_min ko xs) = (List.tl (sort_oalist_aux ko (list_of_oalist xs)), ko)"
   by (simp add: except_min_def)
 
 lemma except_min_Nil:
   assumes "fst (list_of_oalist xs) = []"
   shows "fst (list_of_oalist (except_min ko xs)) = []"
 proof -
   obtain xs' ox where eq: "list_of_oalist xs = (xs', ox)" by fastforce
   from assms have "xs' = []" by (simp add: eq)
   show ?thesis by (simp add: eq \<open>xs' = []\<close> sort_oalist_def)
 qed
 
 lemma lookup_except_min:
   "lookup (except_min ko xs) k =
         (if (\<forall>k'\<in>fst ` set (fst (list_of_oalist xs)). le ko k k') then 0 else lookup xs k)"
   by (simp add: except_min_def lookup_tl set_sort_oalist_aux oalist_inv_list_of_oalist lookup_reorder)
 
 lemma lookup_except_min':
   "lookup (except_min ko xs) k = (if k = fst (min_key_val ko xs) then 0 else lookup xs k)"
 proof (cases "fst (list_of_oalist xs) = []")
   case True
   hence "lookup xs k = 0" by (metis empty_def lookup_empty oalist_of_list_of_oalist prod.collapse)
   thus ?thesis by (simp add: lookup_except_min True)
 next
   case False
   thus ?thesis by (simp add: except_min_def lookup_tl' min_key_val_alt lookup_reorder)
 qed
 
 subsubsection \<open>@{const insert}\<close>
 
 lemma list_of_oalist_insert [simp, code abstract]:
   "list_of_oalist (insert x xs) = update_by_raw x (list_of_oalist xs)"
   unfolding insert_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_raw, fact oalist_inv_list_of_oalist)
 
 lemma lookup_insert: "lookup (insert (k, v) xs) k' = (if k = k' then v else lookup xs k')"
   by (simp add: lookup_def lookup_raw_update_by_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)
 
 subsubsection \<open>@{const update_by_fun} and @{const update_by_fun_gr}\<close>
 
 lemma list_of_oalist_update_by_fun [simp, code abstract]:
   "list_of_oalist (update_by_fun k f xs) = update_by_fun_raw k f (list_of_oalist xs)"
   unfolding update_by_fun_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_raw, fact oalist_inv_list_of_oalist)
 
 lemma lookup_update_by_fun:
   "lookup (update_by_fun k f xs) k' = (if k = k' then f else id) (lookup xs k')"
   by (simp add: lookup_def lookup_raw_update_by_fun_raw oalist_inv_list_of_oalist split del: if_split cong: if_cong)
 
 lemma list_of_oalist_update_by_fun_gr [simp, code abstract]:
   "list_of_oalist (update_by_fun_gr k f xs) = update_by_fun_gr_raw k f (list_of_oalist xs)"
   unfolding update_by_fun_gr_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_update_by_fun_gr_raw, fact oalist_inv_list_of_oalist)
 
 lemma update_by_fun_gr_eq_update_by_fun: "update_by_fun_gr = update_by_fun"
   by (rule, rule, rule,
       simp add: update_by_fun_gr_def update_by_fun_def update_by_fun_gr_raw_eq_update_by_fun_raw oalist_inv_list_of_oalist)
 
 subsubsection \<open>@{const filter}\<close>
 
 lemma list_of_oalist_filter [simp, code abstract]:
   "list_of_oalist (filter P xs) = filter_raw P (list_of_oalist xs)"
   unfolding filter_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_filter_raw, fact oalist_inv_list_of_oalist)
 
 lemma lookup_filter: "lookup (filter P xs) k = (let v = lookup xs k in if P (k, v) then v else 0)"
   by (simp add: lookup_def lookup_raw_filter_raw oalist_inv_list_of_oalist)
 
 subsubsection \<open>@{const map2_val_neutr}\<close>
 
 lemma list_of_oalist_map2_val_neutr [simp, code abstract]:
   "list_of_oalist (map2_val_neutr f xs ys) = map2_val_raw f id id (list_of_oalist xs) (list_of_oalist ys)"
   unfolding map2_val_neutr_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
       fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
       fact map2_val_compat'_id, fact map2_val_compat'_id)
 
 lemma lookup_map2_val_neutr:
   assumes "\<And>k x. f k x 0 = x" and "\<And>k x. f k 0 x = x"
   shows "lookup (map2_val_neutr f xs ys) k = f k (lookup xs k) (lookup ys k)"
 proof (simp add: lookup_def, rule lookup_raw_map2_val_raw)
   fix zs::"('a, 'b, 'o) oalist_raw"
   assume "oalist_inv zs"
   thus "id zs = map_val_raw (\<lambda>k v. f k v 0) zs" by (simp add: assms(1) map_raw_id)
 next
   fix zs::"('a, 'b, 'o) oalist_raw"
   assume "oalist_inv zs"
   thus "id zs = map_val_raw (\<lambda>k. f k 0) zs" by (simp add: assms(2) map_raw_id)
 qed (fact oalist_inv_list_of_oalist, fact oalist_inv_list_of_oalist,
     fact map2_val_compat'_id, fact map2_val_compat'_id, simp only: assms(1))
 
 subsubsection \<open>@{const oalist_eq}\<close>
 
 lemma oalist_eq_alt: "oalist_eq xs ys \<longleftrightarrow> (lookup xs = lookup ys)"
   by (simp add: oalist_eq_def lookup_def oalist_eq_raw_alt oalist_inv_list_of_oalist)
 
 end (* oalist_abstract *)
 
 subsection \<open>Fundamental Operations on Three Lists\<close>
 
 locale oalist_abstract3 =
   oalist_abstract rep_key_order list_of_oalistx oalist_of_listx +
   oay: oalist_abstract rep_key_order list_of_oalisty oalist_of_listy +
   oaz: oalist_abstract rep_key_order list_of_oalistz oalist_of_listz
   for rep_key_order :: "'o \<Rightarrow> 'a key_order"
   and list_of_oalistx :: "'x \<Rightarrow> ('a, 'b::zero, 'o) oalist_raw"
   and oalist_of_listx :: "('a, 'b, 'o) oalist_raw \<Rightarrow> 'x"
   and list_of_oalisty :: "'y \<Rightarrow> ('a, 'c::zero, 'o) oalist_raw"
   and oalist_of_listy :: "('a, 'c, 'o) oalist_raw \<Rightarrow> 'y"
   and list_of_oalistz :: "'z \<Rightarrow> ('a, 'd::zero, 'o) oalist_raw"
   and oalist_of_listz :: "('a, 'd, 'o) oalist_raw \<Rightarrow> 'z"
 begin
 
 definition map_val :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'x \<Rightarrow> 'y"
   where "map_val f xs = oalist_of_listy (map_val_raw f (list_of_oalistx xs))"
 
 definition map2_val :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'x \<Rightarrow> 'y \<Rightarrow> 'z"
   where "map2_val f xs ys =
             oalist_of_listz (map2_val_raw f (map_val_raw (\<lambda>k b. f k b 0)) (map_val_raw (\<lambda>k. f k 0))
               (list_of_oalistx xs) (list_of_oalisty ys))"
 
 definition map2_val_rneutr :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> 'x \<Rightarrow> 'y \<Rightarrow> 'x"
   where "map2_val_rneutr f xs ys =
             oalist_of_listx (map2_val_raw f id (map_val_raw (\<lambda>k. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys))"
 
 definition lex_ord :: "'o \<Rightarrow> ('a \<Rightarrow> ('b, 'c) comp_opt) \<Rightarrow> ('x, 'y) comp_opt"
   where "lex_ord ko f xs ys = lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys)"
 
 definition prod_ord :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'x \<Rightarrow> 'y \<Rightarrow> bool"
   where "prod_ord f xs ys = prod_ord_raw f (list_of_oalistx xs) (list_of_oalisty ys)"
 
 subsubsection \<open>@{const map_val}\<close>
 
 lemma map_val_cong:
   assumes "\<And>k v. (k, v) \<in> set (fst (list_of_oalistx xs)) \<Longrightarrow> f k v = g k v"
   shows "map_val f xs = map_val g xs"
   unfolding map_val_def by (rule arg_cong[where f=oalist_of_listy], rule map_val_raw_cong, elim assms)
 
 lemma list_of_oalist_map_val [simp, code abstract]:
   "list_of_oalisty (map_val f xs) = map_val_raw f (list_of_oalistx xs)"
   unfolding map_val_def
   by (rule oay.list_of_oalist_of_list_id, rule oalist_inv_map_val_raw, fact oalist_inv_list_of_oalist)
 
 lemma lookup_map_val: "f k 0 = 0 \<Longrightarrow> oay.lookup (map_val f xs) k = f k (lookup xs k)"
   by (simp add: oay.lookup_def lookup_def lookup_raw_map_val_raw oalist_inv_list_of_oalist)
 
 subsubsection \<open>@{const map2_val} and @{const map2_val_rneutr}\<close>
 
 lemma list_of_oalist_map2_val [simp, code abstract]:
   "list_of_oalistz (map2_val f xs ys) =
       map2_val_raw f (map_val_raw (\<lambda>k b. f k b 0)) (map_val_raw (\<lambda>k. f k 0)) (list_of_oalistx xs) (list_of_oalisty ys)"
   unfolding map2_val_def
   by (rule oaz.list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
       fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
       fact map2_val_compat'_map_val_raw, fact map2_val_compat'_map_val_raw)
 
 lemma list_of_oalist_map2_val_rneutr [simp, code abstract]:
   "list_of_oalistx (map2_val_rneutr f xs ys) =
       map2_val_raw f id (map_val_raw (\<lambda>k c. f k 0 c)) (list_of_oalistx xs) (list_of_oalisty ys)"
   unfolding map2_val_rneutr_def
   by (rule list_of_oalist_of_list_id, rule oalist_inv_map2_val_raw,
       fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
       fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw)
 
 lemma lookup_map2_val:
   assumes "\<And>k. f k 0 0 = 0"
   shows "oaz.lookup (map2_val f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
   by (simp add: oaz.lookup_def oay.lookup_def lookup_def lookup_raw_map2_val_raw
       map2_val_compat'_map_val_raw assms oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)
 
 lemma lookup_map2_val_rneutr:
   assumes "\<And>k x. f k x 0 = x"
   shows "lookup (map2_val_rneutr f xs ys) k = f k (lookup xs k) (oay.lookup ys k)"
 proof (simp add: lookup_def oay.lookup_def, rule lookup_raw_map2_val_raw)
   fix zs::"('a, 'b, 'o) oalist_raw"
   assume "oalist_inv zs"
   thus "id zs = map_val_raw (\<lambda>k v. f k v 0) zs" by (simp add: assms map_raw_id)
 qed (fact oalist_inv_list_of_oalist, fact oay.oalist_inv_list_of_oalist,
     fact map2_val_compat'_id, fact map2_val_compat'_map_val_raw, rule HOL.refl, simp only: assms)
 
 lemma map2_val_rneutr_singleton_eq_update_by_fun:
   assumes "\<And>a x. f a x 0 = x" and "list_of_oalisty ys = ([(k, v)], oy)"
   shows "map2_val_rneutr f xs ys = update_by_fun k (\<lambda>x. f k x v) xs"
   by (simp add: map2_val_rneutr_def update_by_fun_def assms map2_val_raw_singleton_eq_update_by_fun_raw oalist_inv_list_of_oalist)
 
 subsubsection \<open>@{const lex_ord} and @{const prod_ord}\<close>
 
 lemma lex_ord_EqI:
   "(\<And>k. k \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
      f k (lookup xs k) (oay.lookup ys k) = Some Eq) \<Longrightarrow>
   lex_ord ko f xs ys = Some Eq"
   by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqI,
       rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, blast)
 
 lemma lex_ord_valI:
   assumes "aux \<noteq> Some Eq" and "k \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys))"
   shows "aux = f k (lookup xs k) (oay.lookup ys k) \<Longrightarrow>
          (\<And>k'. k' \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
               lt ko k' k \<Longrightarrow> f k' (lookup xs k') (oay.lookup ys k') = Some Eq) \<Longrightarrow>
           lex_ord ko f xs ys = aux"
   by (simp (no_asm_use) add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_valI,
       rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, rule assms(1), rule assms(2), blast+)
 
 lemma lex_ord_EqD:
   "lex_ord ko f xs ys = Some Eq \<Longrightarrow>
    k \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
    f k (lookup xs k) (oay.lookup ys k) = Some Eq"
   by (simp add: lex_ord_def lookup_def oay.lookup_def, rule lex_ord_raw_EqD[where f=f],
       rule oalist_inv_list_of_oalist, rule oay.oalist_inv_list_of_oalist, assumption, simp)
 
 lemma lex_ord_valE:
   assumes "lex_ord ko f xs ys = aux" and "aux \<noteq> Some Eq"
   obtains k where "k \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys))"
     and "aux = f k (lookup xs k) (oay.lookup ys k)"
     and "\<And>k'. k' \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
             lt ko k' k \<Longrightarrow> f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
 proof -
   note oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist
   moreover from assms(1) have "lex_ord_raw ko f (list_of_oalistx xs) (list_of_oalisty ys) = aux"
     by (simp only: lex_ord_def)
   ultimately obtain k where 1: "k \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys))"
     and "aux = f k (lookup_raw (list_of_oalistx xs) k) (lookup_raw (list_of_oalisty ys) k)"
     and "\<And>k'. k' \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
             lt ko k' k \<Longrightarrow>
             f k' (lookup_raw (list_of_oalistx xs) k') (lookup_raw (list_of_oalisty ys) k') = Some Eq"
     using assms(2) by (rule lex_ord_raw_valE, blast)
   from this(2, 3) have "aux = f k (lookup xs k) (oay.lookup ys k)"
     and "\<And>k'. k' \<in> fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)) \<Longrightarrow>
             lt ko k' k \<Longrightarrow> f k' (lookup xs k') (oay.lookup ys k') = Some Eq"
     by (simp_all only: lookup_def oay.lookup_def)
   with 1 show ?thesis ..
 qed
 
 lemma prod_ord_alt:
   "prod_ord P xs ys \<longleftrightarrow>
                   (\<forall>k\<in>fst ` set (fst (list_of_oalistx xs)) \<union> fst ` set (fst (list_of_oalisty ys)).
                       P k (lookup xs k) (oay.lookup ys k))"
   by (simp add: prod_ord_def lookup_def oay.lookup_def prod_ord_raw_alt oalist_inv_list_of_oalist oay.oalist_inv_list_of_oalist)
 
 end (* oalist_abstract3 *)
 
 subsection \<open>Type \<open>oalist\<close>\<close>
 
 global_interpretation ko: comparator "key_compare ko"
   defines lookup_pair_ko = ko.lookup_pair
   and update_by_pair_ko = ko.update_by_pair
   and update_by_fun_pair_ko = ko.update_by_fun_pair
   and update_by_fun_gr_pair_ko = ko.update_by_fun_gr_pair
   and map2_val_pair_ko = ko.map2_val_pair
   and lex_ord_pair_ko = ko.lex_ord_pair
   and prod_ord_pair_ko = ko.prod_ord_pair
   and sort_oalist_ko' = ko.sort_oalist
   by (fact comparator_key_compare)
 
 lemma ko_le: "ko.le = le_of_key_order"
   by (intro ext, simp add: le_of_comp_def le_of_key_order_alt split: order.split)
 
 global_interpretation ko: oalist_raw "\<lambda>x. x"
   rewrites "comparator.lookup_pair (key_compare ko) = lookup_pair_ko ko"
   and "comparator.update_by_pair (key_compare ko) = update_by_pair_ko ko"
   and "comparator.update_by_fun_pair (key_compare ko) = update_by_fun_pair_ko ko"
   and "comparator.update_by_fun_gr_pair (key_compare ko) = update_by_fun_gr_pair_ko ko"
   and "comparator.map2_val_pair (key_compare ko) = map2_val_pair_ko ko"
   and "comparator.lex_ord_pair (key_compare ko) = lex_ord_pair_ko ko"
   and "comparator.prod_ord_pair (key_compare ko) = prod_ord_pair_ko ko"
   and "comparator.sort_oalist (key_compare ko) = sort_oalist_ko' ko"
   defines sort_oalist_aux_ko = ko.sort_oalist_aux
   and lookup_ko = ko.lookup_raw
   and sorted_domain_ko = ko.sorted_domain_raw
   and tl_ko = ko.tl_raw
   and min_key_val_ko = ko.min_key_val_raw
   and update_by_ko = ko.update_by_raw
   and update_by_fun_ko = ko.update_by_fun_raw
   and update_by_fun_gr_ko = ko.update_by_fun_gr_raw
   and map2_val_ko = ko.map2_val_raw
   and lex_ord_ko = ko.lex_ord_raw
   and prod_ord_ko = ko.prod_ord_raw
   and oalist_eq_ko = ko.oalist_eq_raw
   and sort_oalist_ko = ko.sort_oalist_raw
   subgoal by (simp only: lookup_pair_ko_def)
   subgoal by (simp only: update_by_pair_ko_def)
   subgoal by (simp only: update_by_fun_pair_ko_def)
   subgoal by (simp only: update_by_fun_gr_pair_ko_def)
   subgoal by (simp only: map2_val_pair_ko_def)
   subgoal by (simp only: lex_ord_pair_ko_def)
   subgoal by (simp only: prod_ord_pair_ko_def)
   subgoal by (simp only: sort_oalist_ko'_def)
   done
 
 typedef (overloaded) ('a, 'b) oalist = "{xs::('a, 'b::zero, 'a key_order) oalist_raw. ko.oalist_inv xs}"
   morphisms list_of_oalist Abs_oalist
   by (auto simp: ko.oalist_inv_def intro: ko.oalist_inv_raw_Nil)
 
 lemma oalist_eq_iff: "xs = ys \<longleftrightarrow> list_of_oalist xs = list_of_oalist ys"
   by (simp add: list_of_oalist_inject)
 
 lemma oalist_eqI: "list_of_oalist xs = list_of_oalist ys \<Longrightarrow> xs = ys"
   by (simp add: oalist_eq_iff)
 
 text \<open>Formal, totalized constructor for @{typ "('a, 'b) oalist"}:\<close>
 
 definition OAlist :: "('a \<times> 'b) list \<times> 'a key_order \<Rightarrow> ('a, 'b::zero) oalist" where
   "OAlist xs = Abs_oalist (sort_oalist_ko xs)"
 
 definition "oalist_of_list = OAlist"
 
 lemma oalist_inv_list_of_oalist: "ko.oalist_inv (list_of_oalist xs)"
   using list_of_oalist [of xs] by simp
 
 lemma list_of_oalist_OAlist: "list_of_oalist (OAlist xs) = sort_oalist_ko xs"
 proof -
   obtain xs' ox where xs: "xs = (xs', ox)" by fastforce
   show ?thesis by (simp add: xs OAlist_def Abs_oalist_inverse ko.oalist_inv_raw_sort_oalist ko.oalist_inv_alt)
 qed
 
 lemma OAlist_list_of_oalist [code abstype]: "OAlist (list_of_oalist xs) = xs"
 proof -
   obtain xs' ox where xs: "list_of_oalist xs = (xs', ox)" by fastforce
   have "ko.oalist_inv_raw ox xs'" by (simp add: xs[symmetric] ko.oalist_inv_alt[symmetric] oalist_inv_list_of_oalist)
   thus ?thesis by (simp add: xs OAlist_def ko.sort_oalist_id, simp add: list_of_oalist_inverse xs[symmetric])
 qed
 
 lemma [code abstract]: "list_of_oalist (oalist_of_list xs) = sort_oalist_ko xs"
   by (simp add: list_of_oalist_OAlist oalist_of_list_def)
 
 global_interpretation oa: oalist_abstract "\<lambda>x. x" list_of_oalist OAlist
   defines OAlist_lookup = oa.lookup
   and OAlist_sorted_domain = oa.sorted_domain
   and OAlist_empty = oa.empty
   and OAlist_reorder = oa.reorder
   and OAlist_tl = oa.tl
   and OAlist_hd = oa.hd
   and OAlist_except_min = oa.except_min
   and OAlist_min_key_val = oa.min_key_val
   and OAlist_insert = oa.insert
   and OAlist_update_by_fun = oa.update_by_fun
   and OAlist_update_by_fun_gr = oa.update_by_fun_gr
   and OAlist_filter = oa.filter
   and OAlist_map2_val_neutr = oa.map2_val_neutr
   and OAlist_eq = oa.oalist_eq
   apply standard
   subgoal by (fact oalist_inv_list_of_oalist)
   subgoal by (simp only: list_of_oalist_OAlist sort_oalist_ko_def)
   subgoal by (fact OAlist_list_of_oalist)
   done
 
 global_interpretation oa: oalist_abstract3 "\<lambda>x. x"
     "list_of_oalist::('a, 'b) oalist \<Rightarrow> ('a, 'b::zero, 'a key_order) oalist_raw" OAlist
     "list_of_oalist::('a, 'c) oalist \<Rightarrow> ('a, 'c::zero, 'a key_order) oalist_raw" OAlist
     "list_of_oalist::('a, 'd) oalist \<Rightarrow> ('a, 'd::zero, 'a key_order) oalist_raw" OAlist
   defines OAlist_map_val = oa.map_val
   and OAlist_map2_val = oa.map2_val
   and OAlist_map2_val_rneutr = oa.map2_val_rneutr
   and OAlist_lex_ord = oa.lex_ord
   and OAlist_prod_ord = oa.prod_ord ..
 
 lemmas OAlist_lookup_single = oa.lookup_oalist_of_list_single[folded oalist_of_list_def]
 
 subsection \<open>Type \<open>oalist_tc\<close>\<close>
 
 text \<open>``tc'' stands for ``type class''.\<close>
 
 global_interpretation tc: comparator "comparator_of"
   defines lookup_pair_tc = tc.lookup_pair
   and update_by_pair_tc = tc.update_by_pair
   and update_by_fun_pair_tc = tc.update_by_fun_pair
   and update_by_fun_gr_pair_tc = tc.update_by_fun_gr_pair
   and map2_val_pair_tc = tc.map2_val_pair
   and lex_ord_pair_tc = tc.lex_ord_pair
   and prod_ord_pair_tc = tc.prod_ord_pair
   and sort_oalist_tc = tc.sort_oalist
   by (fact comparator_of)
 
 lemma tc_le_lt [simp]: "tc.le = (\<le>)" "tc.lt = (<)"
   by (auto simp: le_of_comp_def lt_of_comp_def comparator_of_def intro!: ext split: order.split_asm if_split_asm)
 
 typedef (overloaded) ('a, 'b) oalist_tc = "{xs::('a::linorder \<times> 'b::zero) list. tc.oalist_inv_raw xs}"
   morphisms list_of_oalist_tc Abs_oalist_tc
   by (auto intro: tc.oalist_inv_raw_Nil)
 
 lemma oalist_tc_eq_iff: "xs = ys \<longleftrightarrow> list_of_oalist_tc xs = list_of_oalist_tc ys"
   by (simp add: list_of_oalist_tc_inject)
 
 lemma oalist_tc_eqI: "list_of_oalist_tc xs = list_of_oalist_tc ys \<Longrightarrow> xs = ys"
   by (simp add: oalist_tc_eq_iff)
 
 text \<open>Formal, totalized constructor for @{typ "('a, 'b) oalist_tc"}:\<close>
 
 definition OAlist_tc :: "('a \<times> 'b) list \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc" where
   "OAlist_tc xs = Abs_oalist_tc (sort_oalist_tc xs)"
 
 definition "oalist_tc_of_list = OAlist_tc"
 
 lemma oalist_inv_list_of_oalist_tc: "tc.oalist_inv_raw (list_of_oalist_tc xs)"
   using list_of_oalist_tc[of xs] by simp
 
 lemma list_of_oalist_OAlist_tc: "list_of_oalist_tc (OAlist_tc xs) = sort_oalist_tc xs"
   by (simp add: OAlist_tc_def Abs_oalist_tc_inverse tc.oalist_inv_raw_sort_oalist)
 
 lemma OAlist_list_of_oalist_tc [code abstype]: "OAlist_tc (list_of_oalist_tc xs) = xs"
   by (simp add: OAlist_tc_def tc.sort_oalist_id list_of_oalist_tc_inverse oalist_inv_list_of_oalist_tc)
 
 lemma list_of_oalist_tc_of_list [code abstract]: "list_of_oalist_tc (oalist_tc_of_list xs) = sort_oalist_tc xs"
   by (simp add: list_of_oalist_OAlist_tc oalist_tc_of_list_def)
 
 lemma list_of_oalist_tc_of_list_id:
   assumes "tc.oalist_inv_raw xs"
   shows "list_of_oalist_tc (OAlist_tc xs) = xs"
   using assms by (simp add: list_of_oalist_OAlist_tc tc.sort_oalist_id)
 
 text \<open>It is better to define the following operations directly instead of interpreting
   @{locale oalist_abstract}, because @{locale oalist_abstract} defines the operations via their
   \<open>_raw\<close> analogues, whereas in this case we can define them directly via their \<open>_pair\<close> analogues.\<close>
 
 definition OAlist_tc_lookup :: "('a::linorder, 'b::zero) oalist_tc \<Rightarrow> 'a \<Rightarrow> 'b"
   where "OAlist_tc_lookup xs = lookup_pair_tc (list_of_oalist_tc xs)"
 
 definition OAlist_tc_sorted_domain :: "('a::linorder, 'b::zero) oalist_tc \<Rightarrow> 'a list"
   where "OAlist_tc_sorted_domain xs = map fst (list_of_oalist_tc xs)"
 
 definition OAlist_tc_empty :: "('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_empty = OAlist_tc []"
 
 definition OAlist_tc_except_min :: "('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_except_min xs = OAlist_tc (tl (list_of_oalist_tc xs))"
 
 definition OAlist_tc_min_key_val :: "('a::linorder, 'b::zero) oalist_tc \<Rightarrow> ('a \<times> 'b)"
   where "OAlist_tc_min_key_val xs = hd (list_of_oalist_tc xs)"
 
 definition OAlist_tc_insert :: "('a \<times> 'b) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_insert x xs = OAlist_tc (update_by_pair_tc x (list_of_oalist_tc xs))"
 
 definition OAlist_tc_update_by_fun :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_update_by_fun k f xs = OAlist_tc (update_by_fun_pair_tc k f (list_of_oalist_tc xs))"
 
 definition OAlist_tc_update_by_fun_gr :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_update_by_fun_gr k f xs = OAlist_tc (update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs))"
 
 definition OAlist_tc_filter :: "(('a \<times> 'b) \<Rightarrow> bool) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_filter P xs = OAlist_tc (filter P (list_of_oalist_tc xs))"
 
 definition OAlist_tc_map_val :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 'b::zero) oalist_tc \<Rightarrow> ('a::linorder, 'c::zero) oalist_tc"
   where "OAlist_tc_map_val f xs = OAlist_tc (map_val_pair f (list_of_oalist_tc xs))"
 
 definition OAlist_tc_map2_val :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> ('a, 'b::zero) oalist_tc \<Rightarrow> ('a, 'c::zero) oalist_tc \<Rightarrow>
                                     ('a::linorder, 'd::zero) oalist_tc"
   where "OAlist_tc_map2_val f xs ys =
             OAlist_tc (map2_val_pair_tc f (map_val_pair (\<lambda>k b. f k b 0)) (map_val_pair (\<lambda>k. f k 0))
               (list_of_oalist_tc xs) (list_of_oalist_tc ys))"
 
 definition OAlist_tc_map2_val_rneutr :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> ('a, 'c::zero) oalist_tc \<Rightarrow>
                                     ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_map2_val_rneutr f xs ys =
             OAlist_tc (map2_val_pair_tc f id (map_val_pair (\<lambda>k. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys))"
 
 definition OAlist_tc_map2_val_neutr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow>
                                           ('a, 'b) oalist_tc \<Rightarrow> ('a::linorder, 'b::zero) oalist_tc"
   where "OAlist_tc_map2_val_neutr f xs ys = OAlist_tc (map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys))"
 
 definition OAlist_tc_lex_ord :: "('a \<Rightarrow> ('b, 'c) comp_opt) \<Rightarrow> (('a, 'b::zero) oalist_tc, ('a::linorder, 'c::zero) oalist_tc) comp_opt"
   where "OAlist_tc_lex_ord f xs ys = lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
 
 definition OAlist_tc_prod_ord :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a, 'b::zero) oalist_tc \<Rightarrow> ('a::linorder, 'c::zero) oalist_tc \<Rightarrow> bool"
   where "OAlist_tc_prod_ord f xs ys = prod_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
 
 subsubsection \<open>@{const OAlist_tc_lookup}\<close>
 
 lemma OAlist_tc_lookup_eq_valueI: "(k, v) \<in> set (list_of_oalist_tc xs) \<Longrightarrow> OAlist_tc_lookup xs k = v"
   unfolding OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc by (rule tc.lookup_pair_eq_valueI)
 
 lemma OAlist_tc_lookup_inj: "OAlist_tc_lookup xs = OAlist_tc_lookup ys \<Longrightarrow> xs = ys"
   by (simp add: OAlist_tc_lookup_def oalist_inv_list_of_oalist_tc oalist_tc_eqI tc.lookup_pair_inj)
 
 lemma OAlist_tc_lookup_oalist_of_list:
   "distinct (map fst xs) \<Longrightarrow> OAlist_tc_lookup (oalist_tc_of_list xs) = lookup_dflt xs"
   by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.lookup_pair_sort_oalist')
 
 subsubsection \<open>@{const OAlist_tc_sorted_domain}\<close>
 
 lemma set_OAlist_tc_sorted_domain: "set (OAlist_tc_sorted_domain xs) = fst ` set (list_of_oalist_tc xs)"
   unfolding OAlist_tc_sorted_domain_def by simp
 
 lemma in_OAlist_tc_sorted_domain_iff_lookup: "k \<in> set (OAlist_tc_sorted_domain xs) \<longleftrightarrow> (OAlist_tc_lookup xs k \<noteq> 0)"
   unfolding OAlist_tc_sorted_domain_def OAlist_tc_lookup_def using oalist_inv_list_of_oalist_tc tc.lookup_pair_eq_0
   by fastforce
 
 lemma sorted_OAlist_tc_sorted_domain: "sorted_wrt (<) (OAlist_tc_sorted_domain xs)"
   unfolding OAlist_tc_sorted_domain_def tc_le_lt[symmetric] using oalist_inv_list_of_oalist_tc
   by (rule tc.oalist_inv_rawD2)
 
 subsubsection \<open>@{const OAlist_tc_empty} and Singletons\<close>
 
 lemma list_of_oalist_OAlist_tc_empty [simp, code abstract]: "list_of_oalist_tc OAlist_tc_empty = []"
   unfolding OAlist_tc_empty_def using tc.oalist_inv_raw_Nil by (rule list_of_oalist_tc_of_list_id)
 
 lemma lookup_OAlist_tc_empty: "OAlist_tc_lookup OAlist_tc_empty k = 0"
   by (simp add: OAlist_tc_lookup_def)
 
 lemma OAlist_tc_lookup_single:
   "OAlist_tc_lookup (oalist_tc_of_list [(k, v)]) k' = (if k = k' then v else 0)"
   by (simp add: OAlist_tc_lookup_def list_of_oalist_tc_of_list tc.sort_oalist_def comparator_of_def split: order.split)
 
 subsubsection \<open>@{const OAlist_tc_except_min}\<close>
 
 lemma list_of_oalist_OAlist_tc_except_min [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_except_min xs) = tl (list_of_oalist_tc xs)"
   unfolding OAlist_tc_except_min_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_tl, fact oalist_inv_list_of_oalist_tc)
 
 lemma lookup_OAlist_tc_except_min:
   "OAlist_tc_lookup (OAlist_tc_except_min xs) k =
         (if (\<forall>k'\<in>fst ` set (list_of_oalist_tc xs). k \<le> k') then 0 else OAlist_tc_lookup xs k)"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_tl oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
 
 subsubsection \<open>@{const OAlist_tc_min_key_val}\<close>
 
 lemma OAlist_tc_min_key_val_in:
   assumes "list_of_oalist_tc xs \<noteq> []"
   shows "OAlist_tc_min_key_val xs \<in> set (list_of_oalist_tc xs)"
   unfolding OAlist_tc_min_key_val_def using assms by simp
 
 lemma snd_OAlist_tc_min_key_val:
   assumes "list_of_oalist_tc xs \<noteq> []"
   shows "snd (OAlist_tc_min_key_val xs) = OAlist_tc_lookup xs (fst (OAlist_tc_min_key_val xs))"
 proof -
   let ?xs = "list_of_oalist_tc xs"
   from assms have *: "OAlist_tc_min_key_val xs \<in> set ?xs" by (rule OAlist_tc_min_key_val_in)
   show ?thesis unfolding OAlist_tc_lookup_def
     by (rule HOL.sym, rule tc.lookup_pair_eq_valueI, fact oalist_inv_list_of_oalist_tc, simp add: *)
 qed
 
 lemma OAlist_tc_min_key_val_minimal:
   assumes "z \<in> set (list_of_oalist_tc xs)"
   shows "fst (OAlist_tc_min_key_val xs) \<le> fst z"
 proof -
   let ?xs = "list_of_oalist_tc xs"
   from assms have "?xs \<noteq> []" by auto
   hence "OAlist_tc_sorted_domain xs \<noteq> []" by (simp add: OAlist_tc_sorted_domain_def)
   then obtain h xs' where eq: "OAlist_tc_sorted_domain xs = h # xs'" using list.exhaust by blast
   with sorted_OAlist_tc_sorted_domain[of xs] have *: "\<forall>y\<in>set xs'. h < y" by simp
   from assms have "fst z \<in> set (OAlist_tc_sorted_domain xs)" by (simp add: OAlist_tc_sorted_domain_def)
   hence disj: "fst z = h \<or> fst z \<in> set xs'" by (simp add: eq)
   from \<open>?xs \<noteq> []\<close> have "fst (OAlist_tc_min_key_val xs) = hd (OAlist_tc_sorted_domain xs)"
     by (simp add: OAlist_tc_min_key_val_def OAlist_tc_sorted_domain_def hd_map)
   also have "... = h" by (simp add: eq)
   also from disj have "... \<le> fst z"
   proof
     assume "fst z = h"
     thus ?thesis by simp
   next
     assume "fst z \<in> set xs'"
     with * have "h < fst z" ..
     thus ?thesis by simp
   qed
   finally show ?thesis .
 qed
 
 subsubsection \<open>@{const OAlist_tc_insert}\<close>
 
 lemma list_of_oalist_OAlist_tc_insert [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_insert x xs) = update_by_pair_tc x (list_of_oalist_tc xs)"
   unfolding OAlist_tc_insert_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_pair, fact oalist_inv_list_of_oalist_tc)
 
 lemma lookup_OAlist_tc_insert: "OAlist_tc_lookup (OAlist_tc_insert (k, v) xs) k' = (if k = k' then v else OAlist_tc_lookup xs k')"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
 
 subsubsection \<open>@{const OAlist_tc_update_by_fun} and @{const OAlist_tc_update_by_fun_gr}\<close>
 
 lemma list_of_oalist_OAlist_tc_update_by_fun [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_update_by_fun k f xs) = update_by_fun_pair_tc k f (list_of_oalist_tc xs)"
   unfolding OAlist_tc_update_by_fun_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_pair, fact oalist_inv_list_of_oalist_tc)
 
 lemma lookup_OAlist_tc_update_by_fun:
   "OAlist_tc_lookup (OAlist_tc_update_by_fun k f xs) k' = (if k = k' then f else id) (OAlist_tc_lookup xs k')"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_update_by_fun_pair oalist_inv_list_of_oalist_tc split del: if_split cong: if_cong)
 
 lemma list_of_oalist_OAlist_tc_update_by_fun_gr [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_update_by_fun_gr k f xs) = update_by_fun_gr_pair_tc k f (list_of_oalist_tc xs)"
   unfolding OAlist_tc_update_by_fun_gr_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_update_by_fun_gr_pair, fact oalist_inv_list_of_oalist_tc)
 
 lemma OAlist_tc_update_by_fun_gr_eq_OAlist_tc_update_by_fun: "OAlist_tc_update_by_fun_gr = OAlist_tc_update_by_fun"
   by (rule, rule, rule,
       simp add: OAlist_tc_update_by_fun_gr_def OAlist_tc_update_by_fun_def
                 tc.update_by_fun_gr_pair_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)
 
 subsubsection \<open>@{const OAlist_tc_filter}\<close>
 
 lemma list_of_oalist_OAlist_tc_filter [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_filter P xs) = filter P (list_of_oalist_tc xs)"
   unfolding OAlist_tc_filter_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_filter, fact oalist_inv_list_of_oalist_tc)
 
 lemma lookup_OAlist_tc_filter: "OAlist_tc_lookup (OAlist_tc_filter P xs) k = (let v = OAlist_tc_lookup xs k in if P (k, v) then v else 0)"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_filter oalist_inv_list_of_oalist_tc)
 
 subsubsection \<open>@{const OAlist_tc_map_val}\<close>
 
 lemma list_of_oalist_OAlist_tc_map_val [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_map_val f xs) = map_val_pair f (list_of_oalist_tc xs)"
   unfolding OAlist_tc_map_val_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map_val_pair, fact oalist_inv_list_of_oalist_tc)
 
 lemma OAlist_tc_map_val_cong:
   assumes "\<And>k v. (k, v) \<in> set (list_of_oalist_tc xs) \<Longrightarrow> f k v = g k v"
   shows "OAlist_tc_map_val f xs = OAlist_tc_map_val g xs"
   unfolding OAlist_tc_map_val_def by (rule arg_cong[where f=OAlist_tc], rule tc.map_val_pair_cong, elim assms)
 
 lemma lookup_OAlist_tc_map_val: "f k 0 = 0 \<Longrightarrow> OAlist_tc_lookup (OAlist_tc_map_val f xs) k = f k (OAlist_tc_lookup xs k)"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map_val_pair oalist_inv_list_of_oalist_tc)
 
 subsubsection \<open>@{const OAlist_tc_map2_val} @{const OAlist_tc_map2_val_rneutr} and @{const OAlist_tc_map2_val_neutr}\<close>
 
 lemma list_of_oalist_map2_val [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_map2_val f xs ys) =
       map2_val_pair_tc f (map_val_pair (\<lambda>k b. f k b 0)) (map_val_pair (\<lambda>k. f k 0)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
   unfolding OAlist_tc_map2_val_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
       fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
       fact tc.map2_val_compat_map_val_pair, fact tc.map2_val_compat_map_val_pair)
 
 lemma list_of_oalist_OAlist_tc_map2_val_rneutr [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_map2_val_rneutr f xs ys) =
       map2_val_pair_tc f id (map_val_pair (\<lambda>k c. f k 0 c)) (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
   unfolding OAlist_tc_map2_val_rneutr_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
       fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
       fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair)
 
 lemma list_of_oalist_OAlist_tc_map2_val_neutr [simp, code abstract]:
   "list_of_oalist_tc (OAlist_tc_map2_val_neutr f xs ys) = map2_val_pair_tc f id id (list_of_oalist_tc xs) (list_of_oalist_tc ys)"
   unfolding OAlist_tc_map2_val_neutr_def
   by (rule list_of_oalist_tc_of_list_id, rule tc.oalist_inv_raw_map2_val_pair,
       fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
       fact tc.map2_val_compat_id, fact tc.map2_val_compat_id)
 
 lemma lookup_OAlist_tc_map2_val:
   assumes "\<And>k. f k 0 0 = 0"
   shows "OAlist_tc_lookup (OAlist_tc_map2_val f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
   by (simp add: OAlist_tc_lookup_def tc.lookup_pair_map2_val_pair
       tc.map2_val_compat_map_val_pair assms oalist_inv_list_of_oalist_tc)
 
 lemma lookup_OAlist_tc_map2_val_rneutr:
   assumes "\<And>k x. f k x 0 = x"
   shows "OAlist_tc_lookup (OAlist_tc_map2_val_rneutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
 proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
   fix zs::"('a \<times> 'b) list"
   assume "tc.oalist_inv_raw zs"
   thus "id zs = map_val_pair (\<lambda>k v. f k v 0) zs" by (simp add: assms tc.map_pair_id)
 qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
     fact tc.map2_val_compat_id, fact tc.map2_val_compat_map_val_pair, rule refl, simp only: assms)
 
 lemma lookup_OAlist_tc_map2_val_neutr:
   assumes "\<And>k x. f k x 0 = x" and "\<And>k x. f k 0 x = x"
   shows "OAlist_tc_lookup (OAlist_tc_map2_val_neutr f xs ys) k = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
 proof (simp add: OAlist_tc_lookup_def, rule tc.lookup_pair_map2_val_pair)
   fix zs::"('a \<times> 'b) list"
   assume "tc.oalist_inv_raw zs"
   thus "id zs = map_val_pair (\<lambda>k v. f k v 0) zs" by (simp add: assms(1) tc.map_pair_id)
 next
   fix zs::"('a \<times> 'b) list"
   assume "tc.oalist_inv_raw zs"
   thus "id zs = map_val_pair (\<lambda>k. f k 0) zs" by (simp add: assms(2) tc.map_pair_id)
 qed (fact oalist_inv_list_of_oalist_tc, fact oalist_inv_list_of_oalist_tc,
     fact tc.map2_val_compat_id, fact tc.map2_val_compat_id, simp only: assms(1))
 
 lemma OAlist_tc_map2_val_rneutr_singleton_eq_OAlist_tc_update_by_fun:
   assumes "\<And>a x. f a x 0 = x" and "list_of_oalist_tc ys = [(k, v)]"
   shows "OAlist_tc_map2_val_rneutr f xs ys = OAlist_tc_update_by_fun k (\<lambda>x. f k x v) xs"
   by (simp add: OAlist_tc_map2_val_rneutr_def OAlist_tc_update_by_fun_def assms
       tc.map2_val_pair_singleton_eq_update_by_fun_pair oalist_inv_list_of_oalist_tc)
 
 subsubsection \<open>@{const OAlist_tc_lex_ord} and @{const OAlist_tc_prod_ord}\<close>
 
 lemma OAlist_tc_lex_ord_EqI:
   "(\<And>k. k \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
      f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq) \<Longrightarrow>
   OAlist_tc_lex_ord f xs ys = Some Eq"
   by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqI,
       rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, blast)
 
 lemma OAlist_tc_lex_ord_valI:
   assumes "aux \<noteq> Some Eq" and "k \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)"
   shows "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) \<Longrightarrow>
          (\<And>k'. k' \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
               k' < k \<Longrightarrow> f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq) \<Longrightarrow>
           OAlist_tc_lex_ord f xs ys = aux"
   by (simp (no_asm_use) add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_valI,
       rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, rule assms(1), rule assms(2), simp_all)
 
 lemma OAlist_tc_lex_ord_EqD:
   "OAlist_tc_lex_ord f xs ys = Some Eq \<Longrightarrow>
    k \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
    f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k) = Some Eq"
   by (simp add: OAlist_tc_lex_ord_def OAlist_tc_lookup_def, rule tc.lex_ord_pair_EqD[where f=f],
       rule oalist_inv_list_of_oalist_tc, rule oalist_inv_list_of_oalist_tc, assumption, simp)
 
 lemma OAlist_tc_lex_ord_valE:
   assumes "OAlist_tc_lex_ord f xs ys = aux" and "aux \<noteq> Some Eq"
   obtains k where "k \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)"
     and "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
     and "\<And>k'. k' \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
             k' < k \<Longrightarrow> f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
 proof -
   note oalist_inv_list_of_oalist_tc oalist_inv_list_of_oalist_tc
   moreover from assms(1) have "lex_ord_pair_tc f (list_of_oalist_tc xs) (list_of_oalist_tc ys) = aux"
     by (simp only: OAlist_tc_lex_ord_def)
   ultimately obtain k where 1: "k \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)"
     and "aux = f k (lookup_pair_tc (list_of_oalist_tc xs) k) (lookup_pair_tc (list_of_oalist_tc ys) k)"
     and "\<And>k'. k' \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
             k' < k \<Longrightarrow>
             f k' (lookup_pair_tc (list_of_oalist_tc xs) k') (lookup_pair_tc (list_of_oalist_tc ys) k') = Some Eq"
     using assms(2) unfolding tc_le_lt[symmetric] by (rule tc.lex_ord_pair_valE, blast)
   from this(2, 3) have "aux = f k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k)"
     and "\<And>k'. k' \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys) \<Longrightarrow>
             k' < k \<Longrightarrow> f k' (OAlist_tc_lookup xs k') (OAlist_tc_lookup ys k') = Some Eq"
     by (simp_all only: OAlist_tc_lookup_def)
   with 1 show ?thesis ..
 qed
 
 lemma OAlist_tc_prod_ord_alt:
   "OAlist_tc_prod_ord P xs ys \<longleftrightarrow>
                   (\<forall>k\<in>fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys).
                       P k (OAlist_tc_lookup xs k) (OAlist_tc_lookup ys k))"
   by (simp add: OAlist_tc_prod_ord_def OAlist_tc_lookup_def tc.prod_ord_pair_alt oalist_inv_list_of_oalist_tc)
 
 subsubsection \<open>Instance of @{class equal}\<close>
 
 instantiation oalist_tc :: (linorder, zero) equal
 begin
 
 definition equal_oalist_tc :: "('a, 'b) oalist_tc \<Rightarrow> ('a, 'b) oalist_tc \<Rightarrow> bool"
   where "equal_oalist_tc xs ys = (list_of_oalist_tc xs = list_of_oalist_tc ys)"
 
 instance by (intro_classes, simp add: equal_oalist_tc_def list_of_oalist_tc_inject)
 
 end
 
 subsection \<open>Experiment\<close>
 
 lemma "oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)] = oalist_tc_of_list [(0, 4), (1, 3)]"
   by eval
 
 lemma "OAlist_tc_except_min (oalist_tc_of_list ([(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)])) = oalist_tc_of_list [(1, 3)]"
   by eval
 
 lemma "OAlist_tc_min_key_val (oalist_tc_of_list [(1, 3), (0::nat, 4::nat), (0, 2), (1, 1)]) = (0, 4)"
   by eval
 
 lemma "OAlist_tc_lookup (oalist_tc_of_list [(0::nat, 4::nat), (1, 3), (0, 2), (1, 1)]) 1 = 3"
   by eval
 
 lemma "OAlist_tc_prod_ord (\<lambda>_. greater_eq)
                 (oalist_tc_of_list [(1, 4), (0::nat, 4::nat), (1, 3), (0, 2), (3, 1)])
                 (oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) = False"
   by eval
 
 lemma "OAlist_tc_map2_val_rneutr (\<lambda>_. minus)
                 (oalist_tc_of_list [(1, 4), (0::nat, 4::int), (1, 3), (0, 2), (3, 1)])
                 (oalist_tc_of_list [(0, 4), (1, 3), (2, 2), (1, 1)]) =
              oalist_tc_of_list [(1, 1), (2, - 2), (3, 1)]"
   by eval
 
 end (* theory *)
diff --git a/thys/Polynomials/Power_Products.thy b/thys/Polynomials/Power_Products.thy
--- a/thys/Polynomials/Power_Products.thy
+++ b/thys/Polynomials/Power_Products.thy
@@ -1,2698 +1,2698 @@
 (* Author: Fabian Immler, Alexander Maletzky *)
 
 section \<open>Abstract Power-Products\<close>
 
 theory Power_Products
   imports Complex_Main
   "HOL-Library.Function_Algebras"
   "HOL-Library.Countable"
   "More_MPoly_Type"
   "Utils"
   Well_Quasi_Orders.Well_Quasi_Orders
 begin
 
 text \<open>This theory formalizes the concept of "power-products". A power-product can be thought of as
   the product of some indeterminates, such as $x$, $x^2\,y$, $x\,y^3\,z^7$, etc., without any
   scalar coefficient.
 
 The approach in this theory is to capture the notion of "power-product" (also called "monomial") as
 type class. A canonical instance for power-product is the type @{typ "'var \<Rightarrow>\<^sub>0 nat"}, which is
 interpreted as mapping from variables in the power-product to exponents.
 
 A slightly unintuitive (but fitting better with the standard type class instantiations of
 @{typ "'a \<Rightarrow>\<^sub>0 'b"}) approach is to write addition to denote "multiplication" of power products.
 For example, $x^2y$ would be represented as a function \<open>p = (X \<mapsto> 2, Y \<mapsto> 1)\<close>, $xz$ as a
 function \<open>q = (X \<mapsto> 1, Z \<mapsto> 1)\<close>. With the (pointwise) instantiation of addition of @{typ "'a \<Rightarrow>\<^sub>0 'b"},
 we will write \<open>p + q = (X \<mapsto> 3, Y \<mapsto> 1, Z \<mapsto> 1)\<close> for the product $x^2y \cdot xz = x^3yz$
 \<close>
 
 subsection \<open>Constant @{term Keys}\<close>
 
 text \<open>Legacy:\<close>
 lemmas keys_eq_empty_iff = keys_eq_empty
 
 definition Keys :: "('a \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> 'a set"
   where "Keys F = \<Union>(keys ` F)"
 
 lemma in_Keys: "s \<in> Keys F \<longleftrightarrow> (\<exists>f\<in>F. s \<in> keys f)"
   unfolding Keys_def by simp
 
 lemma in_KeysI:
   assumes "s \<in> keys f" and "f \<in> F"
   shows "s \<in> Keys F"
   unfolding in_Keys using assms ..
 
 lemma in_KeysE:
   assumes "s \<in> Keys F"
   obtains f where "s \<in> keys f" and "f \<in> F"
   using assms unfolding in_Keys ..
 
 lemma Keys_mono:
   assumes "A \<subseteq> B"
   shows "Keys A \<subseteq> Keys B"
   using assms by (auto simp add: Keys_def)
 
 lemma Keys_insert: "Keys (insert a A) = keys a \<union> Keys A"
   by (simp add: Keys_def)
 
 lemma Keys_Un: "Keys (A \<union> B) = Keys A \<union> Keys B"
   by (simp add: Keys_def)
 
 lemma finite_Keys:
   assumes "finite A"
   shows "finite (Keys A)"
   unfolding Keys_def by (rule, fact assms, rule finite_keys)
 
 lemma Keys_not_empty:
   assumes "a \<in> A" and "a \<noteq> 0"
   shows "Keys A \<noteq> {}"
 proof
   assume "Keys A = {}"
   from \<open>a \<noteq> 0\<close> have "keys a \<noteq> {}" using aux by fastforce
   then obtain s where "s \<in> keys a" by blast
   from this assms(1) have "s \<in> Keys A" by (rule in_KeysI)
   with \<open>Keys A = {}\<close> show False by simp
 qed
 
 lemma Keys_empty [simp]: "Keys {} = {}"
   by (simp add: Keys_def)
 
 lemma Keys_zero [simp]: "Keys {0} = {}"
   by (simp add: Keys_def)
 
 lemma keys_subset_Keys:
   assumes "f \<in> F"
   shows "keys f \<subseteq> Keys F"
   using in_KeysI[OF _ assms] by auto
 
 lemma Keys_minus: "Keys (A - B) \<subseteq> Keys A"
   by (auto simp add: Keys_def)
 
 lemma Keys_minus_zero: "Keys (A - {0}) = Keys A"
 proof (cases "0 \<in> A")
   case True
   hence "(A - {0}) \<union> {0} = A" by auto
   hence "Keys A = Keys ((A - {0}) \<union> {0})" by simp
   also have "... = Keys (A - {0}) \<union> Keys {0::('a \<Rightarrow>\<^sub>0 'b)}" by (fact Keys_Un)
   also have "... = Keys (A - {0})" by simp
   finally show ?thesis by simp
 next
   case False
   hence "A - {0} = A" by simp
   thus ?thesis by simp
 qed
 
 subsection \<open>Constant @{term except}\<close>
 
 definition except_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'b::zero)"
   where "except_fun f S = (\<lambda>x. (f x when x \<notin> S))"
 
 lift_definition except :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::zero)" is except_fun
 proof -
   fix p::"'a \<Rightarrow> 'b" and S::"'a set"
   assume "finite {t. p t \<noteq> 0}"
   show "finite {t. except_fun p S t \<noteq> 0}"
   proof (rule finite_subset[of _ "{t. p t \<noteq> 0}"], rule)
     fix u
     assume "u \<in> {t. except_fun p S t \<noteq> 0}"
     hence "p u \<noteq> 0" by (simp add: except_fun_def)
     thus "u \<in> {t. p t \<noteq> 0}" by simp
   qed fact
 qed
 
 lemma lookup_except_when: "lookup (except p S) = (\<lambda>t. lookup p t when t \<notin> S)"
   by (auto simp: except.rep_eq except_fun_def)
 
 lemma lookup_except: "lookup (except p S) = (\<lambda>t. if t \<in> S then 0 else lookup p t)"
   by (rule ext) (simp add: lookup_except_when)
 
 lemma lookup_except_singleton: "lookup (except p {t}) t = 0"
   by (simp add: lookup_except)
 
 lemma except_zero [simp]: "except 0 S = 0"
   by (rule poly_mapping_eqI) (simp add: lookup_except)
 
 lemma lookup_except_eq_idI:
   assumes "t \<notin> S"
   shows "lookup (except p S) t = lookup p t"
   using assms by (simp add: lookup_except)
 
 lemma lookup_except_eq_zeroI:
   assumes "t \<in> S"
   shows "lookup (except p S) t = 0"
   using assms by (simp add: lookup_except)
 
 lemma except_empty [simp]: "except p {} = p"
   by (rule poly_mapping_eqI) (simp add: lookup_except)
 
 lemma except_eq_zeroI:
   assumes "keys p \<subseteq> S"
   shows "except p S = 0"
 proof (rule poly_mapping_eqI, simp)
   fix t
   show "lookup (except p S) t = 0"
   proof (cases "t \<in> S")
     case True
     thus ?thesis by (rule lookup_except_eq_zeroI)
   next
     case False then show ?thesis
       by (metis assms in_keys_iff lookup_except_eq_idI subset_eq) 
   qed
 qed
 
 lemma except_eq_zeroE:
   assumes "except p S = 0"
   shows "keys p \<subseteq> S"
   by (metis assms aux in_keys_iff lookup_except_eq_idI subset_iff)
 
 lemma except_eq_zero_iff: "except p S = 0 \<longleftrightarrow> keys p \<subseteq> S"
   by (rule, elim except_eq_zeroE, elim except_eq_zeroI)
 
 lemma except_keys [simp]: "except p (keys p) = 0"
   by (rule except_eq_zeroI, rule subset_refl)
 
 lemma plus_except: "p = Poly_Mapping.single t (lookup p t) + except p {t}"
   by (rule poly_mapping_eqI, simp add: lookup_add lookup_single lookup_except when_def split: if_split)
 
 lemma keys_except: "keys (except p S) = keys p - S"
   by (transfer, auto simp: except_fun_def)
 
 lemma except_single: "except (Poly_Mapping.single u c) S = (Poly_Mapping.single u c when u \<notin> S)"
   by (rule poly_mapping_eqI) (simp add: lookup_except lookup_single when_def)
 
 lemma except_plus: "except (p + q) S = except p S + except q S"
   by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
 
 lemma except_minus: "except (p - q) S = except p S - except q S"
   by (rule poly_mapping_eqI) (simp add: lookup_except lookup_minus)
 
 lemma except_uminus: "except (- p) S = - except p S"
   by (rule poly_mapping_eqI) (simp add: lookup_except)
 
 lemma except_except: "except (except p S) T = except p (S \<union> T)"
   by (rule poly_mapping_eqI) (simp add: lookup_except)
 
 lemma poly_mapping_keys_eqI:
   assumes a1: "keys p = keys q" and a2: "\<And>t. t \<in> keys p \<Longrightarrow> lookup p t = lookup q t"
   shows "p = q"
 proof (rule poly_mapping_eqI)
   fix t
   show "lookup p t = lookup q t"
   proof (cases "t \<in> keys p")
     case True
     thus ?thesis by (rule a2)
   next
     case False
     moreover from this have "t \<notin> keys q" unfolding a1 .
     ultimately have "lookup p t = 0" and "lookup q t = 0" unfolding in_keys_iff by simp_all
     thus ?thesis by simp
   qed
 qed
 
 lemma except_id_iff: "except p S = p \<longleftrightarrow> keys p \<inter> S = {}"
   by (metis Diff_Diff_Int Diff_eq_empty_iff Diff_triv inf_le2 keys_except lookup_except_eq_idI
       lookup_except_eq_zeroI not_in_keys_iff_lookup_eq_zero poly_mapping_keys_eqI)
 
 lemma keys_subset_wf:
   "wfP (\<lambda>p q::('a, 'b::zero) poly_mapping. keys p \<subset> keys q)"
 unfolding wfP_def
 proof (intro wfI_min)
   fix x::"('a, 'b) poly_mapping" and Q
   assume x_in: "x \<in> Q"
   let ?Q0 = "card ` keys ` Q"
   from x_in have "card (keys x) \<in> ?Q0" by simp
   from wfE_min[OF wf this] obtain z0
     where z0_in: "z0 \<in> ?Q0" and z0_min: "\<And>y. (y, z0) \<in> {(x, y). x < y} \<Longrightarrow> y \<notin> ?Q0" by auto
   from z0_in obtain z where z0_def: "z0 = card (keys z)" and "z \<in> Q" by auto
   show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> {(p, q). keys p \<subset> keys q} \<longrightarrow> y \<notin> Q"
   proof (intro bexI[of _ z], rule, rule)
     fix y::"('a, 'b) poly_mapping"
     let ?y0 = "card (keys y)"
     assume "(y, z) \<in> {(p, q). keys p \<subset> keys q}"
     hence "keys y \<subset> keys z" by simp
     hence "?y0 < z0" unfolding z0_def by (simp add: psubset_card_mono) 
     hence "(?y0, z0) \<in> {(x, y). x < y}" by simp
     from z0_min[OF this] show "y \<notin> Q" by auto
   qed (fact)
 qed
 
 lemma poly_mapping_except_induct:
   assumes base: "P 0" and ind: "\<And>p t. p \<noteq> 0 \<Longrightarrow> t \<in> keys p \<Longrightarrow> P (except p {t}) \<Longrightarrow> P p"
   shows "P p"
 proof (induct rule: wfP_induct[OF keys_subset_wf])
   fix p::"('a, 'b) poly_mapping"
   assume "\<forall>q. keys q \<subset> keys p \<longrightarrow> P q"
   hence IH: "\<And>q. keys q \<subset> keys p \<Longrightarrow> P q" by simp
   show "P p"
   proof (cases "p = 0")
     case True
     thus ?thesis using base by simp
   next
     case False
     hence "keys p \<noteq> {}" by simp
     then obtain t where "t \<in> keys p" by blast
     show ?thesis
     proof (rule ind, fact, fact, rule IH, simp only: keys_except, rule, rule Diff_subset, rule)
       assume "keys p - {t} = keys p"
       hence "t \<notin> keys p" by blast
       from this \<open>t \<in> keys p\<close> show False ..
     qed
   qed
 qed
 
 lemma poly_mapping_except_induct':
   assumes "\<And>p. (\<And>t. t \<in> keys p \<Longrightarrow> P (except p {t})) \<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
   show ?case by (rule assms, simp add: \<open>keys p = {}\<close>)
 next
   case step: (Suc n)
   show ?case
   proof (rule assms)
     fix t
     assume "t \<in> keys p"
     show "P (except p {t})"
     proof (rule step(1), simp add: keys_except)
       from step(2) \<open>t \<in> keys p\<close> finite_keys[of p] show "n = card (keys p - {t})" by simp
     qed
   qed
 qed
 
 lemma poly_mapping_plus_induct:
   assumes "P 0" and "\<And>p c t. c \<noteq> 0 \<Longrightarrow> t \<notin> keys p \<Longrightarrow> P p \<Longrightarrow> P (Poly_Mapping.single t c + 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
   with assms(1) show ?case by simp
 next
   case step: (Suc n)
   from step(2) obtain t where t: "t \<in> keys p" by (metis card_eq_SucD insert_iff)
   define c where "c = lookup p t"
   define q where "q = except p {t}"
   have *: "p = Poly_Mapping.single t c + q"
     by (rule poly_mapping_eqI, simp add: lookup_add lookup_single Poly_Mapping.when_def, intro conjI impI,
         simp add: q_def lookup_except c_def, simp add: q_def lookup_except_eq_idI)
   show ?case
   proof (simp only: *, rule assms(2))
     from t show "c \<noteq> 0"
       using c_def by auto
   next
     show "t \<notin> keys q" by (simp add: q_def keys_except)
   next
     show "P q"
     proof (rule step(1))
       from step(2) \<open>t \<in> keys p\<close> show "n = card (keys q)" unfolding q_def keys_except
         by (metis Suc_inject card.remove finite_keys)
     qed
   qed
 qed
 
 lemma except_Diff_singleton: "except p (keys p - {t}) = Poly_Mapping.single t (lookup p t)"
   by (rule poly_mapping_eqI) (simp add: lookup_single in_keys_iff lookup_except when_def)
 
 lemma except_Un_plus_Int: "except p (U \<union> V) + except p (U \<inter> V) = except p U + except p V"
   by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
 
 corollary except_Int:
   assumes "keys p \<subseteq> U \<union> V"
   shows "except p (U \<inter> V) = except p U + except p V"
 proof -
   from assms have "except p (U \<union> V) = 0" by (rule except_eq_zeroI)
   hence "except p (U \<inter> V) = except p (U \<union> V) + except p (U \<inter> V)" by simp
   also have "\<dots> = except p U + except p V" by (fact except_Un_plus_Int)
   finally show ?thesis .
 qed
 
 lemma except_keys_Int [simp]: "except p (keys p \<inter> U) = except p U"
   by (rule poly_mapping_eqI) (simp add: in_keys_iff lookup_except)
 
 lemma except_Int_keys [simp]: "except p (U \<inter> keys p) = except p U"
   by (simp only: Int_commute[of U] except_keys_Int)
 
 lemma except_keys_Diff: "except p (keys p - U) = except p (- U)"
 proof -
   have "except p (keys p - U) = except p (keys p \<inter> (- U))" by (simp only: Diff_eq)
   also have "\<dots> = except p (- U)" by simp
   finally show ?thesis .
 qed
 
 lemma except_decomp: "p = except p U + except p (- U)"
   by (rule poly_mapping_eqI) (simp add: lookup_except lookup_add)
 
 corollary except_Compl: "except p (- U) = p - except p U"
   by (metis add_diff_cancel_left' except_decomp)
 
 subsection \<open>'Divisibility' on Additive Structures\<close>
 
 context plus begin
 
 definition adds :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "adds" 50)
   where "b adds a \<longleftrightarrow> (\<exists>k. a = b + k)"
 
 lemma addsI [intro?]: "a = b + k \<Longrightarrow> b adds a"
   unfolding adds_def ..
 
 lemma addsE [elim?]: "b adds a \<Longrightarrow> (\<And>k. a = b + k \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding adds_def by blast
 
 end
 
 context comm_monoid_add
 begin
 
 lemma adds_refl [simp]: "a adds a"
 proof
   show "a = a + 0" by simp
 qed
 
 lemma adds_trans [trans]:
   assumes "a adds b" and "b adds c"
   shows "a adds c"
 proof -
   from assms obtain v where "b = a + v"
     by (auto elim!: addsE)
   moreover from assms obtain w where "c = b + w"
     by (auto elim!: addsE)
   ultimately have "c = a + (v + w)"
     by (simp add: add.assoc)
   then show ?thesis ..
 qed
 
 lemma subset_divisors_adds: "{c. c adds a} \<subseteq> {c. c adds b} \<longleftrightarrow> a adds b"
   by (auto simp add: subset_iff intro: adds_trans)
 
 lemma strict_subset_divisors_adds: "{c. c adds a} \<subset> {c. c adds b} \<longleftrightarrow> a adds b \<and> \<not> b adds a"
   by (auto simp add: subset_iff intro: adds_trans)
 
 lemma zero_adds [simp]: "0 adds a"
   by (auto intro!: addsI)
 
 lemma adds_plus_right [simp]: "a adds c \<Longrightarrow> a adds (b + c)"
   by (auto intro!: add.left_commute addsI elim!: addsE)
 
 lemma adds_plus_left [simp]: "a adds b \<Longrightarrow> a adds (b + c)"
   using adds_plus_right [of a b c] by (simp add: ac_simps)
 
 lemma adds_triv_right [simp]: "a adds b + a"
   by (rule adds_plus_right) (rule adds_refl)
 
 lemma adds_triv_left [simp]: "a adds a + b"
   by (rule adds_plus_left) (rule adds_refl)
 
 lemma plus_adds_mono:
   assumes "a adds b"
     and "c adds d"
   shows "a + c adds b + d"
 proof -
   from \<open>a adds b\<close> obtain b' where "b = a + b'" ..
   moreover from \<open>c adds d\<close> obtain d' where "d = c + d'" ..
   ultimately have "b + d = (a + c) + (b' + d')"
     by (simp add: ac_simps)
   then show ?thesis ..
 qed
 
 lemma plus_adds_left: "a + b adds c \<Longrightarrow> a adds c"
   by (simp add: adds_def add.assoc) blast
 
 lemma plus_adds_right: "a + b adds c \<Longrightarrow> b adds c"
   using plus_adds_left [of b a c] by (simp add: ac_simps)
 
 end
 
 class ninv_comm_monoid_add = comm_monoid_add +
   assumes plus_eq_zero: "s + t = 0 \<Longrightarrow> s = 0"
 begin
 
 lemma plus_eq_zero_2: "t = 0" if "s + t = 0"
   using that
   by (simp only: add_commute[of s t] plus_eq_zero)
 
 lemma adds_zero: "s adds 0 \<longleftrightarrow> (s = 0)"
 proof
   assume "s adds 0"
   from this obtain k where "0 = s + k" unfolding adds_def ..
   from this plus_eq_zero[of s k] show "s = 0"
     by blast
 next
   assume "s = 0"
   thus "s adds 0" by simp
 qed
 
 end
 
 context canonically_ordered_monoid_add
 begin
 subclass ninv_comm_monoid_add by (standard, simp)
 end
 
 class comm_powerprod = cancel_comm_monoid_add
 begin
 
 lemma adds_canc: "s + u adds t + u \<longleftrightarrow> s adds t" for s t u::'a
   unfolding adds_def
   apply auto
    apply (metis local.add.left_commute local.add_diff_cancel_left' local.add_diff_cancel_right')
   using add_assoc add_commute by auto
 
 lemma adds_canc_2: "u + s adds u + t \<longleftrightarrow> s adds t"
   by (simp add: adds_canc ac_simps)
 
 lemma add_minus_2: "(s + t) - s = t"
   by simp
 
 lemma adds_minus:
   assumes "s adds t"
   shows "(t - s) + s = t"
 proof -
   from assms adds_def[of s t] obtain u where u: "t = u + s" by (auto simp: ac_simps)
   then have "t - s = u"
     by simp
   thus ?thesis using u by simp
 qed
 
 lemma plus_adds_0:
   assumes "(s + t) adds u"
   shows "s adds (u - t)"
 proof -
   from assms have "(s + t) adds ((u - t) + t)" using adds_minus local.plus_adds_right by presburger
   thus ?thesis using adds_canc[of s t "u - t"] by simp
 qed
 
 lemma plus_adds_2:
   assumes "t adds u" and "s adds (u - t)"
   shows "(s + t) adds u"
   by (metis adds_canc adds_minus assms)
 
 lemma plus_adds:
   shows "(s + t) adds u \<longleftrightarrow> (t adds u \<and> s adds (u - t))"
 proof
   assume a1: "(s + t) adds u"
   show "t adds u \<and> s adds (u - t)"
   proof
     from plus_adds_right[OF a1] show "t adds u" .
   next
     from plus_adds_0[OF a1] show "s adds (u - t)" .
   qed
 next
   assume "t adds u \<and> s adds (u - t)"
   hence "t adds u" and "s adds (u - t)" by auto
   from plus_adds_2[OF \<open>t adds u\<close> \<open>s adds (u - t)\<close>] show "(s + t) adds u" .
 qed
 
 lemma minus_plus:
   assumes "s adds t"
   shows "(t - s) + u = (t + u) - s"
 proof -
   from assms obtain k where k: "t = s + k" unfolding adds_def ..
   hence "t - s = k" by simp
   also from k have "(t + u) - s = k + u"
     by (simp add: add_assoc)
   finally show ?thesis by simp
 qed
 
 lemma minus_plus_minus:
   assumes "s adds t" and "u adds v"
   shows "(t - s) + (v - u) = (t + v) - (s + u)"
   using add_commute assms(1) assms(2) diff_diff_add minus_plus by auto
 
 lemma minus_plus_minus_cancel:
   assumes "u adds t" and "s adds u"
   shows "(t - u) + (u - s) = t - s"
   by (metis assms(1) assms(2) local.add_diff_cancel_left' local.add_diff_cancel_right local.addsE minus_plus)
 
 end
 
 text \<open>Instances of class \<open>lcs_powerprod\<close> are types of commutative power-products admitting
   (not necessarily unique) least common sums (inspired from least common multiplies).
   Note that if the components of indeterminates are arbitrary integers (as for instance in Laurent
   polynomials), then no unique lcss exist.\<close>
 class lcs_powerprod = comm_powerprod +
   fixes lcs::"'a \<Rightarrow> 'a \<Rightarrow> 'a"
   assumes adds_lcs: "s adds (lcs s t)"
   assumes lcs_adds: "s adds u \<Longrightarrow> t adds u \<Longrightarrow> (lcs s t) adds u"
   assumes lcs_comm: "lcs s t = lcs t s"
 begin
 
 lemma adds_lcs_2: "t adds (lcs s t)"
   by (simp only: lcs_comm[of s t], rule adds_lcs)
 
 lemma lcs_adds_plus: "lcs s t adds s + t" by (simp add: lcs_adds)
 
 text \<open>"gcs" stands for "greatest common summand".\<close>
 definition gcs :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where "gcs s t = (s + t) - (lcs s t)"
 
 lemma gcs_plus_lcs: "(gcs s t) + (lcs s t) = s + t"
   unfolding gcs_def by (rule adds_minus, fact lcs_adds_plus)
 
 lemma gcs_adds: "(gcs s t) adds s"
 proof -
   have "t adds (lcs s t)" (is "t adds ?l") unfolding lcs_comm[of s t] by (fact adds_lcs)
   then obtain u where eq1: "?l = t + u" unfolding adds_def ..
   from lcs_adds_plus[of s t] obtain v where eq2: "s + t = ?l + v" unfolding adds_def ..
   hence "t + s = t + (u + v)" unfolding eq1 by (simp add: ac_simps)
   hence s: "s = u + v" unfolding add_left_cancel .
   show ?thesis unfolding eq2 gcs_def unfolding s by simp
 qed
 
 lemma gcs_comm: "gcs s t = gcs t s" unfolding gcs_def by (simp add: lcs_comm ac_simps)
 
 lemma gcs_adds_2: "(gcs s t) adds t"
   by (simp only: gcs_comm[of s t], rule gcs_adds)
 
 end
 
 class ulcs_powerprod = lcs_powerprod + ninv_comm_monoid_add
 begin
 
 lemma adds_antisym:
   assumes "s adds t" "t adds s"
   shows "s = t"
 proof -
   from \<open>s adds t\<close> obtain u where u_def: "t = s + u" unfolding adds_def ..
   from \<open>t adds s\<close> obtain v where v_def: "s = t + v" unfolding adds_def ..
   from u_def v_def have "s = (s + u) + v" by (simp add: ac_simps)
   hence "s + 0 = s + (u + v)" by (simp add: ac_simps)
   hence "u + v = 0" by simp
   hence "u = 0" using plus_eq_zero[of u v] by simp
   thus ?thesis using u_def by simp
 qed
 
 lemma lcs_unique:
   assumes "s adds l" and "t adds l" and *: "\<And>u. s adds u \<Longrightarrow> t adds u \<Longrightarrow> l adds u"
   shows "l = lcs s t"
   by (rule adds_antisym, rule *, fact adds_lcs, fact adds_lcs_2, rule lcs_adds, fact+)
 
 lemma lcs_zero: "lcs 0 t = t"
   by (rule lcs_unique[symmetric], fact zero_adds, fact adds_refl)
 
 lemma lcs_plus_left: "lcs (u + s) (u + t) = u + lcs s t" 
 proof (rule lcs_unique[symmetric], simp_all only: adds_canc_2, fact adds_lcs, fact adds_lcs_2,
     simp add: add.commute[of u] plus_adds)
   fix v
   assume "u adds v \<and> s adds v - u"
   hence "s adds v - u" ..
   assume "t adds v - u"
   with \<open>s adds v - u\<close> show "lcs s t adds v - u" by (rule lcs_adds)
 qed
 
 lemma lcs_plus_right: "lcs (s + u) (t + u) = (lcs s t) + u"
   using lcs_plus_left[of u s t] by (simp add: ac_simps)
 
 lemma adds_gcs:
   assumes "u adds s" and "u adds t"
   shows "u adds (gcs s t)"
 proof -
   from assms have "s + u adds s + t" and "t + u adds t + s"
     by (simp_all add: plus_adds_mono)
   hence "lcs (s + u) (t + u) adds s + t"
     by (auto intro: lcs_adds simp add: ac_simps)
   hence "u + (lcs s t) adds s + t" unfolding lcs_plus_right by (simp add: ac_simps)
   hence "u adds (s + t) - (lcs s t)" unfolding plus_adds ..
   thus ?thesis unfolding gcs_def .
 qed
 
 lemma gcs_unique:
   assumes "g adds s" and "g adds t" and *: "\<And>u. u adds s \<Longrightarrow> u adds t \<Longrightarrow> u adds g"
   shows "g = gcs s t"
   by (rule adds_antisym, rule adds_gcs, fact, fact, rule *, fact gcs_adds, fact gcs_adds_2)
 
 lemma gcs_plus_left: "gcs (u + s) (u + t) = u + gcs s t"
 proof -
   have "u + s + (u + t) - (u + lcs s t) = u + s + (u + t) - u - lcs s t" by (simp only: diff_diff_add)
   also have "... = u + s + t + (u - u) - lcs s t" by (simp add: add.left_commute)
   also have "... = u + s + t - lcs s t" by simp
   also have "... =  u + (s + t - lcs s t)"
     using add_assoc add_commute local.lcs_adds_plus local.minus_plus by auto
   finally show ?thesis unfolding gcs_def lcs_plus_left .
 qed
 
 lemma gcs_plus_right: "gcs (s + u) (t + u) = (gcs s t) + u"
   using gcs_plus_left[of u s t] by (simp add: ac_simps)
 
 lemma lcs_same [simp]: "lcs s s = s"
 proof -
   have "lcs s s adds s" by (rule lcs_adds, simp_all)
   moreover have "s adds lcs s s" by (rule adds_lcs)
   ultimately show ?thesis by (rule adds_antisym)
 qed
 
 lemma gcs_same [simp]: "gcs s s = s"
 proof -
   have "gcs s s adds s" by (rule gcs_adds)
   moreover have "s adds gcs s s" by (rule adds_gcs, simp_all)
   ultimately show ?thesis by (rule adds_antisym)
 qed
 
 end
 
 subsection \<open>Dickson Classes\<close>
 
 definition (in plus) dickson_grading :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
   where "dickson_grading d \<longleftrightarrow>
           ((\<forall>s t. d (s + t) = max (d s) (d t)) \<and> (\<forall>n::nat. almost_full_on (adds) {x. d x \<le> n}))"
 
 definition dgrad_set :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a set"
   where "dgrad_set d m = {t. d t \<le> m}"
 
 definition dgrad_set_le :: "('a \<Rightarrow> nat) \<Rightarrow> ('a set) \<Rightarrow> ('a set) \<Rightarrow> bool"
   where "dgrad_set_le d S T \<longleftrightarrow> (\<forall>s\<in>S. \<exists>t\<in>T. d s \<le> d t)"
 
 lemma dickson_gradingI:
   assumes "\<And>s t. d (s + t) = max (d s) (d t)"
   assumes "\<And>n::nat. almost_full_on (adds) {x. d x \<le> n}"
   shows "dickson_grading d"
   unfolding dickson_grading_def using assms by blast
 
 lemma dickson_gradingD1: "dickson_grading d \<Longrightarrow> d (s + t) = max (d s) (d t)"
   by (auto simp add: dickson_grading_def)
 
 lemma dickson_gradingD2: "dickson_grading d \<Longrightarrow> almost_full_on (adds) {x. d x \<le> n}"
   by (auto simp add: dickson_grading_def)
 
 lemma dickson_gradingD2':
   assumes "dickson_grading (d::'a::comm_monoid_add \<Rightarrow> nat)"
   shows "wqo_on (adds) {x. d x \<le> n}"
 proof (intro wqo_onI transp_onI)
   fix x y z :: 'a
   assume "x adds y" and "y adds z"
   thus "x adds z" by (rule adds_trans)
 next
   from assms show "almost_full_on (adds) {x. d x \<le> n}" by (rule dickson_gradingD2)
 qed
 
 lemma dickson_gradingE:
   assumes "dickson_grading d" and "\<And>i::nat. d ((seq::nat \<Rightarrow> 'a::plus) i) \<le> n"
   obtains i j where "i < j" and "seq i adds seq j"
 proof -
   from assms(1) have "almost_full_on (adds) {x. d x \<le> n}" by (rule dickson_gradingD2)
   moreover from assms(2) have "\<And>i. seq i \<in> {x. d x \<le> n}" by simp
   ultimately obtain i j where "i < j" and "seq i adds seq j" by (rule almost_full_onD)
   thus ?thesis ..
 qed
 
 lemma dickson_grading_adds_imp_le:
   assumes "dickson_grading d" and "s adds t"
   shows "d s \<le> d t"
 proof -
   from assms(2) obtain u where "t = s + u" ..
   hence "d t = max (d s) (d u)" by (simp only: dickson_gradingD1[OF assms(1)])
   thus ?thesis by simp
 qed
 
 lemma dickson_grading_minus:
   assumes "dickson_grading d" and "s adds (t::'a::cancel_ab_semigroup_add)"
   shows "d (t - s) \<le> d t"
 proof -
   from assms(2) obtain u where "t = s + u" ..
   hence "t - s = u" by simp
   from assms(1) have "d t = ord_class.max (d s) (d u)" unfolding \<open>t = s + u\<close> by (rule dickson_gradingD1)
   thus ?thesis by (simp add: \<open>t - s = u\<close>)
 qed
 
 lemma dickson_grading_lcs:
   assumes "dickson_grading d"
   shows "d (lcs s t) \<le> max (d s) (d t)"
 proof -
   from assms have "d (lcs s t) \<le> d (s + t)" by (rule dickson_grading_adds_imp_le, intro lcs_adds_plus)
   thus ?thesis by (simp only: dickson_gradingD1[OF assms])
 qed
 
 lemma dickson_grading_lcs_minus:
   assumes "dickson_grading d"
   shows "d (lcs s t - s) \<le> max (d s) (d t)"
 proof -
   from assms have "d (lcs s t - s) \<le> d (lcs s t)" by (rule dickson_grading_minus, intro adds_lcs)
   also from assms have "... \<le> max (d s) (d t)" by (rule dickson_grading_lcs)
   finally show ?thesis .
 qed
 
 lemma dgrad_set_leI:
   assumes "\<And>s. s \<in> S \<Longrightarrow> \<exists>t\<in>T. d s \<le> d t"
   shows "dgrad_set_le d S T"
   using assms by (auto simp: dgrad_set_le_def)
 
 lemma dgrad_set_leE:
   assumes "dgrad_set_le d S T" and "s \<in> S"
   obtains t where "t \<in> T" and "d s \<le> d t"
   using assms by (auto simp: dgrad_set_le_def)
 
 lemma dgrad_set_exhaust_expl:
   assumes "finite F"
   shows "F \<subseteq> dgrad_set d (Max (d ` F))"
 proof
   fix f
   assume "f \<in> F"
   hence "d f \<in> d ` F" by simp
   with _ have "d f \<le> Max (d ` F)"
   proof (rule Max_ge)
     from assms show "finite (d ` F)" by auto
   qed
   hence "dgrad_set d (d f) \<subseteq> dgrad_set d (Max (d ` F))" by (auto simp: dgrad_set_def)
   moreover have "f \<in> dgrad_set d (d f)" by (simp add: dgrad_set_def)
   ultimately show "f \<in> dgrad_set d (Max (d ` F))" ..
 qed
 
 lemma dgrad_set_exhaust:
   assumes "finite F"
   obtains m where "F \<subseteq> dgrad_set d m"
 proof
   from assms show "F \<subseteq> dgrad_set d (Max (d ` F))" by (rule dgrad_set_exhaust_expl)
 qed
 
 lemma dgrad_set_le_trans [trans]:
   assumes "dgrad_set_le d S T" and "dgrad_set_le d T U"
   shows "dgrad_set_le d S U"
   unfolding dgrad_set_le_def
 proof
   fix s
   assume "s \<in> S"
   with assms(1) obtain t where "t \<in> T" and 1: "d s \<le> d t" by (auto simp add: dgrad_set_le_def)
   from assms(2) this(1) obtain u where "u \<in> U" and 2: "d t \<le> d u" by (auto simp add: dgrad_set_le_def)
   from this(1) show "\<exists>u\<in>U. d s \<le> d u"
   proof
     from 1 2 show "d s \<le> d u" by (rule le_trans)
   qed
 qed
 
 lemma dgrad_set_le_Un: "dgrad_set_le d (S \<union> T) U \<longleftrightarrow> (dgrad_set_le d S U \<and> dgrad_set_le d T U)"
   by (auto simp add: dgrad_set_le_def)
 
 lemma dgrad_set_le_subset:
   assumes "S \<subseteq> T"
   shows "dgrad_set_le d S T"
   unfolding dgrad_set_le_def using assms by blast
 
 lemma dgrad_set_le_refl: "dgrad_set_le d S S"
   by (rule dgrad_set_le_subset, fact subset_refl)
 
 lemma dgrad_set_le_dgrad_set:
   assumes "dgrad_set_le d F G" and "G \<subseteq> dgrad_set d m"
   shows "F \<subseteq> dgrad_set d m"
 proof
   fix f
   assume "f \<in> F"
   with assms(1) obtain g where "g \<in> G" and *: "d f \<le> d g" by (auto simp add: dgrad_set_le_def)
   from assms(2) this(1) have "g \<in> dgrad_set d m" ..
   hence "d g \<le> m" by (simp add: dgrad_set_def)
   with * have "d f \<le> m" by (rule le_trans)
   thus "f \<in> dgrad_set d m" by (simp add: dgrad_set_def)
 qed
 
 lemma dgrad_set_dgrad: "p \<in> dgrad_set d (d p)"
   by (simp add: dgrad_set_def)
 
 lemma dgrad_setI [intro]:
   assumes "d t \<le> m"
   shows "t \<in> dgrad_set d m"
   using assms by (auto simp: dgrad_set_def)
 
 lemma dgrad_setD:
   assumes "t \<in> dgrad_set d m"
   shows "d t \<le> m"
   using assms by (simp add: dgrad_set_def)
 
 lemma dgrad_set_zero [simp]: "dgrad_set (\<lambda>_. 0) m = UNIV"
   by auto
 
 lemma subset_dgrad_set_zero: "F \<subseteq> dgrad_set (\<lambda>_. 0) m"
   by simp
 
 lemma dgrad_set_subset:
   assumes "m \<le> n"
   shows "dgrad_set d m \<subseteq> dgrad_set d n"
   using assms by (auto simp: dgrad_set_def)
 
 lemma dgrad_set_closed_plus:
   assumes "dickson_grading d" and "s \<in> dgrad_set d m" and "t \<in> dgrad_set d m"
   shows "s + t \<in> dgrad_set d m"
 proof -
   from assms(1) have "d (s + t) = ord_class.max (d s) (d t)" by (rule dickson_gradingD1)
   also from assms(2, 3) have "... \<le> m" by (simp add: dgrad_set_def)
   finally show ?thesis by (simp add: dgrad_set_def)
 qed
 
 lemma dgrad_set_closed_minus:
   assumes "dickson_grading d" and "s \<in> dgrad_set d m" and "t adds (s::'a::cancel_ab_semigroup_add)"
   shows "s - t \<in> dgrad_set d m"
 proof -
   from assms(1, 3) have "d (s - t) \<le> d s" by (rule dickson_grading_minus)
   also from assms(2) have "... \<le> m" by (simp add: dgrad_set_def)
   finally show ?thesis by (simp add: dgrad_set_def)
 qed
 
 lemma dgrad_set_closed_lcs:
   assumes "dickson_grading d" and "s \<in> dgrad_set d m" and "t \<in> dgrad_set d m"
   shows "lcs s t \<in> dgrad_set d m"
 proof -
   from assms(1) have "d (lcs s t) \<le> ord_class.max (d s) (d t)" by (rule dickson_grading_lcs)
   also from assms(2, 3) have "... \<le> m" by (simp add: dgrad_set_def)
   finally show ?thesis by (simp add: dgrad_set_def)
 qed
 
 lemma dickson_gradingD_dgrad_set: "dickson_grading d \<Longrightarrow> almost_full_on (adds) (dgrad_set d m)"
   by (auto dest: dickson_gradingD2 simp: dgrad_set_def)
 
 lemma ex_finite_adds:
   assumes "dickson_grading d" and "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 (s::'a::cancel_comm_monoid_add))"
 proof -
   have "reflp ((adds)::'a \<Rightarrow> _)" by (simp add: reflp_def)
   moreover from assms(2) have "almost_full_on (adds) S"
   proof (rule almost_full_on_subset)
     from assms(1) show "almost_full_on (adds) (dgrad_set d m)" by (rule dickson_gradingD_dgrad_set)
   qed
   ultimately obtain T where "finite T" and "T \<subseteq> S" and "\<And>s. s \<in> S \<Longrightarrow> (\<exists>t\<in>T. t adds s)"
     by (rule almost_full_on_finite_subsetE, blast)
   thus ?thesis ..
 qed
 
 class graded_dickson_powerprod = ulcs_powerprod +
   assumes ex_dgrad: "\<exists>d::'a \<Rightarrow> nat. dickson_grading d"
 begin
 
 definition dgrad_dummy where "dgrad_dummy = (SOME d. dickson_grading d)"
 
 lemma dickson_grading_dgrad_dummy: "dickson_grading dgrad_dummy"
   unfolding dgrad_dummy_def using ex_dgrad by (rule someI_ex)
 
 end (* graded_dickson_powerprod *)
 
 class dickson_powerprod = ulcs_powerprod +
   assumes dickson: "almost_full_on (adds) UNIV"
 begin
 
 lemma dickson_grading_zero: "dickson_grading (\<lambda>_::'a. 0)"
   by (simp add: dickson_grading_def dickson)
 
 subclass graded_dickson_powerprod by (standard, rule, fact dickson_grading_zero)
 
 end (* dickson_powerprod *)
 
 text \<open>Class @{class graded_dickson_powerprod} is a slightly artificial construction. It is needed,
   because type @{typ "nat \<Rightarrow>\<^sub>0 nat"} does not satisfy the usual conditions of a "Dickson domain" (as
   formulated in class @{class dickson_powerprod}), but we still want to use that type as the type of
   power-products in the computation of Gr\"obner bases. So, we exploit the fact that in a finite
   set of polynomials (which is the input of Buchberger's algorithm) there is always some "highest"
   indeterminate that occurs with non-zero exponent, and no "higher" indeterminates are generated
   during the execution of the algorithm. This allows us to prove that the algorithm terminates, even
   though there are in principle infinitely many indeterminates.\<close>
 
 subsection \<open>Additive Linear Orderings\<close>
   
 lemma group_eq_aux: "a + (b - a) = (b::'a::ab_group_add)"
 proof -
   have "a + (b - a) = b - a + a" by simp
   also have "... = b" by simp
   finally show ?thesis .
 qed
 
 class semi_canonically_ordered_monoid_add = ordered_comm_monoid_add +
   assumes le_imp_add: "a \<le> b \<Longrightarrow> (\<exists>c. b = a + c)"
 
 context canonically_ordered_monoid_add
 begin
 subclass semi_canonically_ordered_monoid_add
   by (standard, simp only: le_iff_add)
 end
 
 class add_linorder_group = ordered_ab_semigroup_add_imp_le + ab_group_add + linorder
 
 class add_linorder = ordered_ab_semigroup_add_imp_le + cancel_comm_monoid_add + semi_canonically_ordered_monoid_add + linorder
 begin
 
 subclass ordered_comm_monoid_add ..
 
 subclass ordered_cancel_comm_monoid_add ..
 
 lemma le_imp_inv:
   assumes "a \<le> b"
   shows "b = a + (b - a)"
   using le_imp_add[OF assms] by auto
 
 lemma max_eq_sum:
   obtains y where "max a b = a + y"
   unfolding max_def
 proof (cases "a \<le> b")
   case True
   hence "b = a + (b - a)" by (rule le_imp_inv)
   then obtain c where eq: "b = a + c" ..
   show ?thesis
   proof
     from True show "max a b = a + c" unfolding max_def eq by simp
   qed
 next
   case False
   show ?thesis
   proof
     from False show "max a b = a + 0" unfolding max_def by simp
   qed
 qed
   
 lemma min_plus_max:
   shows "(min a b) + (max a b) = a + b"
 proof (cases "a \<le> b")
   case True
   thus ?thesis unfolding min_def max_def by simp
 next
   case False
   thus ?thesis unfolding min_def max_def by (simp add: ac_simps)
 qed
 
 end (* add_linorder *)
 
 class add_linorder_min = add_linorder +
   assumes zero_min: "0 \<le> x"
 begin
 
 subclass ninv_comm_monoid_add
 proof
   fix x y
   assume *: "x + y = 0"
   show "x = 0"
   proof -
     from zero_min[of x] have "0 = x \<or> x > 0" by auto
     thus ?thesis
     proof
       assume "x > 0"
       have "0 \<le> y" by (fact zero_min)
       also have "... = 0 + y" by simp
       also from \<open>x > 0\<close> have "... < x + y" by (rule add_strict_right_mono)
       finally have "0 < x + y" .
       hence "x + y \<noteq> 0" by simp
       from this * show ?thesis ..
     qed simp
   qed
 qed
   
 lemma leq_add_right:
   shows "x \<le> x + y"
   using add_left_mono[OF zero_min[of y], of x] by simp
 
 lemma leq_add_left:
   shows "x \<le> y + x"
   using add_right_mono[OF zero_min[of y], of x] by simp
 
 subclass canonically_ordered_monoid_add
   by (standard, rule, elim le_imp_add, elim exE, simp add: leq_add_right)
 
 end (* add_linorder_min *)
   
 class add_wellorder = add_linorder_min + wellorder
   
 instantiation nat :: add_linorder
 begin
 
 instance by (standard, simp)
 
 end (* add_linorder *)
   
 instantiation nat :: add_linorder_min
 begin
 instance by (standard, simp)
 end
   
 instantiation nat :: add_wellorder
 begin
 instance ..
 end
   
 context add_linorder_group
 begin
   
 subclass add_linorder
 proof (standard, intro exI)
   fix a b
   show "b = a + (b - a)" using add_commute local.diff_add_cancel by auto
 qed
 
 end (* add_linorder_group *)
   
 instantiation int :: add_linorder_group
 begin
 instance ..
 end
 
 instantiation rat :: add_linorder_group
 begin
 instance ..
 end
 
 instantiation real :: add_linorder_group
 begin
 instance ..
 end
 
 subsection \<open>Ordered Power-Products\<close>
 
 locale ordered_powerprod =
   ordered_powerprod_lin: linorder ord ord_strict
   for ord::"'a \<Rightarrow> 'a::comm_powerprod \<Rightarrow> bool" (infixl "\<preceq>" 50)
   and ord_strict::"'a \<Rightarrow> 'a::comm_powerprod \<Rightarrow> bool" (infixl "\<prec>" 50) +
   assumes zero_min: "0 \<preceq> t"
   assumes plus_monotone: "s \<preceq> t \<Longrightarrow> s + u \<preceq> t + u"
 begin
 
 abbreviation ord_conv (infixl "\<succeq>" 50) where "ord_conv \<equiv> (\<preceq>)\<inverse>\<inverse>"
 abbreviation ord_strict_conv (infixl "\<succ>" 50) where "ord_strict_conv \<equiv> (\<prec>)\<inverse>\<inverse>"
 
 lemma ord_canc:
   assumes "s + u \<preceq> t + u"
   shows "s \<preceq> t"
 proof (rule ordered_powerprod_lin.le_cases[of s t], simp)
   assume "t \<preceq> s"
   from assms plus_monotone[OF this, of u] have "t + u = s + u"
     using ordered_powerprod_lin.order.eq_iff by simp
   hence "t = s" by simp
   thus "s \<preceq> t" by simp
 qed
 
 lemma ord_adds:
   assumes "s adds t"
   shows "s \<preceq> t"
 proof -
   from assms have "\<exists>u. t = s + u" unfolding adds_def by simp
   then obtain k where "t = s + k" ..
   thus ?thesis using plus_monotone[OF zero_min[of k], of s] by (simp add: ac_simps)
 qed
 
 lemma ord_canc_left:
   assumes "u + s \<preceq> u + t"
   shows "s \<preceq> t"
   using assms unfolding add.commute[of u] by (rule ord_canc)
 
 lemma ord_strict_canc:
   assumes "s + u \<prec> t + u"
   shows "s \<prec> t"
   using assms ord_canc[of s u t] add_right_cancel[of s u t]
     ordered_powerprod_lin.le_imp_less_or_eq ordered_powerprod_lin.order.strict_implies_order by blast
 
 lemma ord_strict_canc_left:
   assumes "u + s \<prec> u + t"
   shows "s \<prec> t"
   using assms unfolding add.commute[of u] by (rule ord_strict_canc)
 
 lemma plus_monotone_left:
   assumes "s \<preceq> t"
   shows "u + s \<preceq> u + t"
   using assms
   by (simp add: add.commute, rule plus_monotone)
 
 lemma plus_monotone_strict:
   assumes "s \<prec> t"
   shows "s + u \<prec> t + u"
   using assms
   by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone)
 
 lemma plus_monotone_strict_left:
   assumes "s \<prec> t"
   shows "u + s \<prec> u + t"
   using assms
   by (simp add: ordered_powerprod_lin.order.strict_iff_order plus_monotone_left)
 
 end
 
 locale gd_powerprod =
   ordered_powerprod ord ord_strict
   for ord::"'a \<Rightarrow> 'a::graded_dickson_powerprod \<Rightarrow> bool" (infixl "\<preceq>" 50)
   and ord_strict (infixl "\<prec>" 50)
 begin
 
 definition dickson_le :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "dickson_le d m s t \<longleftrightarrow> (d s \<le> m \<and> d t \<le> m \<and> s \<preceq> t)"
 
 definition dickson_less :: "('a \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "dickson_less d m s t \<longleftrightarrow> (d s \<le> m \<and> d t \<le> m \<and> s \<prec> t)"
 
 lemma dickson_leI:
   assumes "d s \<le> m" and "d t \<le> m" and "s \<preceq> t"
   shows "dickson_le d m s t"
   using assms by (simp add: dickson_le_def)
 
 lemma dickson_leD1:
   assumes "dickson_le d m s t"
   shows "d s \<le> m"
   using assms by (simp add: dickson_le_def)
 
 lemma dickson_leD2:
   assumes "dickson_le d m s t"
   shows "d t \<le> m"
   using assms by (simp add: dickson_le_def)
 
 lemma dickson_leD3:
   assumes "dickson_le d m s t"
   shows "s \<preceq> t"
   using assms by (simp add: dickson_le_def)
 
 lemma dickson_le_trans:
   assumes "dickson_le d m s t" and "dickson_le d m t u"
   shows "dickson_le d m s u"
   using assms by (auto simp add: dickson_le_def)
 
 lemma dickson_lessI:
   assumes "d s \<le> m" and "d t \<le> m" and "s \<prec> t"
   shows "dickson_less d m s t"
   using assms by (simp add: dickson_less_def)
 
 lemma dickson_lessD1:
   assumes "dickson_less d m s t"
   shows "d s \<le> m"
   using assms by (simp add: dickson_less_def)
 
 lemma dickson_lessD2:
   assumes "dickson_less d m s t"
   shows "d t \<le> m"
   using assms by (simp add: dickson_less_def)
 
 lemma dickson_lessD3:
   assumes "dickson_less d m s t"
   shows "s \<prec> t"
   using assms by (simp add: dickson_less_def)
 
 lemma dickson_less_irrefl: "\<not> dickson_less d m t t"
   by (simp add: dickson_less_def)
 
 lemma dickson_less_trans:
   assumes "dickson_less d m s t" and "dickson_less d m t u"
   shows "dickson_less d m s u"
   using assms by (auto simp add: dickson_less_def)
 
 lemma transp_dickson_less: "transp (dickson_less d m)"
   by (rule transpI, fact dickson_less_trans)
 
 lemma wfp_on_ord_strict:
   assumes "dickson_grading d"
   shows "wfp_on (\<prec>) {x. d x \<le> n}"
 proof -
   let ?A = "{x. d x \<le> n}"
   have "strict (\<preceq>) = (\<prec>)" by (intro ext, simp only: ordered_powerprod_lin.less_le_not_le)
   have "qo_on (adds) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def dest: adds_trans)
   moreover from assms have "wqo_on (adds) ?A" by (rule dickson_gradingD2')
   ultimately have "(\<forall>Q. (\<forall>x\<in>?A. \<forall>y\<in>?A. x adds y \<longrightarrow> Q x y) \<and> qo_on Q ?A \<longrightarrow> wfp_on (strict Q) ?A)"
     by (simp only: wqo_extensions_wf_conv)
   hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x adds y \<longrightarrow> x \<preceq> y) \<and> qo_on (\<preceq>) ?A \<longrightarrow> wfp_on (strict (\<preceq>)) ?A" ..
   thus ?thesis unfolding \<open>strict (\<preceq>) = (\<prec>)\<close>
   proof
     show "(\<forall>x\<in>?A. \<forall>y\<in>?A. x adds y \<longrightarrow> x \<preceq> y) \<and> qo_on (\<preceq>) ?A"
     proof (intro conjI ballI impI ord_adds)
       show "qo_on (\<preceq>) ?A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
     qed
   qed
 qed
 
 lemma wf_dickson_less:
   assumes "dickson_grading d"
   shows "wfP (dickson_less d m)"
 proof (rule wfP_chain)
   show "\<not> (\<exists>seq. \<forall>i. dickson_less d m (seq (Suc i)) (seq i))"
   proof
     assume "\<exists>seq. \<forall>i. dickson_less d m (seq (Suc i)) (seq i)"
     then obtain seq::"nat \<Rightarrow> 'a" where "\<forall>i. dickson_less d m (seq (Suc i)) (seq i)" ..
     hence *: "\<And>i. dickson_less d m (seq (Suc i)) (seq i)" ..
     with transp_dickson_less have seq_decr: "\<And>i j. i < j \<Longrightarrow> dickson_less d m (seq j) (seq i)"
       by (rule transp_sequence)
 
     from assms obtain i j where "i < j" and i_adds_j: "seq i adds seq j"
     proof (rule dickson_gradingE)
       fix i
       from * show "d (seq i) \<le> m" by (rule dickson_lessD2)
     qed
     from \<open>i < j\<close> have "dickson_less d m (seq j) (seq i)" by (rule seq_decr)
     hence "seq j \<prec> seq i" by (rule dickson_lessD3)
     moreover from i_adds_j have "seq i \<preceq> seq j" by (rule ord_adds)
     ultimately show False by simp
   qed
 qed
 
 end
 
 text \<open>\<open>gd_powerprod\<close> stands for @{emph \<open>graded ordered Dickson power-products\<close>}.\<close>
 
 locale od_powerprod =
   ordered_powerprod ord ord_strict
   for ord::"'a \<Rightarrow> 'a::dickson_powerprod \<Rightarrow> bool" (infixl "\<preceq>" 50)
   and ord_strict (infixl "\<prec>" 50)
 begin
 
 sublocale gd_powerprod by standard
 
 lemma wf_ord_strict: "wfP (\<prec>)"
 proof (rule wfP_chain)
   show "\<not> (\<exists>seq. \<forall>i. seq (Suc i) \<prec> seq i)"
   proof
     assume "\<exists>seq. \<forall>i. seq (Suc i) \<prec> seq i"
     then obtain seq::"nat \<Rightarrow> 'a" where "\<forall>i. seq (Suc i) \<prec> seq i" ..
     hence "\<And>i. seq (Suc i) \<prec> seq i" ..
-    with ordered_powerprod_lin.transp_less have seq_decr: "\<And>i j. i < j \<Longrightarrow> (seq j) \<prec> (seq i)"
+    with ordered_powerprod_lin.transp_on_less have seq_decr: "\<And>i j. i < j \<Longrightarrow> (seq j) \<prec> (seq i)"
       by (rule transp_sequence)
 
     from dickson obtain i j::nat where "i < j" and i_adds_j: "seq i adds seq j"
       by (auto elim!: almost_full_onD)
     from seq_decr[OF \<open>i < j\<close>] have "seq j \<preceq> seq i \<and> seq j \<noteq> seq i" by auto
     hence "seq j \<preceq> seq i" and "seq j \<noteq> seq i" by simp_all
     from \<open>seq j \<noteq> seq i\<close> \<open>seq j \<preceq> seq i\<close> ord_adds[OF i_adds_j]
          ordered_powerprod_lin.order.eq_iff[of "seq j" "seq i"]
       show False by simp
   qed
 qed
 
 end
 
 text \<open>\<open>od_powerprod\<close> stands for @{emph \<open>ordered Dickson power-products\<close>}.\<close>
 
 subsection \<open>Functions as Power-Products\<close>
 
 lemma finite_neq_0:
   assumes fin_A: "finite {x. f x \<noteq> 0}" and fin_B: "finite {x. g x \<noteq> 0}" and "\<And>x. h x 0 0 = 0"
   shows "finite {x. h x (f x) (g x) \<noteq> 0}"
 proof -
   from fin_A fin_B have  "finite ({x. f x \<noteq> 0} \<union> {x. g x \<noteq> 0})" by (intro finite_UnI)
   hence finite_union: "finite {x. (f x \<noteq> 0) \<or> (g x \<noteq> 0)}" by (simp only: Collect_disj_eq)
   have "{x. h x (f x) (g x) \<noteq> 0} \<subseteq> {x. (f x \<noteq> 0) \<or> (g x \<noteq> 0)}"
   proof (intro Collect_mono, rule)
     fix x::'a
     assume h_not_zero: "h x (f x) (g x) \<noteq> 0"
     have "f x = 0 \<Longrightarrow> g x \<noteq> 0"
     proof
       assume "f x = 0" "g x = 0"
       thus False using h_not_zero \<open>h x 0 0 = 0\<close>  by simp
     qed
     thus "f x \<noteq> 0 \<or> g x \<noteq> 0" by auto
   qed
   from finite_subset[OF this] finite_union show "finite {x. h x (f x) (g x) \<noteq> 0}" .
 qed
 
 lemma finite_neq_0':
   assumes "finite {x. f x \<noteq> 0}" and "finite {x. g x \<noteq> 0}" and "h 0 0 = 0"
   shows "finite {x. h (f x) (g x) \<noteq> 0}"
   using assms by (rule finite_neq_0)
 
 lemma finite_neq_0_inv:
   assumes fin_A: "finite {x. h x (f x) (g x) \<noteq> 0}" and fin_B: "finite {x. f x \<noteq> 0}" and "\<And>x y. h x 0 y = y"
   shows "finite {x. g x \<noteq> 0}"
 proof -
   from fin_A and fin_B have "finite ({x. h x (f x) (g x) \<noteq> 0} \<union> {x. f x \<noteq> 0})" by (intro finite_UnI)
   hence finite_union: "finite {x. (h x (f x) (g x) \<noteq> 0) \<or> f x \<noteq> 0}" by (simp only: Collect_disj_eq)
   have "{x. g x \<noteq> 0} \<subseteq> {x. (h x (f x) (g x) \<noteq> 0) \<or> f x \<noteq> 0}"
     by (intro Collect_mono, rule, rule disjCI, simp add: assms(3))
   from this finite_union show "finite {x. g x \<noteq> 0}" by (rule finite_subset)
 qed
 
 lemma finite_neq_0_inv':
   assumes inf_A: "finite {x. h (f x) (g x) \<noteq> 0}" and fin_B: "finite {x. f x \<noteq> 0}" and "\<And>x. h 0 x = x"
   shows "finite {x. g x \<noteq> 0}"
   using assms by (rule finite_neq_0_inv)
 
 subsubsection \<open>@{typ "'a \<Rightarrow> 'b"} belongs to class @{class comm_powerprod}\<close>
 
 instance "fun" :: (type, cancel_comm_monoid_add) comm_powerprod
   by standard
 
 subsubsection \<open>@{typ "'a \<Rightarrow> 'b"} belongs to class @{class ninv_comm_monoid_add}\<close>
 
 instance "fun" :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
   by (standard, simp only: plus_fun_def zero_fun_def fun_eq_iff, intro allI, rule plus_eq_zero, auto)
 
 subsubsection \<open>@{typ "'a \<Rightarrow> 'b"} belongs to class @{class lcs_powerprod}\<close>
 
 instantiation "fun" :: (type, add_linorder) lcs_powerprod
 begin
 
 definition lcs_fun::"('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where "lcs f g = (\<lambda>x. max (f x) (g x))"
 
 lemma adds_funI:
   assumes "s \<le> t"
   shows "s adds (t::'a \<Rightarrow> 'b)"
 proof (rule addsI, rule)
   fix x
   from assms have "s x \<le> t x" unfolding le_fun_def ..
   hence "t x = s x + (t x - s x)" by (rule le_imp_inv)
   thus "t x = (s + (t - s)) x" by simp
 qed
 
 lemma adds_fun_iff: "f adds (g::'a \<Rightarrow> 'b) \<longleftrightarrow> (\<forall>x. f x adds g x)"
   unfolding adds_def plus_fun_def by metis
 
 lemma adds_fun_iff': "f adds (g::'a \<Rightarrow> 'b) \<longleftrightarrow> (\<forall>x. \<exists>y. g x = f x + y)"
   unfolding adds_fun_iff unfolding adds_def plus_fun_def ..
 
 lemma adds_lcs_fun:
   shows "s adds (lcs s (t::'a \<Rightarrow> 'b))"
   by (rule adds_funI, simp only: le_fun_def lcs_fun_def, auto simp: max_def)
 
 lemma lcs_comm_fun:  "lcs s t = lcs t (s::'a \<Rightarrow> 'b)"
   unfolding lcs_fun_def
   by (auto simp: max_def intro!: ext)
 
 lemma lcs_adds_fun:
   assumes "s adds u" and "t adds (u::'a \<Rightarrow> 'b)"
   shows "(lcs s t) adds u"
   using assms unfolding lcs_fun_def adds_fun_iff'
 proof -
   assume a1: "\<forall>x. \<exists>y. u x = s x + y" and a2: "\<forall>x. \<exists>y. u x = t x + y"
   show "\<forall>x. \<exists>y. u x = max (s x) (t x) + y"
   proof
     fix x
     from a1 have b1: "\<exists>y. u x = s x + y" ..
     from a2 have b2: "\<exists>y. u x = t x + y" ..
     show "\<exists>y. u x = max (s x) (t x) + y" unfolding max_def
       by (split if_split, intro conjI impI, rule b2, rule b1)
   qed
 qed
 
 instance
   apply standard
   subgoal by (rule adds_lcs_fun)
   subgoal by (rule lcs_adds_fun)
   subgoal by (rule lcs_comm_fun)
   done
 
 end
 
 lemma leq_lcs_fun_1: "s \<le> (lcs s (t::'a \<Rightarrow> 'b::add_linorder))"
   by (simp add: lcs_fun_def le_fun_def)
 
 lemma leq_lcs_fun_2: "t \<le> (lcs s (t::'a \<Rightarrow> 'b::add_linorder))"
   by (simp add: lcs_fun_def le_fun_def)
 
 lemma lcs_leq_fun:
   assumes "s \<le> u" and "t \<le> (u::'a \<Rightarrow> 'b::add_linorder)"
   shows "(lcs s t) \<le> u"
   using assms by (simp add: lcs_fun_def le_fun_def)
 
 lemma adds_fun: "s adds t \<longleftrightarrow> s \<le> t"
   for s t::"'a \<Rightarrow> 'b::add_linorder_min"
 proof
   assume "s adds t"
   from this obtain k where "t = s + k" ..
   show "s \<le> t" unfolding \<open>t = s + k\<close> le_fun_def plus_fun_def le_iff_add by (simp add: leq_add_right)
 qed (rule adds_funI)
 
 lemma gcs_fun: "gcs s (t::'a \<Rightarrow> ('b::add_linorder)) = (\<lambda>x. min (s x) (t x))"
 proof -
   show ?thesis unfolding gcs_def lcs_fun_def fun_diff_def
   proof (simp, rule)
     fix x
     have eq: "s x + t x = max (s x) (t x) + min (s x) (t x)" by (metis add.commute min_def max_def)
     thus "s x + t x - max (s x) (t x) = min (s x) (t x)" by simp
   qed
 qed
 
 lemma gcs_leq_fun_1: "(gcs s (t::'a \<Rightarrow> 'b::add_linorder)) \<le> s"
   by (simp add: gcs_fun le_fun_def)
 
 lemma gcs_leq_fun_2: "(gcs s (t::'a \<Rightarrow> 'b::add_linorder)) \<le> t"
   by (simp add: gcs_fun le_fun_def)
 
 lemma leq_gcs_fun:
   assumes "u \<le> s" and "u \<le> (t::'a \<Rightarrow> 'b::add_linorder)"
   shows "u \<le> (gcs s t)"
   using assms by (simp add: gcs_fun le_fun_def)
 
 subsubsection \<open>@{typ "'a \<Rightarrow> 'b"} belongs to class @{class ulcs_powerprod}\<close>
 
 instance "fun" :: (type, add_linorder_min) ulcs_powerprod ..
 
 subsubsection \<open>Power-products in a given set of indeterminates\<close>
 
 definition supp_fun::"('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set" where "supp_fun f = {x. f x \<noteq> 0}"
 
 text \<open>@{term supp_fun} for general functions is like @{term keys} for @{type poly_mapping},
   but does not need to be finite.\<close>
 
 lemma keys_eq_supp: "keys s = supp_fun (lookup s)"
   unfolding supp_fun_def by (transfer, rule)
 
 lemma supp_fun_zero [simp]: "supp_fun 0 = {}"
   by (auto simp: supp_fun_def)
 
 lemma supp_fun_eq_zero_iff: "supp_fun f = {} \<longleftrightarrow> f = 0"
   by (auto simp: supp_fun_def)
 
 lemma sub_supp_empty: "supp_fun s \<subseteq> {} \<longleftrightarrow> (s = 0)"
   by (auto simp: supp_fun_def)
 
 lemma except_fun_idI: "supp_fun f \<inter> V = {} \<Longrightarrow> except_fun f V = f"
   by (auto simp: except_fun_def supp_fun_def when_def intro!: ext)
 
 lemma supp_except_fun: "supp_fun (except_fun s V) = supp_fun s - V"
   by (auto simp: except_fun_def supp_fun_def)
 
 lemma supp_fun_plus_subset: "supp_fun (s + t) \<subseteq> supp_fun s \<union> supp_fun (t::'a \<Rightarrow> 'b::monoid_add)"
   unfolding supp_fun_def by force
 
 lemma fun_eq_zeroI:
   assumes "\<And>x. x \<in> supp_fun f \<Longrightarrow> f x = 0"
   shows "f = 0"
 proof (rule, simp)
   fix x
   show "f x = 0"
   proof (cases "x \<in> supp_fun f")
     case True
     then show ?thesis by (rule assms)
   next
     case False
     then show ?thesis by (simp add: supp_fun_def)
   qed
 qed
 
 lemma except_fun_cong1:
   "supp_fun s \<inter> ((V - U) \<union> (U - V)) \<subseteq> {} \<Longrightarrow> except_fun s V = except_fun s U"
   by (auto simp: except_fun_def when_def supp_fun_def intro!: ext)
 
 lemma adds_except_fun:
   "s adds t = (except_fun s V adds except_fun t V \<and> except_fun s (- V) adds except_fun t (- V))"
   for s t :: "'a \<Rightarrow> 'b::add_linorder"
   by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)
 
 lemma adds_except_fun_singleton: "s adds t = (except_fun s {v} adds except_fun t {v} \<and> s v adds t v)"
   for s t :: "'a \<Rightarrow> 'b::add_linorder"
   by (auto simp: supp_fun_def except_fun_def adds_fun_iff when_def)
 
 subsubsection \<open>Dickson's lemma for power-products in finitely many indeterminates\<close>
 
 lemma Dickson_fun:
   assumes "finite V"
   shows "almost_full_on (adds) {x::'a \<Rightarrow> 'b::add_wellorder. supp_fun x \<subseteq> V}"
   using assms
 proof (induct V)
   case empty
   have "finite {0}" by simp
   moreover have "reflp_on {0::'a \<Rightarrow> 'b} (adds)" by (simp add: reflp_on_def)
   ultimately have "almost_full_on (adds) {0::'a \<Rightarrow> 'b}" by (rule finite_almost_full_on)
   thus ?case by (simp add: supp_fun_eq_zero_iff)
 next
   case (insert v V)
   show ?case
   proof (rule almost_full_onI)
     fix seq::"nat \<Rightarrow> 'a \<Rightarrow> 'b"
     assume "\<forall>i. seq i \<in> {x. supp_fun x \<subseteq> insert v V}"
     hence a: "supp_fun (seq i) \<subseteq> insert v V" for i by simp
     define seq' where "seq' = (\<lambda>i. (except_fun (seq i) {v}, except_fun (seq i) V))"
     have "almost_full_on (adds) {x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> {v}}"
     proof (rule almost_full_onI)
       fix f::"nat \<Rightarrow> 'a \<Rightarrow> 'b"
       assume "\<forall>i. f i \<in> {x. supp_fun x \<subseteq> {v}}"
       hence b: "supp_fun (f i) \<subseteq> {v}" for i by simp
       let ?f = "\<lambda>i. f i v"
       have "wfP ((<)::'b \<Rightarrow> _)" by (simp add: wf wfP_def)
       hence "\<forall>f::nat \<Rightarrow> 'b. \<exists>i. f i \<le> f (Suc i)"
         by (simp add: wf_iff_no_infinite_down_chain[to_pred] not_less)
       hence "\<exists>i. ?f i \<le> ?f (Suc i)" ..
       then obtain i where "?f i \<le> ?f (Suc i)" ..
       have "i < Suc i" by simp
       moreover have "f i adds f (Suc i)" unfolding adds_fun_iff
       proof
         fix x
         show "f i x adds f (Suc i) x"
         proof (cases "x = v")
           case True
           with \<open>?f i \<le> ?f (Suc i)\<close> show ?thesis by (simp add: adds_def le_iff_add)
         next
           case False
           with b have "x \<notin> supp_fun (f i)" and "x \<notin> supp_fun (f (Suc i))" by blast+
           thus ?thesis by (simp add: supp_fun_def)
         qed
       qed
       ultimately show "good (adds) f" by (meson goodI)
     qed
     with insert(3) have
       "almost_full_on (prod_le (adds) (adds)) ({x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> V} \<times> {x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> {v}})"
       (is "almost_full_on ?P ?A") by (rule almost_full_on_Sigma)
     moreover from a have "seq' i \<in> ?A" for i by (auto simp add: seq'_def supp_except_fun)
     ultimately obtain i j where "i < j" and "?P (seq' i) (seq' j)" by (rule almost_full_onD)
     have "seq i adds seq j" unfolding adds_except_fun[where s="seq i" and V=V]
     proof
       from \<open>?P (seq' i) (seq' j)\<close> show "except_fun (seq i) V adds except_fun (seq j) V"
         by (simp add: prod_le_def seq'_def)
     next
       from \<open>?P (seq' i) (seq' j)\<close> have "except_fun (seq i) {v} adds except_fun (seq j) {v}"
         by (simp add: prod_le_def seq'_def)
       moreover have "except_fun (seq i) (- V) = except_fun (seq i) {v}"
         by (rule except_fun_cong1; use a[of i] insert.hyps(2) in blast)
       moreover have "except_fun (seq j) (- V) = except_fun (seq j) {v}"
         by (rule except_fun_cong1; use a[of j] insert.hyps(2) in blast)
       ultimately show "except_fun (seq i) (- V) adds except_fun (seq j) (- V)" by simp
     qed
     with \<open>i < j\<close> show "good (adds) seq" by (meson goodI)
   qed
 qed
 
 instance "fun" :: (finite, add_wellorder) dickson_powerprod
 proof
   have "finite (UNIV::'a set)" by simp
   hence "almost_full_on (adds) {x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> UNIV}" by (rule Dickson_fun)
   thus "almost_full_on (adds) (UNIV::('a \<Rightarrow> 'b) set)" by simp
 qed
 
 subsubsection \<open>Lexicographic Term Order\<close>
 
 text \<open>Term orders are certain linear orders on power-products, satisfying additional requirements.
   Further information on term orders can be found, e.\,g., in @{cite Robbiano1985}.\<close>
 
 context wellorder
 begin
 
 lemma neq_fun_alt:
   assumes "s \<noteq> (t::'a \<Rightarrow> 'b)"
   obtains x where "s x \<noteq> t x" and "\<And>y. s y \<noteq> t y \<Longrightarrow> x \<le> y"
 proof -
   from assms ext[of s t] have "\<exists>x. s x \<noteq> t x" by auto
   with exists_least_iff[of "\<lambda>x. s x \<noteq> t x"]
   obtain x where x1: "s x \<noteq> t x" and x2: "\<And>y. y < x \<Longrightarrow> s y = t y"
     by auto
   show ?thesis
   proof
     from x1 show "s x \<noteq> t x" .
   next
     fix y
     assume "s y \<noteq> t y"
     with x2[of y] have "\<not> y < x" by auto
     thus "x \<le> y" by simp
   qed
 qed
 
 definition lex_fun::"('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "lex_fun s t \<equiv> (\<forall>x. s x \<le> t x \<or> (\<exists>y<x. s y \<noteq> t y))"
 
 definition "lex_fun_strict s t \<longleftrightarrow> lex_fun s t \<and> \<not> lex_fun t s"
 
 text \<open>Attention! @{term lex_fun} reverses the order of the indeterminates: if @{term x} is smaller than
   @{term y} w.r.t. the order on @{typ 'a}, then the @{emph \<open>power-product\<close>} @{term x} is
   @{emph \<open>greater\<close>} than the @{emph \<open>power-product\<close>} @{term y}.\<close>
 
 lemma lex_fun_alt:
   shows "lex_fun s t = (s = t \<or> (\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y)))" (is "?L = ?R")
 proof
   assume ?L
   show ?R
   proof (cases "s = t")
     assume "s = t"
     thus ?R by simp
   next
     assume "s \<noteq> t"
     from neq_fun_alt[OF this] obtain x0
       where x0_neq: "s x0 \<noteq> t x0" and x0_min: "\<And>z. s z \<noteq> t z \<Longrightarrow> x0 \<le> z" by auto
     show ?R
     proof (intro disjI2, rule exI[of _ x0], intro conjI)
       from \<open>?L\<close> have "s x0 \<le> t x0 \<or> (\<exists>y. y < x0 \<and> s y \<noteq> t y)" unfolding lex_fun_def ..
       thus "s x0 < t x0"
       proof
         assume "s x0 \<le> t x0"
         from this x0_neq show ?thesis by simp
       next
         assume "\<exists>y. y < x0 \<and> s y \<noteq> t y"
         then obtain y where "y < x0" and y_neq: "s y \<noteq> t y" by auto
         from \<open>y < x0\<close> x0_min[OF y_neq] show ?thesis by simp
       qed
     next
       show "\<forall>y<x0. s y = t y"
       proof (rule, rule)
         fix y
         assume "y < x0"
         hence "\<not> x0 \<le> y" by simp
         from this x0_min[of y] show "s y = t y" by auto
       qed
     qed
   qed
 next
   assume ?R
   thus ?L
   proof
     assume "s = t"
     thus ?thesis by (simp add: lex_fun_def)
   next
     assume "\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y)"
     then obtain y where y: "s y < t y" and y_min: "\<forall>z<y. s z = t z" by auto
     show ?thesis unfolding lex_fun_def
     proof
       fix x
       show "s x \<le> t x \<or> (\<exists>y<x. s y \<noteq> t y)"
       proof (cases "s x \<le> t x")
         assume "s x \<le> t x"
         thus ?thesis by simp
       next
         assume x: "\<not> s x \<le> t x"
         show ?thesis
         proof (intro disjI2, rule exI[of _ y], intro conjI)
           have "\<not> x \<le> y"
           proof
             assume "x \<le> y"
             hence "x < y \<or> y = x" by auto
             thus False
             proof
               assume "x < y"
               from x y_min[rule_format, OF this] show ?thesis by simp
             next
               assume "y = x"
               from this x y show ?thesis
                 by (auto simp: preorder_class.less_le_not_le)
             qed
           qed
           thus "y < x" by simp
         next
           from y show "s y \<noteq> t y" by simp
         qed
       qed
     qed
   qed
 qed
 
 lemma lex_fun_refl: "lex_fun s s"
 unfolding lex_fun_alt by simp
 
 lemma lex_fun_antisym:
   assumes "lex_fun s t" and "lex_fun t s"
   shows "s = t"
 proof
   fix x
   from assms(1) have "s = t \<or> (\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y))"
     unfolding lex_fun_alt .
   thus "s x = t x"
   proof
     assume "s = t"
     thus ?thesis by simp
   next
     assume "\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y)"
     then obtain x0 where x0: "s x0 < t x0" and x0_min: "\<forall>y<x0. s y = t y" by auto
     from assms(2) have "t = s \<or> (\<exists>x. t x < s x \<and> (\<forall>y<x. t y = s y))" unfolding lex_fun_alt .
     thus ?thesis
     proof
       assume "t = s"
       thus ?thesis by simp
     next
       assume "\<exists>x. t x < s x \<and> (\<forall>y<x. t y = s y)"
       then obtain x1 where x1: "t x1 < s x1" and x1_min: "\<forall>y<x1. t y = s y" by auto
       have "x0 < x1 \<or> x1 < x0 \<or> x1 = x0" using local.antisym_conv3 by auto
       show ?thesis
       proof (rule linorder_cases[of x0 x1])
         assume "x1 < x0"
         from x0_min[rule_format, OF this] x1 show ?thesis by simp
       next
         assume "x0 = x1"
         from this x0 x1 show ?thesis by simp
       next
         assume "x0 < x1"
         from x1_min[rule_format, OF this] x0 show ?thesis by simp
       qed
     qed
   qed
 qed
 
 lemma lex_fun_trans:
   assumes "lex_fun s t" and "lex_fun t u"
   shows "lex_fun s u"
 proof -
   from assms(1) have "s = t \<or> (\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y))" unfolding lex_fun_alt .
   thus ?thesis
   proof
     assume "s = t"
     from this assms(2) show ?thesis by simp
   next
     assume "\<exists>x. s x < t x \<and> (\<forall>y<x. s y = t y)"
     then obtain x0 where x0: "s x0 < t x0" and x0_min: "\<forall>y<x0. s y = t y"
       by auto
     from assms(2) have "t = u \<or> (\<exists>x. t x < u x \<and> (\<forall>y<x. t y = u y))" unfolding lex_fun_alt .
     thus ?thesis
     proof
       assume "t = u"
       from this assms(1) show ?thesis by simp
     next
       assume "\<exists>x. t x < u x \<and> (\<forall>y<x. t y = u y)"
       then obtain x1 where x1: "t x1 < u x1" and x1_min: "\<forall>y<x1. t y = u y" by auto
       show ?thesis unfolding lex_fun_alt
       proof (intro disjI2)
         show "\<exists>x. s x < u x \<and> (\<forall>y<x. s y = u y)"
         proof (rule linorder_cases[of x0 x1])
           assume "x1 < x0"
           show ?thesis
           proof (rule exI[of _ x1], intro conjI)
             from x0_min[rule_format, OF \<open>x1 < x0\<close>] x1 show "s x1 < u x1" by simp
           next
             show "\<forall>y<x1. s y = u y"
             proof (intro allI, intro impI)
               fix y
               assume "y < x1"
               from this \<open>x1 < x0\<close> have "y < x0" by simp
               from x0_min[rule_format, OF this] x1_min[rule_format, OF \<open>y < x1\<close>]
                 show "s y = u y" by simp
             qed
           qed
         next
           assume "x0 < x1"
           show ?thesis
           proof (rule exI[of _ x0], intro conjI)
             from x1_min[rule_format, OF \<open>x0 < x1\<close>] x0 show "s x0 < u x0" by simp
           next
             show "\<forall>y<x0. s y = u y"
             proof (intro allI, intro impI)
               fix y
               assume "y < x0"
               from this \<open>x0 < x1\<close> have "y < x1" by simp
               from x0_min[rule_format, OF \<open>y < x0\<close>] x1_min[rule_format, OF this]
                 show "s y = u y" by simp
             qed
           qed
         next
           assume "x0 = x1"
           show ?thesis
           proof (rule exI[of _ x1], intro conjI)
             from \<open>x0 = x1\<close> x0 x1 show "s x1 < u x1" by simp
           next
             show "\<forall>y<x1. s y = u y"
             proof (intro allI, intro impI)
               fix y
               assume "y < x1"
               hence "y < x0" using \<open>x0 = x1\<close> by simp
               from x0_min[rule_format, OF this] x1_min[rule_format, OF \<open>y < x1\<close>]
                 show "s y = u y" by simp
             qed
           qed
         qed
       qed
     qed
   qed
 qed
 
 lemma lex_fun_lin: "lex_fun s t \<or> lex_fun t s" for s t::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder}"
 proof (intro disjCI)
   assume "\<not> lex_fun t s"
   hence a: "\<forall>x. \<not> (t x < s x) \<or> (\<exists>y<x. t y \<noteq> s y)" unfolding lex_fun_alt by auto
   show "lex_fun s t" unfolding lex_fun_def
   proof
     fix x
     from a have "\<not> (t x < s x) \<or> (\<exists>y<x. t y \<noteq> s y)" ..
     thus "s x \<le> t x \<or> (\<exists>y<x. s y \<noteq> t y)" by auto
   qed
 qed
 
 corollary lex_fun_strict_alt [code]:
   "lex_fun_strict s t = (\<not> lex_fun t s)" for s t::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder}"
   unfolding lex_fun_strict_def using lex_fun_lin[of s t] by auto
 
 lemma lex_fun_zero_min: "lex_fun 0 s" for s::"'a \<Rightarrow> 'b::add_linorder_min"
   by (simp add: lex_fun_def zero_min)
 
 lemma lex_fun_plus_monotone:
   "lex_fun (s + u) (t + u)" if "lex_fun s t"
   for s t::"'a \<Rightarrow> 'b::ordered_cancel_comm_monoid_add"
 unfolding lex_fun_def
 proof
   fix x
   from that have "s x \<le> t x \<or> (\<exists>y<x. s y \<noteq> t y)" unfolding lex_fun_def ..
   thus "(s + u) x \<le> (t + u) x \<or> (\<exists>y<x. (s + u) y \<noteq> (t + u) y)"
   proof
     assume a1: "s x \<le> t x"
     show ?thesis
     proof (intro disjI1)
       from a1 show "(s + u) x \<le> (t + u) x" by (auto simp: add_right_mono)
     qed
   next
     assume "\<exists>y<x. s y \<noteq> t y"
     then obtain y where "y < x" and a2: "s y \<noteq> t y" by auto
     show ?thesis
     proof (intro disjI2, rule exI[of _ y], intro conjI, fact)
       from a2 show "(s + u) y \<noteq> (t + u) y" by (auto simp: add_right_mono)
     qed
   qed
 qed
 
 end (* wellorder *)
 
 subsubsection \<open>Degree\<close>
 
 definition deg_fun::"('a \<Rightarrow> 'b::comm_monoid_add) \<Rightarrow> 'b" where "deg_fun s \<equiv> \<Sum>x\<in>(supp_fun s). s x"
 
 lemma deg_fun_zero[simp]: "deg_fun 0 = 0"
   by (auto simp: deg_fun_def)
 
 lemma deg_fun_eq_0_iff:
   assumes "finite (supp_fun (s::'a \<Rightarrow> 'b::add_linorder_min))"
   shows "deg_fun s = 0 \<longleftrightarrow> s = 0"
 proof
   assume "deg_fun s = 0"
   hence *: "(\<Sum>x\<in>(supp_fun s). s x) = 0" by (simp only: deg_fun_def)
   have **: "\<And>x. 0 \<le> s x" by (rule zero_min)
   from * have "\<And>x. x \<in> supp_fun s \<Longrightarrow> s x = 0" by (simp only: sum_nonneg_eq_0_iff[OF assms **])
   thus "s = 0" by (rule fun_eq_zeroI)
 qed simp
 
 lemma deg_fun_superset:
   fixes A::"'a set"
   assumes "supp_fun s \<subseteq> A" and "finite A"
   shows "deg_fun s = (\<Sum>x\<in>A. s x)"
   unfolding deg_fun_def
 proof (rule sum.mono_neutral_cong_left, fact, fact, rule)
   fix x
   assume "x \<in> A - supp_fun s"
   hence "x \<notin> supp_fun s" by simp
   thus "s x = 0" by (simp add: supp_fun_def)
 qed rule
 
 lemma deg_fun_plus:
   assumes "finite (supp_fun s)" and "finite (supp_fun t)"
   shows "deg_fun (s + t) = deg_fun s + deg_fun (t::'a \<Rightarrow> 'b::comm_monoid_add)"
 proof -
   from assms have fin: "finite (supp_fun s \<union> supp_fun t)" by simp
   have "deg_fun (s + t) = (\<Sum>x\<in>(supp_fun (s + t)). s x + t x)" by (simp add: deg_fun_def)
   also from fin have "... = (\<Sum>x\<in>(supp_fun s \<union> supp_fun t). s x + t x)"
   proof (rule sum.mono_neutral_cong_left)
     show "\<forall>x\<in>supp_fun s \<union> supp_fun t - supp_fun (s + t). s x + t x = 0"
     proof
       fix x
       assume "x \<in> supp_fun s \<union> supp_fun t - supp_fun (s + t)"
       hence "x \<notin> supp_fun (s + t)" by simp
       thus "s x + t x = 0" by (simp add: supp_fun_def)
     qed
   qed (rule supp_fun_plus_subset, rule)
   also have "\<dots> = (\<Sum>x\<in>(supp_fun s \<union> supp_fun t). s x) + (\<Sum>x\<in>(supp_fun s \<union> supp_fun t). t x)"
     by (rule sum.distrib)
   also from fin have "(\<Sum>x\<in>(supp_fun s \<union> supp_fun t). s x) = deg_fun s" unfolding deg_fun_def
   proof (rule sum.mono_neutral_cong_right)
     show "\<forall>x\<in>supp_fun s \<union> supp_fun t - supp_fun s. s x = 0"
     proof
       fix x
       assume "x \<in> supp_fun s \<union> supp_fun t - supp_fun s"
       hence "x \<notin> supp_fun s" by simp
       thus "s x = 0" by (simp add: supp_fun_def)
     qed
   qed simp_all
   also from fin have "(\<Sum>x\<in>(supp_fun s \<union> supp_fun t). t x) = deg_fun t" unfolding deg_fun_def
   proof (rule sum.mono_neutral_cong_right)
   show "\<forall>x\<in>supp_fun s \<union> supp_fun t - supp_fun t. t x = 0"
     proof
       fix x
       assume "x \<in> supp_fun s \<union> supp_fun t - supp_fun t"
       hence "x \<notin> supp_fun t" by simp
       thus "t x = 0" by (simp add: supp_fun_def)
     qed
   qed simp_all
   finally show ?thesis .
 qed
 
 lemma deg_fun_leq:
   assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "s \<le> (t::'a \<Rightarrow> 'b::ordered_comm_monoid_add)"
   shows "deg_fun s \<le> deg_fun t"
 proof -
   let ?A = "supp_fun s \<union> supp_fun t"
   from assms(1) assms(2) have 1: "finite ?A" by simp
   have s: "supp_fun s \<subseteq> ?A" and t: "supp_fun t \<subseteq> ?A" by simp_all
   show ?thesis unfolding deg_fun_superset[OF s 1] deg_fun_superset[OF t 1]
   proof (rule sum_mono)
     fix i
     from assms(3) show "s i \<le> t i" unfolding le_fun_def ..
   qed
 qed
 
 subsubsection \<open>General Degree-Orders\<close>
 
 context linorder
 begin
 
 lemma ex_min:
   assumes "finite (A::'a set)" and "A \<noteq> {}"
   shows "\<exists>y\<in>A. (\<forall>z\<in>A. y \<le> z)"
 using assms
 proof (induct rule: finite_induct)
   assume "{} \<noteq> {}"
   thus "\<exists>y\<in>{}. \<forall>z\<in>{}. y \<le> z" by simp
 next
   fix a::'a and A::"'a set"
   assume "a \<notin> A" and IH: "A \<noteq> {} \<Longrightarrow> \<exists>y\<in>A. (\<forall>z\<in>A. y \<le> z)"
   show "\<exists>y\<in>insert a A. (\<forall>z\<in>insert a A. y \<le> z)"
   proof (cases "A = {}")
     case True
     show ?thesis
     proof (rule bexI[of _ a], intro ballI)
       fix z
       assume "z \<in> insert a A"
       from this True have "z = a" by simp
       thus "a \<le> z" by simp
     qed (simp)
   next
     case False
     from IH[OF False] obtain y where "y \<in> A" and y_min: "\<forall>z\<in>A. y \<le> z" by auto
     from linear[of a y] show ?thesis
     proof
       assume "y \<le> a"
       show ?thesis
       proof (rule bexI[of _ y], intro ballI)
         fix z
         assume "z \<in> insert a A"
         hence "z = a \<or> z \<in> A" by simp
         thus "y \<le> z"
         proof
           assume "z = a"
           from this \<open>y \<le> a\<close> show "y \<le> z" by simp
         next
           assume "z \<in> A"
           from y_min[rule_format, OF this] show "y \<le> z" .
         qed
       next
         from \<open>y \<in> A\<close> show "y \<in> insert a A" by simp
       qed
     next
       assume "a \<le> y"
       show ?thesis
       proof (rule bexI[of _ a], intro ballI)
         fix z
         assume "z \<in> insert a A"
         hence "z = a \<or> z \<in> A" by simp
         thus "a \<le> z"
         proof
           assume "z = a"
           from this show "a \<le> z" by simp
         next
           assume "z \<in> A"
           from y_min[rule_format, OF this] \<open>a \<le> y\<close> show "a \<le> z" by simp
         qed
       qed (simp)
     qed
   qed
 qed
 
 definition dord_fun::"(('a \<Rightarrow> 'b::ordered_comm_monoid_add) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "dord_fun ord s t \<equiv> (let d1 = deg_fun s; d2 = deg_fun t in (d1 < d2 \<or> (d1 = d2 \<and> ord s t)))"
 
 lemma dord_fun_degD:
   assumes "dord_fun ord s t"
   shows "deg_fun s \<le> deg_fun t"
   using assms unfolding dord_fun_def Let_def by auto
 
 lemma dord_fun_refl:
   assumes "ord s s"
   shows "dord_fun ord s s"
   using assms unfolding dord_fun_def by simp
 
 lemma dord_fun_antisym:
   assumes ord_antisym: "ord s t \<Longrightarrow> ord t s \<Longrightarrow> s = t" and "dord_fun ord s t" and "dord_fun ord t s"
   shows "s = t"
 proof -
   from assms(3) have ts: "deg_fun t < deg_fun s \<or> (deg_fun t = deg_fun s \<and> ord t s)"
     unfolding dord_fun_def Let_def .
   from assms(2) have st: "deg_fun s < deg_fun t \<or> (deg_fun s = deg_fun t \<and> ord s t)"
     unfolding dord_fun_def Let_def .
   thus ?thesis
   proof
     assume "deg_fun s < deg_fun t"
     thus ?thesis using ts by auto
   next
     assume "deg_fun s = deg_fun t \<and> ord s t"
     hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
     from \<open>deg_fun s = deg_fun t\<close> ts have "ord t s" by simp
     with \<open>ord s t\<close> show ?thesis by (rule ord_antisym)
   qed
 qed
 
 lemma dord_fun_trans:
   assumes ord_trans: "ord s t \<Longrightarrow> ord t u \<Longrightarrow> ord s u" and "dord_fun ord s t" and "dord_fun ord t u"
   shows "dord_fun ord s u"
 proof -
   from assms(3) have ts: "deg_fun t < deg_fun u \<or> (deg_fun t = deg_fun u \<and> ord t u)"
     unfolding dord_fun_def Let_def .
   from assms(2) have st: "deg_fun s < deg_fun t \<or> (deg_fun s = deg_fun t \<and> ord s t)"
     unfolding dord_fun_def Let_def .
   thus ?thesis
   proof
     assume "deg_fun s < deg_fun t"
     from this dord_fun_degD[OF assms(3)] have "deg_fun s < deg_fun u" by simp
     thus ?thesis by (simp add: dord_fun_def Let_def)
   next
     assume "deg_fun s = deg_fun t \<and> ord s t"
     hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
     from ts show ?thesis
     proof
       assume "deg_fun t < deg_fun u"
       hence "deg_fun s < deg_fun u" using \<open>deg_fun s = deg_fun t\<close> by simp
       thus ?thesis by (simp add: dord_fun_def Let_def)
     next
       assume "deg_fun t = deg_fun u \<and> ord t u"
       hence "deg_fun t = deg_fun u" and "ord t u" by simp_all
       from ord_trans[OF \<open>ord s t\<close> \<open>ord t u\<close>] \<open>deg_fun s = deg_fun t\<close> \<open>deg_fun t = deg_fun u\<close> show ?thesis
         by (simp add: dord_fun_def Let_def)
     qed
   qed
 qed
 
 lemma dord_fun_lin:
   "dord_fun ord s t \<or> dord_fun ord t s"
   if "ord s t \<or> ord t s"
   for s t::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder}"
 proof (intro disjCI)
   assume "\<not> dord_fun ord t s"
   hence "deg_fun s \<le> deg_fun t \<and> (deg_fun t \<noteq> deg_fun s \<or> \<not> ord t s)"
     unfolding dord_fun_def Let_def by auto
   hence "deg_fun s \<le> deg_fun t" and dis1: "deg_fun t \<noteq> deg_fun s \<or> \<not> ord t s" by simp_all
   show "dord_fun ord s t" unfolding dord_fun_def Let_def
   proof (intro disjCI)
     assume "\<not> (deg_fun s = deg_fun t \<and> ord s t)"
     hence dis2: "deg_fun s \<noteq> deg_fun t \<or> \<not> ord s t" by simp
     show "deg_fun s < deg_fun t"
     proof (cases "deg_fun s = deg_fun t")
       case True
       from True dis1 have "\<not> ord t s" by simp
       from True dis2 have "\<not> ord s t" by simp
       from \<open>\<not> ord s t\<close> \<open>\<not> ord t s\<close> that show ?thesis by simp
     next
       case False
       from this \<open>deg_fun s \<le> deg_fun t\<close> show ?thesis by simp
     qed
   qed
 qed
 
 lemma dord_fun_zero_min:
   fixes s t::"'a \<Rightarrow> 'b::add_linorder_min"
   assumes ord_refl: "\<And>t. ord t t" and "finite (supp_fun s)"
   shows "dord_fun ord 0 s"
   unfolding dord_fun_def Let_def deg_fun_zero
 proof (rule disjCI)
   assume "\<not> (0 = deg_fun s \<and> ord 0 s)"
   hence dis: "deg_fun s \<noteq> 0 \<or> \<not> ord 0 s" by simp
   show "0 < deg_fun s"
   proof (cases "deg_fun s = 0")
     case True
     hence "s = 0" using deg_fun_eq_0_iff[OF assms(2)] by auto
     hence "ord 0 s" using ord_refl by simp
     with True dis show ?thesis by simp
   next
     case False
     thus ?thesis by (auto simp: zero_less_iff_neq_zero)
   qed
 qed
 
 lemma dord_fun_plus_monotone:
   fixes s t u ::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
   assumes ord_monotone: "ord s t \<Longrightarrow> ord (s + u) (t + u)" and "finite (supp_fun s)"
     and "finite (supp_fun t)" and "finite (supp_fun u)" and "dord_fun ord s t"
   shows "dord_fun ord (s + u) (t + u)"
 proof -
   from assms(5) have "deg_fun s < deg_fun t \<or> (deg_fun s = deg_fun t \<and> ord s t)"
     unfolding dord_fun_def Let_def .
   thus ?thesis
   proof
     assume "deg_fun s < deg_fun t"
     hence "deg_fun (s + u) < deg_fun (t + u)" by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
     thus ?thesis unfolding dord_fun_def Let_def by simp
   next
     assume "deg_fun s = deg_fun t \<and> ord s t"
     hence "deg_fun s = deg_fun t" and "ord s t" by simp_all
     from \<open>deg_fun s = deg_fun t\<close> have "deg_fun (s + u) = deg_fun (t + u)"
       by (auto simp: deg_fun_plus[OF _ assms(4)] assms(2) assms(3))
     from this ord_monotone[OF \<open>ord s t\<close>] show ?thesis unfolding dord_fun_def Let_def by simp
   qed
 qed
 
 end (* linorder *)
 
 context wellorder
 begin
 
 subsubsection \<open>Degree-Lexicographic Term Order\<close>
 
 definition dlex_fun::"('a \<Rightarrow> 'b::ordered_comm_monoid_add) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "dlex_fun \<equiv> dord_fun lex_fun"
 
 definition "dlex_fun_strict s t \<longleftrightarrow> dlex_fun s t \<and> \<not> dlex_fun t s"
 
 lemma dlex_fun_refl:
   shows "dlex_fun s s"
 unfolding dlex_fun_def by (rule dord_fun_refl, rule lex_fun_refl)
 
 lemma dlex_fun_antisym:
   assumes "dlex_fun s t" and "dlex_fun t s"
   shows "s = t"
   by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
       simp_all only: dlex_fun_def[symmetric], fact+)
 
 lemma dlex_fun_trans:
   assumes "dlex_fun s t" and "dlex_fun t u"
   shows "dlex_fun s u"
   by (simp only: dlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
       simp_all only: dlex_fun_def[symmetric], fact+)
 
 lemma dlex_fun_lin: "dlex_fun s t \<or> dlex_fun t s"
   for s t::"('a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder})"
   unfolding dlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)
 
 corollary dlex_fun_strict_alt [code]:
   "dlex_fun_strict s t = (\<not> dlex_fun t s)" for s t::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder}"
   unfolding dlex_fun_strict_def using dlex_fun_lin by auto
 
 lemma dlex_fun_zero_min:
   fixes s t::"('a \<Rightarrow> 'b::add_linorder_min)"
   assumes "finite (supp_fun s)"
   shows "dlex_fun 0 s"
   unfolding dlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)
 
 lemma dlex_fun_plus_monotone:
   fixes s t u::"'a \<Rightarrow> 'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
   assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "dlex_fun s t"
   shows "dlex_fun (s + u) (t + u)"
   using lex_fun_plus_monotone[of s t u] assms unfolding dlex_fun_def
   by (rule dord_fun_plus_monotone)
 
 subsubsection \<open>Degree-Reverse-Lexicographic Term Order\<close>
 
 abbreviation rlex_fun::"('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "rlex_fun s t \<equiv> lex_fun t s"
 
 text \<open>Note that @{const rlex_fun} is not precisely the reverse-lexicographic order relation on
   power-products. Normally, the @{emph \<open>last\<close>} (i.\,e. highest) indeterminate whose exponent differs
   in the two power-products to be compared is taken, but since we do not require the domain to be finite,
   there might not be such a last indeterminate. Therefore, we simply take the converse of
   @{const lex_fun}.\<close>
 
 definition drlex_fun::"('a \<Rightarrow> 'b::ordered_comm_monoid_add) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "drlex_fun \<equiv> dord_fun rlex_fun"
 
 definition "drlex_fun_strict s t \<longleftrightarrow> drlex_fun s t \<and> \<not> drlex_fun t s"
 
 lemma drlex_fun_refl:
   shows "drlex_fun s s"
   unfolding drlex_fun_def by (rule dord_fun_refl, fact lex_fun_refl)
 
 lemma drlex_fun_antisym:
   assumes "drlex_fun s t" and "drlex_fun t s"
   shows "s = t"
   by (rule dord_fun_antisym, erule lex_fun_antisym, assumption,
       simp_all only: drlex_fun_def[symmetric], fact+)
 
 lemma drlex_fun_trans:
   assumes "drlex_fun s t" and "drlex_fun t u"
   shows "drlex_fun s u"
   by (simp only: drlex_fun_def, rule dord_fun_trans, erule lex_fun_trans, assumption,
       simp_all only: drlex_fun_def[symmetric], fact+)
 
 lemma drlex_fun_lin: "drlex_fun s t \<or> drlex_fun t s"
   for s t::"('a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder})"
   unfolding drlex_fun_def by (rule dord_fun_lin, rule lex_fun_lin)
 
 corollary drlex_fun_strict_alt [code]:
   "drlex_fun_strict s t = (\<not> drlex_fun t s)" for s t::"'a \<Rightarrow> 'b::{ordered_comm_monoid_add, linorder}"
   unfolding drlex_fun_strict_def using drlex_fun_lin by auto
 
 lemma drlex_fun_zero_min:
   fixes s t::"('a \<Rightarrow> 'b::add_linorder_min)"
   assumes "finite (supp_fun s)"
   shows "drlex_fun 0 s"
   unfolding drlex_fun_def by (rule dord_fun_zero_min, rule lex_fun_refl, fact)
 
 lemma drlex_fun_plus_monotone:
   fixes s t u::"'a \<Rightarrow> 'b::{ordered_cancel_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
   assumes "finite (supp_fun s)" and "finite (supp_fun t)" and "finite (supp_fun u)" and "drlex_fun s t"
   shows "drlex_fun (s + u) (t + u)"
   using lex_fun_plus_monotone[of t s u] assms unfolding drlex_fun_def
   by (rule dord_fun_plus_monotone)
 
 end (* wellorder *)
 
 text\<open>Every finite linear ordering is also a well-ordering. This fact is particularly useful when
   working with fixed finite sets of indeterminates.\<close>
 class finite_linorder = finite + linorder
 begin
 
 subclass wellorder
 proof
   fix P::"'a \<Rightarrow> bool" and a
   assume hyp: "\<And>x. (\<And>y. (y < x) \<Longrightarrow> P y) \<Longrightarrow> P x"
   show "P a"
   proof (rule ccontr)
     assume "\<not> P a"
     have "finite {x. \<not> P x}" (is "finite ?A") by simp
     from \<open>\<not> P a\<close> have "a \<in> ?A" by simp
     hence "?A \<noteq> {}" by auto
     from ex_min[OF \<open>finite ?A\<close> this] obtain b where "b \<in> ?A" and b_min: "\<forall>y\<in>?A. b \<le> y" by auto
     from \<open>b \<in> ?A\<close> have "\<not> P b" by simp
     with hyp[of b] obtain y where "y < b" and "\<not> P y" by auto
     from \<open>\<not> P y\<close> have "y \<in> ?A" by simp
     with b_min have "b \<le> y" by simp
     with \<open>y < b\<close> show False by simp
   qed
 qed
 
 end
 
 
 subsection \<open>Type @{type poly_mapping}\<close>
 
 lemma poly_mapping_eq_zeroI:
   assumes "keys s = {}"
   shows "s = (0::('a, 'b::zero) poly_mapping)"
 proof (rule poly_mapping_eqI, simp)
   fix x
   from assms show "lookup s x = 0" by auto
 qed
 
 lemma keys_plus_ninv_comm_monoid_add: "keys (s + t) = keys s \<union> keys (t::'a \<Rightarrow>\<^sub>0 'b::ninv_comm_monoid_add)"
 proof (rule, fact Poly_Mapping.keys_add, rule)
   fix x
   assume "x \<in> keys s \<union> keys t"
   thus "x \<in> keys (s + t)"
   proof
     assume "x \<in> keys s"
     thus ?thesis
       by (metis in_keys_iff lookup_add plus_eq_zero)
   next
     assume "x \<in> keys t"
     thus ?thesis
       by (metis in_keys_iff lookup_add plus_eq_zero_2)
   qed
 qed
 
 lemma lookup_zero_fun: "lookup 0 = 0"
   by (simp only: zero_poly_mapping.rep_eq zero_fun_def)
 
 lemma lookup_plus_fun: "lookup (s + t) = lookup s + lookup t"
   by (simp only: plus_poly_mapping.rep_eq plus_fun_def)
 
 lemma lookup_uminus_fun: "lookup (- s) = - lookup s"
   by (fact uminus_poly_mapping.rep_eq)
 
 lemma lookup_minus_fun: "lookup (s - t) = lookup s - lookup t"
   by (simp only: minus_poly_mapping.rep_eq, rule, simp only: minus_apply)
 
 lemma poly_mapping_adds_iff: "s adds t \<longleftrightarrow> lookup s adds lookup t"
   unfolding adds_def
 proof
   assume "\<exists>k. t = s + k"
   then obtain k where *: "t = s + k" ..
   show "\<exists>k. lookup t = lookup s + k"
   proof
     from * show "lookup t = lookup s + lookup k" by (simp only: lookup_plus_fun)
   qed
 next
   assume "\<exists>k. lookup t = lookup s + k"
   then obtain k where *: "lookup t = lookup s + k" ..
   have **: "k \<in> {f. finite {x. f x \<noteq> 0}}"
   proof
     have "finite {x. lookup t x \<noteq> 0}" by transfer
     hence "finite {x. lookup s x + k x \<noteq> 0}" by (simp only: * plus_fun_def)
     moreover have "finite {x. lookup s x \<noteq> 0}" by transfer
     ultimately show "finite {x. k x \<noteq> 0}" by (rule finite_neq_0_inv', simp)
   qed
   show "\<exists>k. t = s + k"
   proof
     show "t = s + Abs_poly_mapping k"
       by (rule poly_mapping_eqI, simp add: * lookup_add Abs_poly_mapping_inverse[OF **])
   qed
 qed
 
 subsubsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}\<close>
 
 instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
   by standard
 
 subsubsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}\<close>
 
 instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
 proof (standard, transfer)
   fix s t::"'a \<Rightarrow> 'b"
   assume "(\<lambda>k. s k + t k) = (\<lambda>_. 0)"
   hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
   hence "s = 0" by (rule plus_eq_zero)
   thus "s = (\<lambda>_. 0)" by (simp only: zero_fun_def)
 qed
 
 subsubsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class lcs_powerprod}\<close>
 
 instantiation poly_mapping :: (type, add_linorder) lcs_powerprod
 begin
 
 lift_definition lcs_poly_mapping::"('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)" is "\<lambda>s t. \<lambda>x. max (s x) (t x)"
 proof -
   fix fun1 fun2::"'a \<Rightarrow> 'b"
   assume "finite {t. fun1 t \<noteq> 0}" and "finite {t. fun2 t \<noteq> 0}"
   from finite_neq_0'[OF this, of max] show "finite {t. max (fun1 t) (fun2 t) \<noteq> 0}"
     by (auto simp: max_def)
 qed
 
 lemma adds_poly_mappingI:
   assumes "lookup s \<le> lookup (t::'a \<Rightarrow>\<^sub>0 'b)"
   shows "s adds t"
   unfolding poly_mapping_adds_iff using assms by (rule adds_funI)
 
 lemma lookup_lcs_fun: "lookup (lcs s t) = lcs (lookup s) (lookup (t:: 'a \<Rightarrow>\<^sub>0 'b))"
   by (simp only: lcs_poly_mapping.rep_eq lcs_fun_def)
 
 instance
   by (standard, simp_all only: poly_mapping_adds_iff lookup_lcs_fun, rule adds_lcs, elim lcs_adds,
       assumption, rule poly_mapping_eqI, simp only: lookup_lcs_fun lcs_comm)
 
 end
 
 lemma adds_poly_mapping: "s adds t \<longleftrightarrow> lookup s \<le> lookup t"
   for s t::"'a \<Rightarrow>\<^sub>0 'b::add_linorder_min"
   by (simp only: poly_mapping_adds_iff adds_fun)
 
 lemma lookup_gcs_fun: "lookup (gcs s (t::'a \<Rightarrow>\<^sub>0 ('b::add_linorder))) = gcs (lookup s) (lookup t)"
 proof
   fix x
   show "lookup (gcs s t) x = gcs (lookup s) (lookup t) x"
     by (simp add: gcs_def lookup_minus lookup_add lookup_lcs_fun)
 qed
 
 subsubsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class ulcs_powerprod}\<close>
 
 instance poly_mapping :: (type, add_linorder_min) ulcs_powerprod ..
 
 subsubsection \<open>Power-products in a given set of indeterminates.\<close>
 
 lemma adds_except:
   "s adds t = (except s V adds except t V \<and> except s (- V) adds except t (- V))"
   for s t :: "'a \<Rightarrow>\<^sub>0 'b::add_linorder"
   by (simp add: poly_mapping_adds_iff adds_except_fun[of "lookup s", where V=V] except.rep_eq)
 
 lemma adds_except_singleton:
   "s adds t \<longleftrightarrow> (except s {v} adds except t {v} \<and> lookup s v adds lookup t v)"
   for s t :: "'a \<Rightarrow>\<^sub>0 'b::add_linorder"
   by (simp add: poly_mapping_adds_iff adds_except_fun_singleton[of "lookup s", where v=v] except.rep_eq)
 
 subsubsection \<open>Dickson's lemma for power-products in finitely many indeterminates\<close>
 
 context countable
 begin
 
 definition elem_index :: "'a \<Rightarrow> nat" where "elem_index = (SOME f. inj f)"
 
 lemma inj_elem_index: "inj elem_index"
   unfolding elem_index_def using ex_inj by (rule someI_ex)
 
 lemma elem_index_inj:
   assumes "elem_index x = elem_index y"
   shows "x = y"
   using inj_elem_index assms by (rule injD)
 
 lemma finite_nat_seg: "finite {x. elem_index x < n}"
 proof (rule finite_imageD)
   have "elem_index ` {x. elem_index x < n} \<subseteq> {0..<n}" by auto
   moreover have "finite ..." ..
   ultimately show "finite (elem_index ` {x. elem_index x < n})" by (rule finite_subset)
 next
   from inj_elem_index show "inj_on elem_index {x. elem_index x < n}" using inj_on_subset by blast
 qed
 
 end (* countable *)
 
 lemma Dickson_poly_mapping:
   assumes "finite V"
   shows "almost_full_on (adds) {x::'a \<Rightarrow>\<^sub>0 'b::add_wellorder. keys x \<subseteq> V}"
 proof (rule almost_full_onI)
   fix seq::"nat \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
   assume a: "\<forall>i. seq i \<in> {x::'a \<Rightarrow>\<^sub>0 'b. keys x \<subseteq> V}"
   define seq' where "seq' = (\<lambda>i. lookup (seq i))"
   from assms have "almost_full_on (adds) {x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> V}" by (rule Dickson_fun)
   moreover from a have "\<And>i. seq' i \<in> {x::'a \<Rightarrow> 'b. supp_fun x \<subseteq> V}"
     by (auto simp: seq'_def keys_eq_supp)
   ultimately obtain i j where "i < j" and "seq' i adds seq' j" by (rule almost_full_onD)
   from this(2) have "seq i adds seq j" by (simp add: seq'_def poly_mapping_adds_iff)
   with \<open>i < j\<close> show "good (adds) seq" by (rule goodI)
 qed
 
 definition varnum :: "'x set \<Rightarrow> ('x::countable \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> nat"
   where "varnum X t = (if keys t - X = {} then 0 else Suc (Max (elem_index ` (keys t - X))))"
 
 lemma elem_index_less_varnum:
   assumes "x \<in> keys t"
   obtains "x \<in> X" | "elem_index x < varnum X t"
 proof (cases "x \<in> X")
   case True
   thus ?thesis ..
 next
   case False
   with assms have 1: "x \<in> keys t - X" by simp
   hence "keys t - X \<noteq> {}" by blast
   hence eq: "varnum X t = Suc (Max (elem_index ` (keys t - X)))" by (simp add: varnum_def)
   hence "elem_index x < varnum X t" using 1 by (simp add: less_Suc_eq_le)
   thus ?thesis ..
 qed
 
 lemma varnum_plus:
   "varnum X (s + t) = max (varnum X s) (varnum X (t::'x::countable \<Rightarrow>\<^sub>0 'b::ninv_comm_monoid_add))"
 proof (simp add: varnum_def keys_plus_ninv_comm_monoid_add image_Un Un_Diff del: Diff_eq_empty_iff, intro impI)
   assume 1: "keys s - X \<noteq> {}" and 2: "keys t - X \<noteq> {}"
   have "finite (elem_index ` (keys s - X))" by simp
   moreover from 1 have "elem_index ` (keys s - X) \<noteq> {}" by simp
   moreover have "finite (elem_index ` (keys t - X))" by simp
   moreover from 2 have "elem_index ` (keys t - X) \<noteq> {}" by simp
   ultimately show "Max (elem_index ` (keys s - X) \<union> elem_index ` (keys t - X)) =
                     max (Max (elem_index ` (keys s - X))) (Max (elem_index ` (keys t - X)))"
     by (rule Max_Un)
 qed
 
 lemma dickson_grading_varnum:
   assumes "finite X"
   shows "dickson_grading ((varnum X)::('x::countable \<Rightarrow>\<^sub>0 'b::add_wellorder) \<Rightarrow> nat)"
   using varnum_plus
 proof (rule dickson_gradingI)
   fix m::nat
   let ?V = "X \<union> {x. elem_index x < m}"
   have "{t::'x \<Rightarrow>\<^sub>0 'b. varnum X t \<le> m} \<subseteq> {t. keys t \<subseteq> ?V}"
   proof (rule, simp, intro subsetI, simp)
     fix t::"'x \<Rightarrow>\<^sub>0 'b" and x::'x
     assume "varnum X t \<le> m"
     assume "x \<in> keys t"
     thus "x \<in> X \<or> elem_index x < m"
     proof (rule elem_index_less_varnum)
       assume "x \<in> X"
       thus ?thesis ..
     next
       assume "elem_index x < varnum X t"
       hence "elem_index x < m" using \<open>varnum X t \<le> m\<close> by (rule less_le_trans)
       thus ?thesis ..
     qed
   qed
   thus "almost_full_on (adds) {t::'x \<Rightarrow>\<^sub>0 'b. varnum X t \<le> m}"
   proof (rule almost_full_on_subset)
     from assms finite_nat_seg have "finite ?V" by (rule finite_UnI)
     thus "almost_full_on (adds) {t::'x \<Rightarrow>\<^sub>0 'b. keys t \<subseteq> ?V}" by (rule Dickson_poly_mapping)
   qed
 qed
 
 corollary dickson_grading_varnum_empty:
   "dickson_grading ((varnum {})::(_ \<Rightarrow>\<^sub>0 _::add_wellorder) \<Rightarrow> nat)"
   using finite.emptyI by (rule dickson_grading_varnum)
 
 lemma varnum_le_iff: "varnum X t \<le> n \<longleftrightarrow> keys t \<subseteq> X \<union> {x. elem_index x < n}"
   by (auto simp: varnum_def Suc_le_eq)
 
 lemma varnum_zero [simp]: "varnum X 0 = 0"
   by (simp add: varnum_def)
 
 lemma varnum_empty_eq_zero_iff: "varnum {} t = 0 \<longleftrightarrow> t = 0"
 proof
   assume "varnum {} t = 0"
   hence "keys t = {}" by (simp add: varnum_def split: if_splits)
   thus "t = 0" by (rule poly_mapping_eq_zeroI)
 qed simp
 
 instance poly_mapping :: (countable, add_wellorder) graded_dickson_powerprod
   by standard (rule, fact dickson_grading_varnum_empty)
 
 instance poly_mapping :: (finite, add_wellorder) dickson_powerprod
 proof
   have "finite (UNIV::'a set)" by simp
   hence "almost_full_on (adds) {x::'a \<Rightarrow>\<^sub>0 'b. keys x \<subseteq> UNIV}" by (rule Dickson_poly_mapping)
   thus "almost_full_on (adds) (UNIV::('a \<Rightarrow>\<^sub>0 'b) set)" by simp
 qed
 
 subsubsection \<open>Lexicographic Term Order\<close>
 
 definition lex_pm :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a::linorder \<Rightarrow>\<^sub>0 'b::{zero,linorder}) \<Rightarrow> bool"
   where "lex_pm = (\<le>)"
 
 definition lex_pm_strict :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a::linorder \<Rightarrow>\<^sub>0 'b::{zero,linorder}) \<Rightarrow> bool"
   where "lex_pm_strict = (<)"
 
 lemma lex_pm_alt: "lex_pm s t = (s = t \<or> (\<exists>x. lookup s x < lookup t x \<and> (\<forall>y<x. lookup s y = lookup t y)))"
   unfolding lex_pm_def by (metis less_eq_poly_mapping.rep_eq less_funE less_funI poly_mapping_eq_iff)
 
 lemma lex_pm_refl: "lex_pm s s"
   by (simp add: lex_pm_def)
 
 lemma lex_pm_antisym: "lex_pm s t \<Longrightarrow> lex_pm t s \<Longrightarrow> s = t"
   by (simp add: lex_pm_def)
 
 lemma lex_pm_trans: "lex_pm s t \<Longrightarrow> lex_pm t u \<Longrightarrow> lex_pm s u"
   by (simp add: lex_pm_def)
 
 lemma lex_pm_lin: "lex_pm s t \<or> lex_pm t s"
   by (simp add: lex_pm_def linear)
 
 corollary lex_pm_strict_alt [code]: "lex_pm_strict s t = (\<not> lex_pm t s)"
   by (auto simp: lex_pm_strict_def lex_pm_def)
 
 lemma lex_pm_zero_min: "lex_pm 0 s" for s::"_ \<Rightarrow>\<^sub>0 _::add_linorder_min"
 proof (rule ccontr)
   assume "\<not> lex_pm 0 s"
   hence "lex_pm_strict s 0" by (simp add: lex_pm_strict_alt)
   thus False by (simp add: lex_pm_strict_def less_poly_mapping.rep_eq less_fun_def)
 qed
 
 lemma lex_pm_plus_monotone: "lex_pm s t \<Longrightarrow> lex_pm (s + u) (t + u)"
   for s t::"_ \<Rightarrow>\<^sub>0 _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
   by (simp add: lex_pm_def add_right_mono)
 
 subsubsection \<open>Degree\<close>
 
 lift_definition deg_pm::"('a \<Rightarrow>\<^sub>0 'b::comm_monoid_add) \<Rightarrow> 'b" is deg_fun .
 
 lemma deg_pm_zero[simp]: "deg_pm 0 = 0"
   by (simp add: deg_pm.rep_eq lookup_zero_fun)
 
 lemma deg_pm_eq_0_iff[simp]: "deg_pm s = 0 \<longleftrightarrow> s = 0" for s::"'a \<Rightarrow>\<^sub>0 'b::add_linorder_min"
   by (simp only: deg_pm.rep_eq poly_mapping_eq_iff lookup_zero_fun, rule deg_fun_eq_0_iff,
       simp add: keys_eq_supp[symmetric])
 
 lemma deg_pm_superset:
   assumes "keys s \<subseteq> A" and "finite A"
   shows "deg_pm s = (\<Sum>x\<in>A. lookup s x)"
   using assms by (simp only: deg_pm.rep_eq keys_eq_supp, elim deg_fun_superset)
 
 lemma deg_pm_plus: "deg_pm (s + t) = deg_pm s + deg_pm (t::'a \<Rightarrow>\<^sub>0 'b::comm_monoid_add)"
   by (simp only: deg_pm.rep_eq lookup_plus_fun, rule deg_fun_plus, simp_all add: keys_eq_supp[symmetric])
 
 lemma deg_pm_single: "deg_pm (Poly_Mapping.single x k) = k"
 proof -
   have "keys (Poly_Mapping.single x k) \<subseteq> {x}" by simp
   moreover have "finite {x}" by simp
   ultimately have "deg_pm (Poly_Mapping.single x k) = (\<Sum>y\<in>{x}. lookup (Poly_Mapping.single x k) y)"
     by (rule deg_pm_superset)
   also have "... = k" by simp
   finally show ?thesis .
 qed
 
 subsubsection \<open>General Degree-Orders\<close>
 
 context linorder
 begin
 
 lift_definition dord_pm::"(('a \<Rightarrow>\<^sub>0 'b::ordered_comm_monoid_add) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool"
   is dord_fun by (metis local.dord_fun_def)
 
 lemma dord_pm_alt: "dord_pm ord = (\<lambda>x y. deg_pm x < deg_pm y \<or> (deg_pm x = deg_pm y \<and> ord x y))"
   by (intro ext) (transfer, simp add: dord_fun_def Let_def)
 
 lemma dord_pm_degD:
   assumes "dord_pm ord s t"
   shows "deg_pm s \<le> deg_pm t"
   using assms by (simp only: dord_pm.rep_eq deg_pm.rep_eq, elim dord_fun_degD)
 
 lemma dord_pm_refl:
   assumes "ord s s"
   shows "dord_pm ord s s"
   using assms by (simp only: dord_pm.rep_eq, intro dord_fun_refl, simp add: lookup_inverse)
 
 lemma dord_pm_antisym:
   assumes "ord s t \<Longrightarrow> ord t s \<Longrightarrow> s = t" and "dord_pm ord s t" and "dord_pm ord t s"
   shows "s = t"
   using assms
 proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
   assume 1: "(ord s t \<Longrightarrow> ord t s \<Longrightarrow> lookup s = lookup t)"
   assume 2: "dord_fun (map_fun Abs_poly_mapping id \<circ> ord \<circ> Abs_poly_mapping) (lookup s) (lookup t)"
   assume 3: "dord_fun (map_fun Abs_poly_mapping id \<circ> ord \<circ> Abs_poly_mapping) (lookup t) (lookup s)"
   from _ 2 3 show "lookup s = lookup t" by (rule dord_fun_antisym, simp add: lookup_inverse 1)
 qed
 
 lemma dord_pm_trans:
   assumes "ord s t \<Longrightarrow> ord t u \<Longrightarrow> ord s u" and "dord_pm ord s t" and "dord_pm ord t u"
   shows "dord_pm ord s u"
   using assms
 proof (simp only: dord_pm.rep_eq poly_mapping_eq_iff)
   assume 1: "(ord s t \<Longrightarrow> ord t u \<Longrightarrow> ord s u)"
   assume 2: "dord_fun (map_fun Abs_poly_mapping id \<circ> ord \<circ> Abs_poly_mapping) (lookup s) (lookup t)"
   assume 3: "dord_fun (map_fun Abs_poly_mapping id \<circ> ord \<circ> Abs_poly_mapping) (lookup t) (lookup u)"
   from _ 2 3 show "dord_fun (map_fun Abs_poly_mapping id \<circ> ord \<circ> Abs_poly_mapping) (lookup s) (lookup u)"
     by (rule dord_fun_trans, simp add: lookup_inverse 1)
 qed
 
 lemma dord_pm_lin:
   "dord_pm ord s t \<or> dord_pm ord t s"
   if "ord s t \<or> ord t s"
   for s t::"'a \<Rightarrow>\<^sub>0 'b::{ordered_comm_monoid_add, linorder}"
   using that by (simp only: dord_pm.rep_eq, intro dord_fun_lin, simp add: lookup_inverse)
 
 lemma dord_pm_zero_min: "dord_pm ord 0 s"
   if ord_refl: "\<And>t. ord t t"
   for s t::"'a \<Rightarrow>\<^sub>0 'b::add_linorder_min"
   using that
   by (simp only: dord_pm.rep_eq lookup_zero_fun, intro dord_fun_zero_min,
       simp add: lookup_inverse, simp add: keys_eq_supp[symmetric])
 
 lemma dord_pm_plus_monotone:
   fixes s t u ::"'a \<Rightarrow>\<^sub>0 'b::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}"
   assumes "ord s t \<Longrightarrow> ord (s + u) (t + u)" and "dord_pm ord s t"
   shows "dord_pm ord (s + u) (t + u)"
   using assms
   by (simp only: dord_pm.rep_eq lookup_plus_fun, intro dord_fun_plus_monotone,
       simp add: lookup_inverse lookup_plus_fun[symmetric],
       simp add: keys_eq_supp[symmetric],
       simp add: keys_eq_supp[symmetric],
       simp add: keys_eq_supp[symmetric],
       simp add: lookup_inverse)
 
 end (* linorder *)
 
 subsubsection \<open>Degree-Lexicographic Term Order\<close>
 
 definition dlex_pm::"('a::linorder \<Rightarrow>\<^sub>0 'b::{ordered_comm_monoid_add,linorder}) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool"
   where "dlex_pm \<equiv> dord_pm lex_pm"
 
 definition "dlex_pm_strict s t \<longleftrightarrow> dlex_pm s t \<and> \<not> dlex_pm t s"
 
 lemma dlex_pm_refl: "dlex_pm s s"
   unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_refl)
 
 lemma dlex_pm_antisym: "dlex_pm s t \<Longrightarrow> dlex_pm t s \<Longrightarrow> s = t"
   unfolding dlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)
 
 lemma dlex_pm_trans: "dlex_pm s t \<Longrightarrow> dlex_pm t u \<Longrightarrow> dlex_pm s u"
   unfolding dlex_pm_def using lex_pm_trans by (rule dord_pm_trans)
 
 lemma dlex_pm_lin: "dlex_pm s t \<or> dlex_pm t s"
   unfolding dlex_pm_def using lex_pm_lin by (rule dord_pm_lin)
 
 corollary dlex_pm_strict_alt [code]: "dlex_pm_strict s t = (\<not> dlex_pm t s)"
   unfolding dlex_pm_strict_def using dlex_pm_lin by auto
 
 lemma dlex_pm_zero_min: "dlex_pm 0 s"
   for s t::"(_ \<Rightarrow>\<^sub>0 _::add_linorder_min)"
   unfolding dlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)
 
 lemma dlex_pm_plus_monotone: "dlex_pm s t \<Longrightarrow> dlex_pm (s + u) (t + u)"
   for s t::"_ \<Rightarrow>\<^sub>0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
   unfolding dlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)
 
 subsubsection \<open>Degree-Reverse-Lexicographic Term Order\<close>
 
 definition drlex_pm::"('a::linorder \<Rightarrow>\<^sub>0 'b::{ordered_comm_monoid_add,linorder}) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> bool"
   where "drlex_pm \<equiv> dord_pm (\<lambda>s t. lex_pm t s)"
 
 definition "drlex_pm_strict s t \<longleftrightarrow> drlex_pm s t \<and> \<not> drlex_pm t s"
 
 lemma drlex_pm_refl: "drlex_pm s s"
   unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_refl)
 
 lemma drlex_pm_antisym: "drlex_pm s t \<Longrightarrow> drlex_pm t s \<Longrightarrow> s = t"
   unfolding drlex_pm_def using lex_pm_antisym by (rule dord_pm_antisym)
 
 lemma drlex_pm_trans: "drlex_pm s t \<Longrightarrow> drlex_pm t u \<Longrightarrow> drlex_pm s u"
   unfolding drlex_pm_def using lex_pm_trans by (rule dord_pm_trans)
 
 lemma drlex_pm_lin: "drlex_pm s t \<or> drlex_pm t s"
   unfolding drlex_pm_def using lex_pm_lin by (rule dord_pm_lin)
 
 corollary drlex_pm_strict_alt [code]: "drlex_pm_strict s t = (\<not> drlex_pm t s)"
   unfolding drlex_pm_strict_def using drlex_pm_lin by auto
 
 lemma drlex_pm_zero_min: "drlex_pm 0 s"
   for s t::"(_ \<Rightarrow>\<^sub>0 _::add_linorder_min)"
   unfolding drlex_pm_def using lex_pm_refl by (rule dord_pm_zero_min)
 
 lemma drlex_pm_plus_monotone: "drlex_pm s t \<Longrightarrow> drlex_pm (s + u) (t + u)"
   for s t::"_ \<Rightarrow>\<^sub>0 _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}"
   unfolding drlex_pm_def using lex_pm_plus_monotone by (rule dord_pm_plus_monotone)
 
 end (* theory *)
diff --git a/thys/Types_To_Sets_Extension/Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy b/thys/Types_To_Sets_Extension/Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy
--- a/thys/Types_To_Sets_Extension/Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy
+++ b/thys/Types_To_Sets_Extension/Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy
@@ -1,1708 +1,1696 @@
 (* Title: Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy
    Author: Mihails Milehins
    Copyright 2021 (C) Mihails Milehins
 *)
 section\<open>Relativization of the results about orders\<close>
 theory SML_Simple_Orders
   imports 
     "../../Introduction"
     "../Foundations/SML_Relations"
     Complex_Main
 begin
 
 
 
 subsection\<open>Class \<^class>\<open>ord\<close>\<close>
 
 
 subsubsection\<open>Definitions and common properties\<close>
 
 locale ord_ow =
   fixes U :: "'ao set"
     and le :: "['ao, 'ao] \<Rightarrow> bool" (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50) 
     and ls :: "['ao, 'ao] \<Rightarrow> bool" (infix \<open><\<^sub>o\<^sub>w\<close> 50)
 begin
 
 notation le (\<open>'(\<le>\<^sub>o\<^sub>w')\<close>)
   and le (infix \<open>\<le>\<^sub>o\<^sub>w\<close> 50) 
   and ls (\<open>'(<\<^sub>o\<^sub>w')\<close>) 
   and ls (infix \<open><\<^sub>o\<^sub>w\<close> 50)
 
 abbreviation (input) ge (infix \<open>\<ge>\<^sub>o\<^sub>w\<close> 50) where "x \<ge>\<^sub>o\<^sub>w y \<equiv> y \<le>\<^sub>o\<^sub>w x"
 abbreviation (input) gt (infix \<open>>\<^sub>o\<^sub>w\<close> 50) where "x >\<^sub>o\<^sub>w y \<equiv> y <\<^sub>o\<^sub>w x"
 
 notation ge (\<open>'(\<ge>\<^sub>o\<^sub>w')\<close>) 
   and ge (infix \<open>\<ge>\<^sub>o\<^sub>w\<close> 50) 
   and gt (\<open>'(>\<^sub>o\<^sub>w')\<close>) 
   and gt (infix \<open>>\<^sub>o\<^sub>w\<close> 50)
 
 tts_register_sbts \<open>(\<le>\<^sub>o\<^sub>w)\<close> | U
 proof-
   assume "Domainp AOA = (\<lambda>x. x \<in> U)" "bi_unique AOA" "right_total AOA" 
   from tts_AA_eq_transfer[OF this] show ?thesis by auto
 qed
 
 tts_register_sbts \<open>(<\<^sub>o\<^sub>w)\<close> | U
 proof-
   assume "Domainp AOA = (\<lambda>x. x \<in> U)" "bi_unique AOA" "right_total AOA" 
   from tts_AA_eq_transfer[OF this] show ?thesis by auto
 qed
 
 end
 
 locale ord_pair_ow = ord\<^sub>1: ord_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: ord_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
 begin
 
 notation le\<^sub>1 (\<open>'(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1')\<close>)
   and le\<^sub>1 (infix \<open>\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 50) 
   and ls\<^sub>1 (\<open>'(<\<^sub>o\<^sub>w\<^sub>.\<^sub>1')\<close>) 
   and ls\<^sub>1 (infix \<open><\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 50)
   and le\<^sub>2 (\<open>'(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2')\<close>)
   and le\<^sub>2 (infix \<open>\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 50) 
   and ls\<^sub>2 (\<open>'(<\<^sub>o\<^sub>w\<^sub>.\<^sub>2')\<close>) 
   and ls\<^sub>2 (infix \<open><\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 50)
 
 notation ord\<^sub>1.ge (\<open>'(\<ge>\<^sub>o\<^sub>w\<^sub>.\<^sub>1')\<close>) 
   and ord\<^sub>1.ge (infix \<open>\<ge>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 50) 
   and ord\<^sub>1.gt (\<open>'(>\<^sub>o\<^sub>w\<^sub>.\<^sub>1')\<close>) 
   and ord\<^sub>1.gt (infix \<open>>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close> 50)
   and ord\<^sub>2.ge (\<open>'(\<ge>\<^sub>o\<^sub>w\<^sub>.\<^sub>2')\<close>) 
   and ord\<^sub>2.ge (infix \<open>\<ge>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 50) 
   and ord\<^sub>2.gt (\<open>'(>\<^sub>o\<^sub>w\<^sub>.\<^sub>2')\<close>) 
   and ord\<^sub>2.gt (infix \<open>>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close> 50)
 
 end
 
 ud \<open>ord.lessThan\<close> (\<open>(with _ : ({..<_}))\<close> [1000] 10)
 ud lessThan' \<open>lessThan\<close> 
 ud \<open>ord.atMost\<close> (\<open>(with _ : ({.._}))\<close> [1000] 10) 
 ud atMost' \<open>atMost\<close> 
 ud \<open>ord.greaterThan\<close> (\<open>(with _ : ({_<..}))\<close> [1000] 10) 
 ud greaterThan' \<open>greaterThan\<close> 
 ud \<open>ord.atLeast\<close> (\<open>(with _ : ({_..}))\<close> [1000] 10) 
 ud atLeast' \<open>atLeast\<close> 
 ud \<open>ord.greaterThanLessThan\<close> (\<open>(with _ : ({_<..<_}))\<close> [1000, 999, 1000] 10) 
 ud greaterThanLessThan' \<open>greaterThanLessThan\<close> 
 ud \<open>ord.atLeastLessThan\<close> (\<open>(with _ _ : ({_..<_}))\<close> [1000, 999, 1000, 1000] 10)
 ud atLeastLessThan' \<open>atLeastLessThan\<close> 
 ud \<open>ord.greaterThanAtMost\<close> (\<open>(with _ _ : ({_<.._}))\<close> [1000, 999, 1000, 999] 10) 
 ud greaterThanAtMost' \<open>greaterThanAtMost\<close> 
 ud \<open>ord.atLeastAtMost\<close> (\<open>(with _ : ({_.._}))\<close> [1000, 1000, 1000] 10) 
 ud atLeastAtMost' \<open>atLeastAtMost\<close> 
 ud \<open>ord.min\<close> (\<open>(with _ : \<guillemotleft>min\<guillemotright> _ _)\<close> [1000, 1000, 999] 10)
 ud min' \<open>min\<close> 
 ud \<open>ord.max\<close> (\<open>(with _ : \<guillemotleft>max\<guillemotright> _ _)\<close> [1000, 1000, 999] 10)
 ud max' \<open>max\<close>
 
 ctr relativization
   synthesis ctr_simps
   assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
     and [transfer_rule]: "right_total A" 
   trp (?'a A)
   in lessThan_ow: lessThan.with_def 
     (\<open>(on _ with _ : ({..<_}))\<close> [1000, 1000, 1000] 10) 
     and atMost_ow: atMost.with_def 
       (\<open>(on _ with _ : ({.._}))\<close> [1000, 1000, 1000] 10) 
     and greaterThan_ow: greaterThan.with_def
       (\<open>(on _ with _: ({_<..}))\<close> [1000, 1000, 1000] 10) 
     and atLeast_ow: atLeast.with_def
       (\<open>(on _ with _ : ({_..}))\<close> [1000, 1000, 1000] 10) 
 
 ctr relativization
   synthesis ctr_simps
   assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
     and [transfer_rule]: "bi_unique A" "right_total A" 
   trp (?'a A)
   in greaterThanLessThan_ow: greaterThanLessThan.with_def 
       (\<open>(on _ with _ : ({_<..<_}))\<close> [1000, 1000, 1000, 1000] 10) 
     and atLeastLessThan_ow: atLeastLessThan.with_def 
       (\<open>(on _ with _ _ : ({_..<_}))\<close> [1000, 1000, 999, 1000, 1000] 10)
     and greaterThanAtMost_ow: greaterThanAtMost.with_def 
       (\<open>(on _ with _ _ : ({_<.._}))\<close> [1000, 1000, 999, 1000, 1000] 10) 
     and atLeastAtMost_ow: atLeastAtMost.with_def 
       (\<open>(on _ with _ : ({_.._}))\<close> [1000, 1000, 1000, 1000] 10)
 
 ctr parametricity
   in min_ow: min.with_def
     and max_ow: max.with_def
 
 context ord_ow
 begin
 
 abbreviation lessThan :: "'ao \<Rightarrow> 'ao set" ("(1{..<\<^sub>o\<^sub>w_})") 
   where "{..<\<^sub>o\<^sub>w u} \<equiv> on U with (<\<^sub>o\<^sub>w) : {..<u}"
 abbreviation atMost :: "'ao \<Rightarrow> 'ao set" ("(1{..\<^sub>o\<^sub>w_})") 
   where "{..\<^sub>o\<^sub>w u} \<equiv> on U with (\<le>\<^sub>o\<^sub>w) : {..u}"
 abbreviation greaterThan :: "'ao \<Rightarrow> 'ao set" ("(1{_<\<^sub>o\<^sub>w..})")  
   where "{l<\<^sub>o\<^sub>w..} \<equiv> on U with (<\<^sub>o\<^sub>w) : {l<..}"
 abbreviation atLeast :: "'ao \<Rightarrow> 'ao set" ("(1{_..\<^sub>o\<^sub>w})") 
   where "atLeast l \<equiv> on U with (\<le>\<^sub>o\<^sub>w) : {l..}"
 abbreviation greaterThanLessThan :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao set" ("(1{_<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>w_})")
   where "{l<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wu} \<equiv> on U with (<\<^sub>o\<^sub>w) : {l<..<u}"
 abbreviation atLeastLessThan :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao set" ("(1{_..<\<^sub>o\<^sub>w_})")
   where "{l..<\<^sub>o\<^sub>w u} \<equiv> on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l<..u}"
 abbreviation greaterThanAtMost :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao set" ("(1{_<\<^sub>o\<^sub>w.._})")
   where "{l<\<^sub>o\<^sub>w..u}  \<equiv> on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l<..u}"
 abbreviation atLeastAtMost :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao set" ("(1{_..\<^sub>o\<^sub>w_})")
   where "{l..\<^sub>o\<^sub>wu} \<equiv> on U with (\<le>\<^sub>o\<^sub>w) : {l..u}"
 abbreviation min :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao" where "min \<equiv> min.with (\<le>\<^sub>o\<^sub>w)"
 abbreviation max :: "'ao \<Rightarrow> 'ao \<Rightarrow> 'ao" where "max \<equiv> max.with (\<le>\<^sub>o\<^sub>w)"
 
 end
 
 context ord_pair_ow
 begin
 
 notation ord\<^sub>1.lessThan ("(1{..<\<^sub>o\<^sub>w\<^sub>.\<^sub>1_})") 
 notation ord\<^sub>1.atMost ("(1{..\<^sub>o\<^sub>w\<^sub>.\<^sub>1_})") 
 notation ord\<^sub>1.greaterThan ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>1..})")  
 notation ord\<^sub>1.atLeast ("(1{_..\<^sub>o\<^sub>w\<^sub>.\<^sub>1})") 
 notation ord\<^sub>1.greaterThanLessThan ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>1..<\<^sub>o\<^sub>w\<^sub>.\<^sub>1_})")
 notation ord\<^sub>1.atLeastLessThan ("(1{_..<\<^sub>o\<^sub>w\<^sub>.\<^sub>1_})")
 notation ord\<^sub>1.greaterThanAtMost ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>1.._})")
 notation ord\<^sub>1.atLeastAtMost ("(1{_..\<^sub>o\<^sub>w\<^sub>.\<^sub>1_})")
 
 notation ord\<^sub>2.lessThan ("(1{..<\<^sub>o\<^sub>w\<^sub>.\<^sub>2_})") 
 notation ord\<^sub>2.atMost ("(1{..\<^sub>o\<^sub>w\<^sub>.\<^sub>2_})") 
 notation ord\<^sub>2.greaterThan ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>2..})")  
 notation ord\<^sub>2.atLeast ("(1{_..\<^sub>o\<^sub>w\<^sub>.\<^sub>2})") 
 notation ord\<^sub>2.greaterThanLessThan ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>2..<\<^sub>o\<^sub>w\<^sub>.\<^sub>2_})")
 notation ord\<^sub>2.atLeastLessThan ("(1{_..<\<^sub>o\<^sub>w\<^sub>.\<^sub>2_})")
 notation ord\<^sub>2.greaterThanAtMost ("(1{_<\<^sub>o\<^sub>w\<^sub>.\<^sub>2.._})")
 notation ord\<^sub>2.atLeastAtMost ("(1{_..\<^sub>o\<^sub>w\<^sub>.\<^sub>2_})")
 
 end
 
 
 
 subsection\<open>Preorders\<close>
 
 
 subsubsection\<open>Definitions and common properties\<close>
 
 locale partial_preordering_ow =
   fixes U :: "'ao set"
     and le :: "'ao \<Rightarrow> 'ao \<Rightarrow> bool" (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
   assumes refl: "a \<in> U \<Longrightarrow> a \<^bold>\<le>\<^sub>o\<^sub>w a"
     and trans: "\<lbrakk> a \<in> U; b \<in> U; c \<in> U; a \<^bold>\<le>\<^sub>o\<^sub>w b; b \<^bold>\<le>\<^sub>o\<^sub>w c \<rbrakk> \<Longrightarrow> a \<^bold>\<le>\<^sub>o\<^sub>w c"
 begin
 
 notation le (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
 
 end
 
 locale preordering_ow = partial_preordering_ow U le 
   for U :: "'ao set"
     and le :: "'ao \<Rightarrow> 'ao \<Rightarrow> bool" (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50) +
   fixes ls :: \<open>'ao \<Rightarrow> 'ao \<Rightarrow> bool\<close> (infix "\<^bold><\<^sub>o\<^sub>w" 50)
   assumes strict_iff_not: 
     "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<^bold><\<^sub>o\<^sub>w b \<longleftrightarrow> a \<^bold>\<le>\<^sub>o\<^sub>w b \<and> \<not> b \<^bold>\<le>\<^sub>o\<^sub>w a"
 
 locale preorder_ow = ord_ow U le ls 
   for U :: "'ao set" and le ls +
   assumes less_le_not_le: 
     "\<lbrakk> x \<in> U; y \<in> U \<rbrakk> \<Longrightarrow> x <\<^sub>o\<^sub>w y \<longleftrightarrow> x \<le>\<^sub>o\<^sub>w y \<and> \<not> (y \<le>\<^sub>o\<^sub>w x)"
     and order_refl[iff]: "x \<in> U \<Longrightarrow> x \<le>\<^sub>o\<^sub>w x"
     and order_trans: "\<lbrakk> x \<in> U; y \<in> U; z \<in> U; x \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w z \<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w z"
 begin
 
 sublocale 
   order: preordering_ow U \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> + 
   dual_order: preordering_ow U \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close>
   apply unfold_locales
   subgoal by auto
   subgoal by (meson order_trans)
   subgoal using less_le_not_le by simp
   subgoal by (meson order_trans)
   subgoal by (metis less_le_not_le)
   done
 
 end
 
 locale ord_preorder_ow = 
   ord\<^sub>1: ord_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: preorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
 begin
 
 sublocale ord_pair_ow .
 
 end
 
 locale preorder_pair_ow = 
   ord\<^sub>1: preorder_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: preorder_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 and ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 and ls\<^sub>2
 begin
 
 sublocale ord_preorder_ow ..
 
 end
 
 ud \<open>preordering_bdd.bdd\<close>
 ud \<open>preorder.bdd_above\<close>
 ud bdd_above' \<open>bdd_above\<close> 
 ud \<open>preorder.bdd_below\<close> 
 ud bdd_below' \<open>bdd_below\<close> 
 
 ctr relativization
   synthesis ctr_simps
   assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (\<lambda>x. x \<in> U)"
     and [transfer_rule]: "right_total A"
   trp (?'a A)
   in bdd_ow: bdd.with_def
     (\<open>(on _ with _ : \<guillemotleft>bdd\<guillemotright> _)\<close> [1000, 1000, 1000] 10)
     and bdd_above_ow: bdd_above.with_def
     (\<open>(on _ with _ : \<guillemotleft>bdd'_above\<guillemotright> _)\<close> [1000, 1000, 1000] 10)
     and bdd_below_ow: bdd_below.with_def
     (\<open>(on _ with _ : \<guillemotleft>bdd'_below\<guillemotright> _)\<close> [1000, 1000, 1000] 10)
 
 declare bdd.with[ud_with del]
 
 context preorder_ow
 begin
 
 abbreviation bdd_above :: "'ao set \<Rightarrow> bool" 
   where "bdd_above \<equiv> bdd_above_ow U (\<le>\<^sub>o\<^sub>w)"
 abbreviation bdd_below :: "'ao set \<Rightarrow> bool" 
   where "bdd_below \<equiv> bdd_below_ow U (\<le>\<^sub>o\<^sub>w)"
 
 end
 
 
 subsubsection\<open>Transfer rules\<close>
 
 context
   includes lifting_syntax
 begin
 
 lemma partial_preordering_transfer[transfer_rule]:
   assumes [transfer_rule]: "right_total A"
   shows 
     "((A ===> A ===> (=)) ===> (=))
       (partial_preordering_ow (Collect (Domainp A))) partial_preordering"
   unfolding partial_preordering_ow_def partial_preordering_def
   apply transfer_prover_start
   apply transfer_step+
   by blast
 
 lemma preordering_transfer[transfer_rule]:
   assumes [transfer_rule]: "right_total A"
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))
       (preordering_ow (Collect (Domainp A))) preordering"
   unfolding 
     preordering_ow_def preordering_ow_axioms_def 
     preordering_def preordering_axioms_def
   apply transfer_prover_start
   apply transfer_step+
   by blast
 
 lemma preorder_transfer[transfer_rule]:
   assumes [transfer_rule]: "right_total A"
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=))  ===> (=)) 
       (preorder_ow (Collect (Domainp A))) class.preorder"
   unfolding preorder_ow_def class.preorder_def
   apply transfer_prover_start
   apply transfer_step+
   by blast
 
 end
 
 
 subsubsection\<open>Relativization\<close>
 
 context preordering_ow
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting preordering_ow_axioms
   eliminating through auto
 begin
 
 tts_lemma strict_implies_order:
   assumes "a \<in> U" and "b \<in> U" and "a \<^bold><\<^sub>o\<^sub>w b"
   shows "a \<^bold>\<le>\<^sub>o\<^sub>w b"
     is preordering.strict_implies_order.
 
 tts_lemma irrefl:
   assumes "a \<in> U"
   shows "\<not>a \<^bold><\<^sub>o\<^sub>w a"
     is preordering.irrefl.
 
 tts_lemma asym:
   assumes "a \<in> U" and "b \<in> U" and "a \<^bold><\<^sub>o\<^sub>w b" and "b \<^bold><\<^sub>o\<^sub>w a"
   shows False
     is preordering.asym.
 
 tts_lemma strict_trans1:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<^bold>\<le>\<^sub>o\<^sub>w b" and "b \<^bold><\<^sub>o\<^sub>w c"
   shows "a \<^bold><\<^sub>o\<^sub>w c"
     is preordering.strict_trans1.
 
 tts_lemma strict_trans2:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<^bold><\<^sub>o\<^sub>w b" and "b \<^bold>\<le>\<^sub>o\<^sub>w c"
   shows "a \<^bold><\<^sub>o\<^sub>w c"
     is preordering.strict_trans2.
 
 tts_lemma strict_trans:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "a \<^bold><\<^sub>o\<^sub>w b" and "b \<^bold><\<^sub>o\<^sub>w c"
   shows "a \<^bold><\<^sub>o\<^sub>w c"
     is preordering.strict_trans.
 
 end
 
 end
 
 context preorder_ow
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting preorder_ow_axioms
   eliminating through auto
 begin
 
 tts_lemma less_irrefl:
   assumes "x \<in> U"
   shows "\<not> x <\<^sub>o\<^sub>w x"
   is preorder_class.less_irrefl.
     
 tts_lemma bdd_below_Ioc:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_below {a<\<^sub>o\<^sub>w..b}"
   is preorder_class.bdd_below_Ioc.
     
 tts_lemma bdd_above_Ioc:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_above {a<\<^sub>o\<^sub>w..b}"
     is preorder_class.bdd_above_Ioc.
 
 tts_lemma bdd_above_Iic:
   assumes "b \<in> U"
   shows "bdd_above {..\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_above_Iic.
 
 tts_lemma bdd_above_Iio:
   assumes "b \<in> U"
   shows "bdd_above {..<\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_above_Iio.
 
 tts_lemma bdd_below_Ici:
   assumes "a \<in> U"
   shows "bdd_below {a..\<^sub>o\<^sub>w}"
     is preorder_class.bdd_below_Ici.
 
 tts_lemma bdd_below_Ioi:
   assumes "a \<in> U"
   shows "bdd_below {a<\<^sub>o\<^sub>w..}"
     is preorder_class.bdd_below_Ioi.
 
 tts_lemma bdd_above_Icc:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_above {a..\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_above_Icc.
 
 tts_lemma bdd_above_Ioo:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_above {a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_above_Ioo.
 
 tts_lemma bdd_below_Icc:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_below {a..\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_below_Icc.
 
 tts_lemma bdd_below_Ioo:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_below {a<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wb}"
     is preorder_class.bdd_below_Ioo.
 
 tts_lemma bdd_above_Ico:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_above (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b})"
     is preorder_class.bdd_above_Ico.
 
 tts_lemma bdd_below_Ico:
   assumes "a \<in> U" and "b \<in> U"
   shows "bdd_below (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b})"
     is preorder_class.bdd_below_Ico.
 
 tts_lemma Ioi_le_Ico:
   assumes "a \<in> U"
   shows "{a<\<^sub>o\<^sub>w..} \<subseteq> {a..\<^sub>o\<^sub>w}"
     is preorder_class.Ioi_le_Ico.
 
 tts_lemma eq_refl:
   assumes "y \<in> U" and "x = y"
   shows "x \<le>\<^sub>o\<^sub>w y"
     is preorder_class.eq_refl.
 
 tts_lemma less_imp_le:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "x \<le>\<^sub>o\<^sub>w y"
     is preorder_class.less_imp_le.
 
 tts_lemma less_not_sym:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "\<not> y <\<^sub>o\<^sub>w x"
     is preorder_class.less_not_sym.
 
 tts_lemma less_imp_not_less:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "(\<not> y <\<^sub>o\<^sub>w x) = True"
     is preorder_class.less_imp_not_less.
 
 tts_lemma less_asym':
   assumes "a \<in> U" and "b \<in> U" and "a <\<^sub>o\<^sub>w b" and "b <\<^sub>o\<^sub>w a"
   shows P
     is preorder_class.less_asym'.
 
 tts_lemma less_imp_triv:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "(y <\<^sub>o\<^sub>w x \<longrightarrow> P) = True"
     is preorder_class.less_imp_triv.
 
 tts_lemma less_trans:
   assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x <\<^sub>o\<^sub>w y" and "y <\<^sub>o\<^sub>w z"
   shows "x <\<^sub>o\<^sub>w z"
     is preorder_class.less_trans.
 
 tts_lemma less_le_trans:
   assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x <\<^sub>o\<^sub>w y" and "y \<le>\<^sub>o\<^sub>w z"
   shows "x <\<^sub>o\<^sub>w z"
     is preorder_class.less_le_trans.
 
 tts_lemma le_less_trans:
   assumes "x \<in> U" and "y \<in> U" and "z \<in> U" and "x \<le>\<^sub>o\<^sub>w y" and "y <\<^sub>o\<^sub>w z"
   shows "x <\<^sub>o\<^sub>w z"
     is preorder_class.le_less_trans.
 
 tts_lemma bdd_aboveI:
   assumes "A \<subseteq> U" and "M \<in> U" and "\<And>x. \<lbrakk>x \<in> U; x \<in> A\<rbrakk> \<Longrightarrow> x \<le>\<^sub>o\<^sub>w M"
   shows "bdd_above A"
     is preorder_class.bdd_aboveI.
 
 tts_lemma bdd_belowI:
   assumes "A \<subseteq> U" and "m \<in> U" and "\<And>x. \<lbrakk>x \<in> U; x \<in> A\<rbrakk> \<Longrightarrow> m \<le>\<^sub>o\<^sub>w x"
   shows "bdd_below A"
     is preorder_class.bdd_belowI.
 
 tts_lemma less_asym:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y" and "\<not> P \<Longrightarrow> y <\<^sub>o\<^sub>w x"
   shows P
     is preorder_class.less_asym.
 
-tts_lemma transp_less: "transp_on U (<\<^sub>o\<^sub>w)"
-  is preorder_class.transp_less.
-
-tts_lemma transp_le: "transp_on U (\<le>\<^sub>o\<^sub>w)"
-  is preorder_class.transp_le.
-
-tts_lemma transp_gr: "transp_on U (\<lambda>x y. y <\<^sub>o\<^sub>w x)"
-  is preorder_class.transp_gr.
-
-tts_lemma transp_ge: "transp_on U (\<lambda>x y. y \<le>\<^sub>o\<^sub>w x)"
-  is preorder_class.transp_ge.
-
 tts_lemma bdd_above_Int1:
   assumes "A \<subseteq> U" and "B \<subseteq> U" and "bdd_above A"
   shows "bdd_above (A \<inter> B)"
     is preorder_class.bdd_above_Int1.
 
 tts_lemma bdd_above_Int2:
   assumes "B \<subseteq> U" and "A \<subseteq> U" and "bdd_above B"
   shows "bdd_above (A \<inter> B)"
     is preorder_class.bdd_above_Int2.
 
 tts_lemma bdd_below_Int1:
   assumes "A \<subseteq> U" and "B \<subseteq> U" and "bdd_below A"
   shows "bdd_below (A \<inter> B)"
     is preorder_class.bdd_below_Int1.
 
 tts_lemma bdd_below_Int2:
   assumes "B \<subseteq> U" and "A \<subseteq> U" and "bdd_below B"
   shows "bdd_below (A \<inter> B)"
     is preorder_class.bdd_below_Int2.
 
 tts_lemma bdd_above_mono:
   assumes "B \<subseteq> U" and "bdd_above B" and "A \<subseteq> B"
   shows "bdd_above A"
     is preorder_class.bdd_above_mono.
 
 tts_lemma bdd_below_mono:
   assumes "B \<subseteq> U" and "bdd_below B" and "A \<subseteq> B"
   shows "bdd_below A"
     is preorder_class.bdd_below_mono.
 
 tts_lemma atLeastAtMost_subseteq_atLeastLessThan_iff:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
   shows "({a..\<^sub>o\<^sub>wb} \<subseteq> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {c..<d})) = 
     (a \<le>\<^sub>o\<^sub>w b \<longrightarrow> b <\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
     is preorder_class.atLeastAtMost_subseteq_atLeastLessThan_iff.
 
 tts_lemma atMost_subset_iff:
   assumes "x \<in> U" and "y \<in> U"
   shows "({..\<^sub>o\<^sub>wx} \<subseteq> {..\<^sub>o\<^sub>wy}) = (x \<le>\<^sub>o\<^sub>w y)"
     is Set_Interval.atMost_subset_iff.
 
 tts_lemma single_Diff_lessThan:
   assumes "k \<in> U"
   shows "{k} - {..<\<^sub>o\<^sub>wk} = {k}"
   is Set_Interval.single_Diff_lessThan.
 
 tts_lemma atLeast_subset_iff:
   assumes "x \<in> U" and "y \<in> U"
   shows "({x..\<^sub>o\<^sub>w} \<subseteq> {y..\<^sub>o\<^sub>w}) = (y \<le>\<^sub>o\<^sub>w x)"
     is Set_Interval.atLeast_subset_iff.
 
 tts_lemma atLeastatMost_psubset_iff:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
   shows 
     "({a..\<^sub>o\<^sub>wb} \<subset> {c..\<^sub>o\<^sub>wd}) = 
       (c \<le>\<^sub>o\<^sub>w d \<and> (\<not> a \<le>\<^sub>o\<^sub>w b \<or> c \<le>\<^sub>o\<^sub>w a \<and> b \<le>\<^sub>o\<^sub>w d \<and> (c <\<^sub>o\<^sub>w a \<or> b <\<^sub>o\<^sub>w d)))"
     is preorder_class.atLeastatMost_psubset_iff.
 
 tts_lemma not_empty_eq_Iic_eq_empty:
   assumes "h \<in> U"
   shows "{} \<noteq> {..\<^sub>o\<^sub>wh}"
     is preorder_class.not_empty_eq_Iic_eq_empty.
     
 tts_lemma atLeastatMost_subset_iff:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U"
   shows "({a..\<^sub>o\<^sub>wb} \<subseteq> {c..\<^sub>o\<^sub>wd}) = (\<not> a \<le>\<^sub>o\<^sub>w b \<or> b \<le>\<^sub>o\<^sub>w d \<and> c \<le>\<^sub>o\<^sub>w a)"
     is preorder_class.atLeastatMost_subset_iff.
 
 tts_lemma Icc_subset_Ici_iff:
   assumes "l \<in> U" and "h \<in> U" and "l' \<in> U"
   shows "({l..\<^sub>o\<^sub>wh} \<subseteq> {l'..\<^sub>o\<^sub>w}) = (\<not> l \<le>\<^sub>o\<^sub>w h \<or> l' \<le>\<^sub>o\<^sub>w l)"
     is preorder_class.Icc_subset_Ici_iff.
     
 tts_lemma Icc_subset_Iic_iff:
   assumes "l \<in> U" and "h \<in> U" and "h' \<in> U"
   shows "({l..\<^sub>o\<^sub>wh} \<subseteq> {..\<^sub>o\<^sub>wh'}) = (\<not> l \<le>\<^sub>o\<^sub>w h \<or> h \<le>\<^sub>o\<^sub>w h')"
     is preorder_class.Icc_subset_Iic_iff.
 
 tts_lemma not_empty_eq_Ici_eq_empty:
   assumes "l \<in> U"
   shows "{} \<noteq> {l..\<^sub>o\<^sub>w}"
   is preorder_class.not_empty_eq_Ici_eq_empty.
     
 tts_lemma not_Ici_eq_empty:
   assumes "l \<in> U"
   shows "{l..\<^sub>o\<^sub>w} \<noteq> {}"
 is preorder_class.not_Ici_eq_empty.
     
 tts_lemma not_Iic_eq_empty:
   assumes "h \<in> U"
   shows "{..\<^sub>o\<^sub>wh} \<noteq> {}"
     is preorder_class.not_Iic_eq_empty.
 
 tts_lemma atLeastatMost_empty_iff2:
   assumes "a \<in> U" and "b \<in> U"
   shows "({} = {a..\<^sub>o\<^sub>wb}) = (\<not> a \<le>\<^sub>o\<^sub>w b)"
     is preorder_class.atLeastatMost_empty_iff2.
     
 tts_lemma atLeastLessThan_empty_iff2:
   assumes "a \<in> U" and "b \<in> U"
   shows "({} = (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b})) = (\<not> a <\<^sub>o\<^sub>w b)"
     is preorder_class.atLeastLessThan_empty_iff2.
     
 tts_lemma greaterThanAtMost_empty_iff2:
   assumes "k \<in> U" and "l \<in> U"
   shows "({} = {k<\<^sub>o\<^sub>w..l}) = (\<not> k <\<^sub>o\<^sub>w l)"
     is preorder_class.greaterThanAtMost_empty_iff2.
     
 tts_lemma atLeastatMost_empty_iff:
   assumes "a \<in> U" and "b \<in> U"
   shows "({a..\<^sub>o\<^sub>wb} = {}) = (\<not> a \<le>\<^sub>o\<^sub>w b)"
     is preorder_class.atLeastatMost_empty_iff.
     
 tts_lemma atLeastLessThan_empty_iff:
   assumes "a \<in> U" and "b \<in> U"
   shows "((on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) = {}) = (\<not> a <\<^sub>o\<^sub>w b)"
     is preorder_class.atLeastLessThan_empty_iff.
     
 tts_lemma greaterThanAtMost_empty_iff:
   assumes "k \<in> U" and "l \<in> U"
   shows "({k<\<^sub>o\<^sub>w..l} = {}) = (\<not> k <\<^sub>o\<^sub>w l)"
     is preorder_class.greaterThanAtMost_empty_iff.
 
 end
 
 tts_context
   tts: (?'a to U)
   substituting preorder_ow_axioms
 begin
 
 tts_lemma bdd_above_empty:
   assumes "U \<noteq> {}"
   shows "bdd_above {}"
     is preorder_class.bdd_above_empty.
     
 tts_lemma bdd_below_empty:
   assumes "U \<noteq> {}"
   shows "bdd_below {}"
     is preorder_class.bdd_below_empty.
     
 end
 
 tts_context
   tts: (?'a to U) and (?'b to \<open>U\<^sub>2::'a set\<close>)
   rewriting ctr_simps
   substituting preorder_ow_axioms
   eliminating through (auto intro: bdd_above_empty bdd_below_empty)
 begin
 
 tts_lemma bdd_belowI2:
   assumes "A \<subseteq> U\<^sub>2"
     and "m \<in> U"
     and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
     and "\<And>x. x \<in> A \<Longrightarrow> m \<le>\<^sub>o\<^sub>w f x"
   shows "bdd_below (f ` A)"
     given preorder_class.bdd_belowI2
   by blast
 
 tts_lemma bdd_aboveI2:
   assumes "A \<subseteq> U\<^sub>2"
     and "\<forall>x\<in>U\<^sub>2. f x \<in> U"
     and "M \<in> U"
     and "\<And>x. x \<in> A \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w M"
   shows "bdd_above (f ` A)"
     given preorder_class.bdd_aboveI2
   by blast
     
 end
 
 end
 
 
 
 subsection\<open>Partial orders\<close>
 
 
 subsubsection\<open>Definitions and common properties\<close>
 
 locale ordering_ow = partial_preordering_ow U le 
   for U :: "'ao set" and le :: "'ao \<Rightarrow> 'ao \<Rightarrow> bool" (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50) +
   fixes ls :: "'ao \<Rightarrow> 'ao \<Rightarrow> bool" (infix "\<^bold><\<^sub>o\<^sub>w" 50)
   assumes strict_iff_order: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<^bold><\<^sub>o\<^sub>w b \<longleftrightarrow> a \<^bold>\<le>\<^sub>o\<^sub>w b \<and> a \<noteq> b"
     and antisym: "\<lbrakk> a \<in> U; b \<in> U; a \<^bold>\<le>\<^sub>o\<^sub>w b; b \<^bold>\<le>\<^sub>o\<^sub>w a \<rbrakk> \<Longrightarrow> a = b"
 begin
 
 notation le (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
   and ls (infix "\<^bold><\<^sub>o\<^sub>w" 50)
 
 sublocale preordering_ow U \<open>(\<^bold>\<le>\<^sub>o\<^sub>w)\<close> \<open>(\<^bold><\<^sub>o\<^sub>w)\<close>  
   using local.antisym strict_iff_order by unfold_locales blast
 
 end
 
 locale order_ow = preorder_ow U le ls for U :: "'ao set" and le ls +
   assumes antisym: "\<lbrakk> x \<in> U; y \<in> U; x \<le>\<^sub>o\<^sub>w y; y \<le>\<^sub>o\<^sub>w x \<rbrakk> \<Longrightarrow> x = y" 
 begin
 
 sublocale 
   order: ordering_ow U \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> + 
   dual_order: ordering_ow U \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close>
   apply unfold_locales
   subgoal by (force simp: less_le_not_le antisym)
   subgoal by (simp add: antisym)
   subgoal by (force simp: less_le_not_le antisym)
   subgoal by (simp add: antisym)
   done
 
 no_notation le (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
   and ls (infix "\<^bold><\<^sub>o\<^sub>w" 50)
 
 end
 
 locale ord_order_ow = ord\<^sub>1: ord_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: order_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
 
 sublocale ord_order_ow \<subseteq> ord_preorder_ow ..
 
 locale preorder_order_ow =
   ord\<^sub>1: preorder_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: order_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
 
 sublocale preorder_order_ow \<subseteq> preorder_pair_ow ..
 
 locale order_pair_ow = ord\<^sub>1: order_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: order_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2
 
 sublocale order_pair_ow \<subseteq> preorder_order_ow ..
 
 ud \<open>monoseq\<close> (\<open>(with _ : \<guillemotleft>monoseq\<guillemotright> _)\<close> [1000, 1000] 10)
 
 ctr relativization
   synthesis ctr_simps
   assumes [transfer_domain_rule, transfer_rule]: 
     "Domainp (B::'c\<Rightarrow>'d\<Rightarrow>bool) = (\<lambda>x. x \<in> U\<^sub>2)"
     and [transfer_rule]: "right_total B" 
   trp (?'b \<open>A::'a\<Rightarrow>'b\<Rightarrow>bool\<close>) and (?'a B)
   in  monoseq_ow: monoseq.with_def
 
 
 subsubsection\<open>Transfer rules\<close>
 
 context
   includes lifting_syntax
 begin
 
 lemma ordering_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A" 
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
       (ordering_ow (Collect (Domainp A))) ordering"
   unfolding ordering_ow_def ordering_ow_axioms_def ordering_def ordering_axioms_def 
   apply transfer_prover_start
   apply transfer_step+
   unfolding Ball_Collect[symmetric]
   by (intro ext HOL.arg_cong2[where f="(\<and>)"]) auto
 
 lemma order_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A" 
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
       (order_ow (Collect (Domainp A))) class.order"
   unfolding 
     order_ow_def class.order_def order_ow_axioms_def class.order_axioms_def
   apply transfer_prover_start
   apply transfer_step+
   by simp
 
 end
 
 
 subsubsection\<open>Relativization\<close>
 
 context ordering_ow
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting ordering_ow_axioms
   eliminating through simp
 begin
 
 tts_lemma strict_implies_not_eq:
   assumes "a \<in> U" and "b \<in> U" and "a \<^bold><\<^sub>o\<^sub>w b"
   shows "a \<noteq> b"
     is ordering.strict_implies_not_eq.
     
 tts_lemma order_iff_strict:
   assumes "a \<in> U" and "b \<in> U"
   shows "(a \<^bold>\<le>\<^sub>o\<^sub>w b) = (a \<^bold><\<^sub>o\<^sub>w b \<or> a = b)"
     is ordering.order_iff_strict.
    
 tts_lemma not_eq_order_implies_strict:
   assumes "a \<in> U" and "b \<in> U" and "a \<noteq> b" and "a \<^bold>\<le>\<^sub>o\<^sub>w b"
   shows "a \<^bold><\<^sub>o\<^sub>w b"
     is ordering.not_eq_order_implies_strict.
 
 tts_lemma eq_iff:
   assumes "a \<in> U" and "b \<in> U"
   shows "(a = b) = (a \<^bold>\<le>\<^sub>o\<^sub>w b \<and> b \<^bold>\<le>\<^sub>o\<^sub>w a)"
     is ordering.eq_iff.
 
 end
 
 end
 
 context order_ow 
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting order_ow_axioms
   eliminating through clarsimp
 begin
 
 tts_lemma atLeastAtMost_singleton:
   assumes "a \<in> U"
   shows "{a..\<^sub>o\<^sub>wa} = {a}"
   is order_class.atLeastAtMost_singleton.
     
 tts_lemma less_imp_neq:
   assumes "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "x \<noteq> y"
     is order_class.less_imp_neq.
     
 tts_lemma atLeastatMost_empty:
   assumes "b \<in> U" and "a \<in> U" and "b <\<^sub>o\<^sub>w a"
   shows "{a..\<^sub>o\<^sub>wb} = {}"
     is order_class.atLeastatMost_empty.
     
 tts_lemma less_imp_not_eq:
   assumes "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "(x = y) = False"
     is order_class.less_imp_not_eq.
     
 tts_lemma less_imp_not_eq2:
   assumes "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows "(y = x) = False"
     is order_class.less_imp_not_eq2.
     
 tts_lemma atLeastLessThan_empty:
   assumes "b \<in> U" and "a \<in> U" and "b \<le>\<^sub>o\<^sub>w a"
   shows "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) = {}"
     is order_class.atLeastLessThan_empty.
     
 tts_lemma greaterThanAtMost_empty:
   assumes "l \<in> U" and "k \<in> U" and "l \<le>\<^sub>o\<^sub>w k"
   shows "{k<\<^sub>o\<^sub>w..l} = {}"
     is order_class.greaterThanAtMost_empty.
 
 tts_lemma antisym_conv1:
   assumes "x \<in> U" and "y \<in> U" and "\<not> x <\<^sub>o\<^sub>w y"
   shows "(x \<le>\<^sub>o\<^sub>w y) = (x = y)"
     is order_class.antisym_conv1.
 
 tts_lemma antisym_conv2:
   assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>o\<^sub>w y"
   shows "(\<not> x <\<^sub>o\<^sub>w y) = (x = y)"
     is order_class.antisym_conv2.
     
 tts_lemma greaterThanLessThan_empty:
   assumes "l \<in> U" and "k \<in> U" and "l \<le>\<^sub>o\<^sub>w k"
   shows "{k<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wl} = {}"
     is order_class.greaterThanLessThan_empty.
     
 tts_lemma atLeastLessThan_eq_atLeastAtMost_diff:
   assumes "a \<in> U" and "b \<in> U"
   shows "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {a..<b}) = {a..\<^sub>o\<^sub>wb} - {b}"
     is order_class.atLeastLessThan_eq_atLeastAtMost_diff.
     
 tts_lemma greaterThanAtMost_eq_atLeastAtMost_diff:
   assumes "a \<in> U" and "b \<in> U"
   shows "{a<\<^sub>o\<^sub>w..b} = {a..\<^sub>o\<^sub>wb} - {a}"
     is order_class.greaterThanAtMost_eq_atLeastAtMost_diff.
 
 tts_lemma less_separate:
   assumes "x \<in> U" and "y \<in> U" and "x <\<^sub>o\<^sub>w y"
   shows 
     "\<exists>x'\<in>U. \<exists>y'\<in>U. x \<in> {..<\<^sub>o\<^sub>wx'} \<and> y \<in> {y'<\<^sub>o\<^sub>w..} \<and> {..<\<^sub>o\<^sub>wx'} \<inter> {y'<\<^sub>o\<^sub>w..} = {}"
     is order_class.less_separate.
 
 tts_lemma order_iff_strict:
   assumes "a \<in> U" and "b \<in> U"
   shows "(a \<le>\<^sub>o\<^sub>w b) = (a <\<^sub>o\<^sub>w b \<or> a = b)"
     is order_class.order.order_iff_strict.
     
 tts_lemma le_less:
   assumes "x \<in> U" and "y \<in> U"
   shows "(x \<le>\<^sub>o\<^sub>w y) = (x <\<^sub>o\<^sub>w y \<or> x = y)"
     is order_class.le_less.
     
 tts_lemma strict_iff_order:
   assumes "a \<in> U" and "b \<in> U"
   shows "(a <\<^sub>o\<^sub>w b) = (a \<le>\<^sub>o\<^sub>w b \<and> a \<noteq> b)"
     is order_class.order.strict_iff_order.
     
 tts_lemma less_le:
   assumes "x \<in> U" and "y \<in> U"
   shows "(x <\<^sub>o\<^sub>w y) = (x \<le>\<^sub>o\<^sub>w y \<and> x \<noteq> y)"
     is order_class.less_le.
 
 tts_lemma atLeastAtMost_singleton':
   assumes "b \<in> U" and "a = b"
   shows "{a..\<^sub>o\<^sub>wb} = {a}"
     is order_class.atLeastAtMost_singleton'.
     
 tts_lemma le_imp_less_or_eq:
   assumes "x \<in> U" and "y \<in> U" and "x \<le>\<^sub>o\<^sub>w y"
   shows "x <\<^sub>o\<^sub>w y \<or> x = y"
     is order_class.le_imp_less_or_eq.
   
 tts_lemma antisym_conv:
   assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>o\<^sub>w x"
   shows "(x \<le>\<^sub>o\<^sub>w y) = (x = y)"
     is order_class.antisym_conv.
 
 tts_lemma le_neq_trans:
   assumes "a \<in> U" and "b \<in> U" and "a \<le>\<^sub>o\<^sub>w b" and "a \<noteq> b"
   shows "a <\<^sub>o\<^sub>w b"
     is order_class.le_neq_trans.
 
 tts_lemma neq_le_trans:
   assumes "a \<in> U" and "b \<in> U" and "a \<noteq> b" and "a \<le>\<^sub>o\<^sub>w b"
   shows "a <\<^sub>o\<^sub>w b"
     is order_class.neq_le_trans.
     
 tts_lemma Iio_Int_singleton:
   assumes "k \<in> U" and "x \<in> U"
   shows "{..<\<^sub>o\<^sub>wk} \<inter> {x} = (if x <\<^sub>o\<^sub>w k then {x} else {})"
     is order_class.Iio_Int_singleton.
     
 tts_lemma atLeastAtMost_singleton_iff:
   assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
   shows "({a..\<^sub>o\<^sub>wb} = {c}) = (a = b \<and> b = c)"
     is order_class.atLeastAtMost_singleton_iff.
     
 tts_lemma Icc_eq_Icc:
   assumes "l \<in> U" and "h \<in> U" and "l' \<in> U" and "h' \<in> U"
   shows "({l..\<^sub>o\<^sub>wh} = {l'..\<^sub>o\<^sub>wh'}) = (h = h' \<and> l = l' \<or> \<not> l' \<le>\<^sub>o\<^sub>w h' \<and> \<not> l \<le>\<^sub>o\<^sub>w h)"
     is order_class.Icc_eq_Icc.
     
 tts_lemma lift_Suc_mono_less_iff:
   assumes "range f \<subseteq> U" and "\<And>n. f n <\<^sub>o\<^sub>w f (Suc n)"
   shows "(f n <\<^sub>o\<^sub>w f m) = (n < m)"
     is order_class.lift_Suc_mono_less_iff.
 
 tts_lemma lift_Suc_mono_less:
   assumes "range f \<subseteq> U" and "\<And>n. f n <\<^sub>o\<^sub>w f (Suc n)" and "n < n'"
   shows "f n <\<^sub>o\<^sub>w f n'"
     is order_class.lift_Suc_mono_less.
   
 tts_lemma lift_Suc_mono_le:
   assumes "range f \<subseteq> U" and "\<And>n. f n \<le>\<^sub>o\<^sub>w f (Suc n)" and "n \<le> n'"
   shows "f n \<le>\<^sub>o\<^sub>w f n'"
     is order_class.lift_Suc_mono_le.
     
 tts_lemma lift_Suc_antimono_le:
   assumes "range f \<subseteq> U" and "\<And>n. f (Suc n) \<le>\<^sub>o\<^sub>w f n" and "n \<le> n'"
   shows "f n' \<le>\<^sub>o\<^sub>w f n"
     is order_class.lift_Suc_antimono_le.
 
 tts_lemma ivl_disj_int_two:
   assumes "l \<in> U" and "m \<in> U" and "u \<in> U"
   shows 
     "{l<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wm} \<inter> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {m..<u}) = {}"
     "{l<\<^sub>o\<^sub>w..m} \<inter> {m<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wu} = {}"
     "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l..<m}) \<inter> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {m..<u}) = {}"
     "{l..\<^sub>o\<^sub>wm} \<inter> {m<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wu} = {}"
     "{l<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wm} \<inter> {m..\<^sub>o\<^sub>wu} = {}"
     "{l<\<^sub>o\<^sub>w..m} \<inter> {m<\<^sub>o\<^sub>w..u} = {}"
     "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l..<m}) \<inter> {m..\<^sub>o\<^sub>wu} = {}"
     "{l..\<^sub>o\<^sub>wm} \<inter> {m<\<^sub>o\<^sub>w..u} = {}"
     is Set_Interval.ivl_disj_int_two.
   
 tts_lemma ivl_disj_int_one:
   assumes "l \<in> U" and "u \<in> U"
   shows 
     "{..\<^sub>o\<^sub>wl} \<inter> {l<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wu} = {}"
     "{..<\<^sub>o\<^sub>wl} \<inter> (on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l..<u}) = {}"
     "{..\<^sub>o\<^sub>wl} \<inter> {l<\<^sub>o\<^sub>w..u} = {}"
     "{..<\<^sub>o\<^sub>wl} \<inter> {l..\<^sub>o\<^sub>wu} = {}"
     "{l<\<^sub>o\<^sub>w..u} \<inter> {u<\<^sub>o\<^sub>w..} = {}"
     "{l<\<^sub>o\<^sub>w..<\<^sub>o\<^sub>wu} \<inter> {u..\<^sub>o\<^sub>w} = {}"
     "{l..\<^sub>o\<^sub>wu} \<inter> {u<\<^sub>o\<^sub>w..} = {}"
     "(on U with (\<le>\<^sub>o\<^sub>w) (<\<^sub>o\<^sub>w) : {l..<u}) \<inter> {u..\<^sub>o\<^sub>w} = {}"
     is Set_Interval.ivl_disj_int_one.
 
 tts_lemma min_absorb2:
   assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>o\<^sub>w x"
   shows "local.min x y = y"
     is Orderings.min_absorb2.
     
 tts_lemma max_absorb1:
   assumes "y \<in> U" and "x \<in> U" and "y \<le>\<^sub>o\<^sub>w x"
   shows "local.max x y = x"
     is Orderings.max_absorb1.
 
 tts_lemma atMost_Int_atLeast:
   assumes "n \<in> U"
   shows "{..\<^sub>o\<^sub>wn} \<inter> {n..\<^sub>o\<^sub>w} = {n}"
     is Set_Interval.atMost_Int_atLeast.
 
 tts_lemma monoseq_Suc:
   assumes "range X \<subseteq> U"
   shows 
     "(with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>monoseq\<guillemotright> X) = 
       ((\<forall>x. X x \<le>\<^sub>o\<^sub>w X (Suc x)) \<or> (\<forall>x. X (Suc x) \<le>\<^sub>o\<^sub>w X x))"
     is Topological_Spaces.monoseq_Suc.
 
 tts_lemma mono_SucI2:
   assumes "range X \<subseteq> U" and "\<forall>x. X (Suc x) \<le>\<^sub>o\<^sub>w X x"
   shows "with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>monoseq\<guillemotright> X"
     is Topological_Spaces.mono_SucI2.
 
 tts_lemma mono_SucI1:
   assumes "range X \<subseteq> U" and "\<forall>x. X x \<le>\<^sub>o\<^sub>w X (Suc x)"
   shows "with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>monoseq\<guillemotright> X"
     is Topological_Spaces.mono_SucI1.
 
 tts_lemma monoI2:
   assumes "range X \<subseteq> U" and "\<forall>x y. x \<le> y \<longrightarrow> X y \<le>\<^sub>o\<^sub>w X x"
   shows "with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>monoseq\<guillemotright> X"
     is Topological_Spaces.monoI2.
 
 tts_lemma monoI1:
   assumes "range X \<subseteq> U" and "\<forall>x y. x \<le> y \<longrightarrow> X x \<le>\<^sub>o\<^sub>w X y"
   shows "with (\<le>\<^sub>o\<^sub>w) : \<guillemotleft>monoseq\<guillemotright> X"
     is Topological_Spaces.monoI1.
 
 end
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting order_ow_axioms
   eliminating through clarsimp
 begin
 
 tts_lemma ex_min_if_finite:
   assumes "S \<subseteq> U"
     and "finite S"
     and "S \<noteq> {}"
   shows "\<exists>x\<in>S. \<not> (\<exists>y\<in>S. y <\<^sub>o\<^sub>w x)"
     is Lattices_Big.ex_min_if_finite.
     
 end
 
 tts_context
   tts: (?'a to U)
   sbterms: (\<open>(\<le>)::['a::order, 'a::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w)\<close>) 
     and (\<open>(<)::['a::order, 'a::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w)\<close>)
   substituting order_ow_axioms
   eliminating through clarsimp
 begin
 
 tts_lemma xt1:
   shows 
     "\<lbrakk>a = b; c <\<^sub>o\<^sub>w b\<rbrakk> \<Longrightarrow> c <\<^sub>o\<^sub>w a"
     "\<lbrakk>b <\<^sub>o\<^sub>w a; b = c\<rbrakk> \<Longrightarrow> c <\<^sub>o\<^sub>w a"
     "\<lbrakk>a = b; c \<le>\<^sub>o\<^sub>w b\<rbrakk> \<Longrightarrow> c \<le>\<^sub>o\<^sub>w a"
     "\<lbrakk>b \<le>\<^sub>o\<^sub>w a; b = c\<rbrakk> \<Longrightarrow> c \<le>\<^sub>o\<^sub>w a"
     "\<lbrakk>y \<in> U; x \<in> U; y \<le>\<^sub>o\<^sub>w x; x \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> x = y"
     "\<lbrakk>y \<in> U; x \<in> U; z \<in> U; y \<le>\<^sub>o\<^sub>w x; z \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> z \<le>\<^sub>o\<^sub>w x"
     "\<lbrakk>y \<in> U; x \<in> U; z \<in> U; y <\<^sub>o\<^sub>w x; z \<le>\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> z <\<^sub>o\<^sub>w x"
     "\<lbrakk>y \<in> U; x \<in> U; z \<in> U; y \<le>\<^sub>o\<^sub>w x; z <\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> z <\<^sub>o\<^sub>w x"
     "\<lbrakk>b \<in> U; a \<in> U; b <\<^sub>o\<^sub>w a; a <\<^sub>o\<^sub>w b\<rbrakk> \<Longrightarrow> P"
     "\<lbrakk>y \<in> U; x \<in> U; z \<in> U; y <\<^sub>o\<^sub>w x; z <\<^sub>o\<^sub>w y\<rbrakk> \<Longrightarrow> z <\<^sub>o\<^sub>w x"
     "\<lbrakk>b \<in> U; a \<in> U; b \<le>\<^sub>o\<^sub>w a; a \<noteq> b\<rbrakk> \<Longrightarrow> b <\<^sub>o\<^sub>w a"
     "\<lbrakk>a \<in> U; b \<in> U; a \<noteq> b; b \<le>\<^sub>o\<^sub>w a\<rbrakk> \<Longrightarrow> b <\<^sub>o\<^sub>w a"
     "\<lbrakk>
       b \<in> U;
       c \<in> U;
       a = f b;
       c <\<^sub>o\<^sub>w b;
       \<And>x y. \<lbrakk>x \<in> U; y \<in> U; y <\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w f x
      \<rbrakk> \<Longrightarrow> f c <\<^sub>o\<^sub>w a"
     "\<lbrakk>
       b \<in> U;
       a \<in> U;
       b <\<^sub>o\<^sub>w a;
       f b = c;
       \<And>x y. \<lbrakk>x \<in> U; y \<in> U; y <\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w f x
       \<rbrakk> \<Longrightarrow> c <\<^sub>o\<^sub>w f a"
     "\<lbrakk>
       b \<in> U;
       c \<in> U;
       a = f b;
       c \<le>\<^sub>o\<^sub>w b;
       \<And>x y. \<lbrakk>x \<in> U; y \<in> U; y \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w f x
      \<rbrakk> \<Longrightarrow> f c \<le>\<^sub>o\<^sub>w a"
     "\<lbrakk>
       b \<in> U; 
       a \<in> U; 
       b \<le>\<^sub>o\<^sub>w a; 
       f b = c; 
       \<And>x y. \<lbrakk>x \<in> U; y \<in> U; y \<le>\<^sub>o\<^sub>w x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w f x
      \<rbrakk> \<Longrightarrow> c \<le>\<^sub>o\<^sub>w f a"
     is Orderings.xt1.
 
 end
 
 end
 
 context ord_order_ow 
 begin
 
 tts_context
   tts: (?'a to U\<^sub>2) and (?'b to U\<^sub>1)
   sbterms: (\<open>(\<le>)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>) 
     and (\<open>(<)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>) 
     and (\<open>(\<le>)::[?'b::ord, ?'b::ord] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(<)::[?'b::ord, ?'b::ord] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
   rewriting ctr_simps
   substituting ord\<^sub>2.order_ow_axioms
   eliminating through clarsimp
 begin
 
 tts_lemma xt2:
   assumes "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>2"
     and "c \<in> U\<^sub>1"
     and "f b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 a"
     and "c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "f c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 a"
   is Orderings.xt2.
     
 tts_lemma xt6:
   assumes "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>2"
     and "c \<in> U\<^sub>1"
     and "f b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 a"
     and "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "f c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 a"
     is Orderings.xt6.
 
 end
 
 end
 
 context order_pair_ow 
 begin
 
 tts_context
   tts: (?'a to U\<^sub>1) and (?'b to U\<^sub>2)
   sbterms: (\<open>(\<le>)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(<)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(\<le>)::[?'b::order, ?'b::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>) 
     and (\<open>(<)::[?'b::order, ?'b::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>)
   rewriting ctr_simps
   substituting ord\<^sub>1.order_ow_axioms and ord\<^sub>2.order_ow_axioms
   eliminating through clarsimp
 begin
 
 tts_lemma xt3:
   assumes "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f a"
     is Orderings.xt3.
     
 tts_lemma xt4:
   assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U\<^sub>1"
     and "b \<in> U\<^sub>2"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "f b <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>2; y \<in> U\<^sub>2; y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f x"
   shows "f c <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     is Orderings.xt4.
     
 tts_lemma xt5:
   assumes "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f a"
     is Orderings.xt5.
     
 tts_lemma xt7:
   assumes "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f a"
     is Orderings.xt7.
 
 tts_lemma xt8:
   assumes "\<forall>x\<in>U\<^sub>2. f x \<in> U\<^sub>1"
     and "b \<in> U\<^sub>2"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "f b <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>2; y \<in> U\<^sub>2; y <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f x"
   shows "f c <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     is Orderings.xt8.
 
 tts_lemma xt9:
   assumes "b \<in> U\<^sub>1"
     and "a \<in> U\<^sub>1"
     and "c \<in> U\<^sub>2"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "b <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 a"
     and "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f b"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; y <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 x\<rbrakk> \<Longrightarrow> f y <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f x"
   shows "c <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f a"
     is Orderings.xt9.
 
 end
 
 tts_context
   tts: (?'a to U\<^sub>1) and (?'b to U\<^sub>2)
   sbterms: (\<open>(\<le>)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(<)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>)  
     and (\<open>(\<le>)::[?'b::order, ?'b::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>) 
     and (\<open>(<)::[?'b::order, ?'b::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>)
   rewriting ctr_simps
   substituting ord\<^sub>1.order_ow_axioms and ord\<^sub>2.order_ow_axioms
   eliminating through simp
 begin
 
 tts_lemma order_less_subst1:
   assumes "a \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>2. f x \<in> U\<^sub>1"
     and "b \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f b"
     and "b <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>2; y \<in> U\<^sub>2; x <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 y\<rbrakk> \<Longrightarrow> f x <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f y"
   shows "a <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f c"
     is Orderings.order_less_subst1.
     
 tts_lemma order_subst1:
   assumes "a \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>2. f x \<in> U\<^sub>1"
     and "b \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f b"
     and "b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>2; y \<in> U\<^sub>2; x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 y\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f y"
   shows "a \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 f c"
     is Orderings.order_subst1.
 
 end
 
 tts_context
   tts: (?'a to U\<^sub>1) and (?'c to U\<^sub>2)
   sbterms: (\<open>(\<le>)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(<)::[?'a::order, ?'a::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>1)\<close>) 
     and (\<open>(\<le>)::[?'c::order, ?'c::order] \<Rightarrow> bool\<close> to \<open>(\<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>) 
     and (\<open>(<)::[?'c::order, ?'c::order] \<Rightarrow> bool\<close> to \<open>(<\<^sub>o\<^sub>w\<^sub>.\<^sub>2)\<close>)
   rewriting ctr_simps
   substituting ord\<^sub>1.order_ow_axioms and ord\<^sub>2.order_ow_axioms
   eliminating through simp
 begin
 
 tts_lemma order_less_le_subst2:
   assumes "a \<in> U\<^sub>1"
     and "b \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "f b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; x <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 y\<rbrakk> \<Longrightarrow> f x <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f y"
   shows "f a <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     is Orderings.order_less_le_subst2.
     
 tts_lemma order_le_less_subst2:
   assumes "a \<in> U\<^sub>1"
     and "b \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "f b <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 y\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f y"
   shows "f a <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     is Orderings.order_le_less_subst2.
     
 tts_lemma order_less_subst2:
   assumes "a \<in> U\<^sub>1"
     and "b \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "f b <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; x <\<^sub>o\<^sub>w\<^sub>.\<^sub>1 y\<rbrakk> \<Longrightarrow> f x <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f y"
   shows "f a <\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     is Orderings.order_less_subst2.
 
 tts_lemma order_subst2:
   assumes "a \<in> U\<^sub>1"
     and "b \<in> U\<^sub>1"
     and "\<forall>x\<in>U\<^sub>1. f x \<in> U\<^sub>2"
     and "c \<in> U\<^sub>2"
     and "a \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 b"
     and "f b \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     and "\<And>x y. \<lbrakk>x \<in> U\<^sub>1; y \<in> U\<^sub>1; x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>1 y\<rbrakk> \<Longrightarrow> f x \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 f y"
   shows "f a \<le>\<^sub>o\<^sub>w\<^sub>.\<^sub>2 c"
     is Orderings.order_subst2.
 
 end
 
 end
 
 
 
 subsection\<open>Dense orders\<close>
 
 
 subsubsection\<open>Definitions and common properties\<close>
 
 locale dense_order_ow = order_ow U le ls
   for U :: "'ao set" and le ls +
   assumes dense: "\<lbrakk> x \<in> U; y \<in> U; x <\<^sub>o\<^sub>w y \<rbrakk> \<Longrightarrow> (\<exists>z\<in>U. x <\<^sub>o\<^sub>w z \<and> z <\<^sub>o\<^sub>w y)"
 
 
 subsubsection\<open>Transfer rules\<close>
 
 context
   includes lifting_syntax
 begin
 
 lemma dense_order_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A" 
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
       (dense_order_ow (Collect (Domainp A))) class.dense_order"
   unfolding 
     dense_order_ow_def class.dense_order_def
     dense_order_ow_axioms_def class.dense_order_axioms_def
   apply transfer_prover_start
   apply transfer_step+
   by simp
   
 end
 
 
 
 subsection\<open>
 Partial orders with the greatest element and 
 partial orders with the least elements
 \<close>
 
 
 subsubsection\<open>Definitions and common properties\<close>
 
 locale ordering_top_ow = ordering_ow U le ls 
   for U :: "'ao set" and le ls  +
   fixes top :: "'ao" ("\<^bold>\<top>\<^sub>o\<^sub>w")
   assumes top_closed[simp]: "\<^bold>\<top>\<^sub>o\<^sub>w \<in> U"
   assumes extremum[simp]: "a \<in> U \<Longrightarrow> a \<^bold>\<le>\<^sub>o\<^sub>w \<^bold>\<top>\<^sub>o\<^sub>w"
 begin
 
 notation top ("\<^bold>\<top>\<^sub>o\<^sub>w")
 
 end
 
 locale bot_ow = 
   fixes U :: "'ao set" and bot (\<open>\<bottom>\<^sub>o\<^sub>w\<close>)
   assumes bot_closed[simp]: "\<bottom>\<^sub>o\<^sub>w \<in> U"
 begin
 
 notation bot (\<open>\<bottom>\<^sub>o\<^sub>w\<close>)
 
 end
 
 locale bot_pair_ow = ord\<^sub>1: bot_ow U\<^sub>1 bot\<^sub>1 + ord\<^sub>2: bot_ow U\<^sub>2 bot\<^sub>2
   for U\<^sub>1 :: "'ao set" and bot\<^sub>1 and U\<^sub>2 :: "'bo set" and bot\<^sub>2
 begin
 
 notation bot\<^sub>1 (\<open>\<bottom>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close>)
 notation bot\<^sub>2 (\<open>\<bottom>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close>)
 
 end
 
 locale order_bot_ow = order_ow U le ls + bot_ow U bot
   for U :: "'ao set" and bot le ls  +
   assumes bot_least: "a \<in> U \<Longrightarrow> \<bottom>\<^sub>o\<^sub>w \<le>\<^sub>o\<^sub>w a"
 begin
 
 sublocale bot: ordering_top_ow U \<open>(\<ge>\<^sub>o\<^sub>w)\<close> \<open>(>\<^sub>o\<^sub>w)\<close> \<open>\<bottom>\<^sub>o\<^sub>w\<close>
   apply unfold_locales
   subgoal by simp
   subgoal by (simp add: bot_least)
   done
 
 no_notation le (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
   and ls (infix "\<^bold><\<^sub>o\<^sub>w" 50)
   and top ("\<^bold>\<top>\<^sub>o\<^sub>w")
 
 end
 
 locale order_bot_pair_ow = 
   ord\<^sub>1: order_bot_ow U\<^sub>1 bot\<^sub>1 le\<^sub>1 ls\<^sub>1 + ord\<^sub>2: order_bot_ow U\<^sub>2 bot\<^sub>2 le\<^sub>2 ls\<^sub>2 
   for U\<^sub>1 :: "'ao set" and bot\<^sub>1 le\<^sub>1 ls\<^sub>1 and U\<^sub>2 :: "'bo set" and bot\<^sub>2 le\<^sub>2 ls\<^sub>2  
 begin
 
 sublocale bot_pair_ow ..
 sublocale order_pair_ow ..
 
 end
 
 
 locale top_ow = 
   fixes U :: "'ao set" and top (\<open>\<top>\<^sub>o\<^sub>w\<close>)
   assumes top_closed[simp]: "\<top>\<^sub>o\<^sub>w \<in> U"
 begin
 
 notation top (\<open>\<top>\<^sub>o\<^sub>w\<close>)
 
 end
 
 locale top_pair_ow = ord\<^sub>1: top_ow U\<^sub>1 top\<^sub>1 + ord\<^sub>2: top_ow U\<^sub>2 top\<^sub>2
   for U\<^sub>1 :: "'ao set" and top\<^sub>1 and U\<^sub>2 :: "'bo set" and top\<^sub>2
 begin
 
 notation top\<^sub>1 (\<open>\<top>\<^sub>o\<^sub>w\<^sub>.\<^sub>1\<close>)
 notation top\<^sub>2 (\<open>\<top>\<^sub>o\<^sub>w\<^sub>.\<^sub>2\<close>)
 
 end
 
 locale order_top_ow = order_ow U le ls + top_ow U top
   for U :: "'ao set" and le ls top  +
   assumes top_greatest: "a \<in> U \<Longrightarrow> a \<le>\<^sub>o\<^sub>w \<top>\<^sub>o\<^sub>w"
 begin
 
 sublocale top: ordering_top_ow U \<open>(\<le>\<^sub>o\<^sub>w)\<close> \<open>(<\<^sub>o\<^sub>w)\<close> \<open>\<top>\<^sub>o\<^sub>w\<close>
   apply unfold_locales
   subgoal by simp
   subgoal by (simp add: top_greatest)
   done
 
 no_notation le (infix "\<^bold>\<le>\<^sub>o\<^sub>w" 50)
   and ls (infix "\<^bold><\<^sub>o\<^sub>w" 50)
   and top ("\<^bold>\<top>\<^sub>o\<^sub>w")
 
 end
 
 locale order_top_pair_ow = 
   ord\<^sub>1: order_top_ow U\<^sub>1 le\<^sub>1 ls\<^sub>1 top\<^sub>1 + ord\<^sub>2: order_top_ow U\<^sub>2 le\<^sub>2 ls\<^sub>2 top\<^sub>2
   for U\<^sub>1 :: "'ao set" and le\<^sub>1 ls\<^sub>1 top\<^sub>1 and U\<^sub>2 :: "'bo set" and le\<^sub>2 ls\<^sub>2 top\<^sub>2 
 begin
 
 sublocale top_pair_ow ..
 sublocale order_pair_ow ..
 
 end
 
 
 subsubsection\<open>Transfer rules\<close>
 
 context
   includes lifting_syntax
 begin
 
 lemma ordering_top_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A" 
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=)) 
       (ordering_top_ow (Collect (Domainp A))) ordering_top"
 proof-
   let ?P = "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=))"
   let ?ordering_top_ow = "ordering_top_ow (Collect (Domainp A))"
   have 
     "?P ?ordering_top_ow (\<lambda>le ls ext. ext \<in> UNIV \<and> ordering_top le ls ext)"
     unfolding 
       ordering_top_ow_def ordering_top_def
       ordering_top_ow_axioms_def ordering_top_axioms_def
     apply transfer_prover_start
     apply transfer_step+
     by blast 
   thus ?thesis by simp
 qed
 
 lemma order_bot_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A"
   shows 
     "(A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
       (order_bot_ow (Collect (Domainp A))) class.order_bot"
 proof-
   let ?P = "(A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))"
   let ?order_bot_ow = "order_bot_ow (Collect (Domainp A))"
   have 
     "?P ?order_bot_ow (\<lambda>bot le ls. bot \<in> UNIV \<and> class.order_bot bot le ls)"
     unfolding 
       class.order_bot_def order_bot_ow_def 
       class.order_bot_axioms_def order_bot_ow_axioms_def
       bot_ow_def
     apply transfer_prover_start
     apply transfer_step+
     by blast 
   thus ?thesis by simp
 qed
 
 lemma order_top_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "right_total A" 
   shows 
     "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=)) 
       (order_top_ow (Collect (Domainp A))) class.order_top"
 proof-
   let ?P = "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=))"
   let ?order_top_ow = "order_top_ow (Collect (Domainp A))"
   have 
     "?P ?order_top_ow (\<lambda>le ls top. top \<in> UNIV \<and> class.order_top le ls top)"
     unfolding 
       class.order_top_def order_top_ow_def 
       class.order_top_axioms_def order_top_ow_axioms_def
       top_ow_def
     apply transfer_prover_start
     apply transfer_step+
     by blast 
   thus ?thesis by simp
 qed
   
 end
 
 
 subsubsection\<open>Relativization\<close>
 
 context ordering_top_ow 
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting ordering_top_ow_axioms
   eliminating through simp
   applying [OF top_closed]
 begin
 
 tts_lemma extremum_uniqueI:
   assumes "\<^bold>\<top>\<^sub>o\<^sub>w \<^bold>\<le>\<^sub>o\<^sub>w \<^bold>\<top>\<^sub>o\<^sub>w"
   shows "\<^bold>\<top>\<^sub>o\<^sub>w = \<^bold>\<top>\<^sub>o\<^sub>w"
     is ordering_top.extremum_uniqueI.
     
 tts_lemma extremum_unique:
   shows "(\<^bold>\<top>\<^sub>o\<^sub>w \<^bold>\<le>\<^sub>o\<^sub>w \<^bold>\<top>\<^sub>o\<^sub>w) = (\<^bold>\<top>\<^sub>o\<^sub>w = \<^bold>\<top>\<^sub>o\<^sub>w)"
     is ordering_top.extremum_unique.
     
 tts_lemma extremum_strict:
   shows "\<not> \<^bold>\<top>\<^sub>o\<^sub>w \<^bold><\<^sub>o\<^sub>w \<^bold>\<top>\<^sub>o\<^sub>w"
     is ordering_top.extremum_strict.
     
 tts_lemma not_eq_extremum:
   shows "(\<^bold>\<top>\<^sub>o\<^sub>w \<noteq> \<^bold>\<top>\<^sub>o\<^sub>w) = (\<^bold>\<top>\<^sub>o\<^sub>w \<^bold><\<^sub>o\<^sub>w \<^bold>\<top>\<^sub>o\<^sub>w)"
     is ordering_top.not_eq_extremum.
 
 end
   
 end
 
 context order_bot_ow 
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting order_bot_ow_axioms
   eliminating through simp
 begin
 
 tts_lemma bdd_above_bot:
   assumes "A \<subseteq> U"
   shows "bdd_below A"
     is order_bot_class.bdd_below_bot.
 
 tts_lemma not_less_bot:
   assumes "a \<in> U"
   shows "\<not> a <\<^sub>o\<^sub>w \<bottom>\<^sub>o\<^sub>w"
   is order_bot_class.not_less_bot.
     
 tts_lemma max_bot:
   assumes "x \<in> U"
   shows "max \<bottom>\<^sub>o\<^sub>w x = x"
     is order_bot_class.max_bot.
 
 tts_lemma max_bot2:
   assumes "x \<in> U"
   shows "max x \<bottom>\<^sub>o\<^sub>w = x"
     is order_bot_class.max_bot2.
 
 tts_lemma min_bot:
   assumes "x \<in> U"
   shows "min \<bottom>\<^sub>o\<^sub>w x = \<bottom>\<^sub>o\<^sub>w"
     is order_bot_class.min_bot.
 
 tts_lemma min_bot2:
   assumes "x \<in> U"
   shows "min x \<bottom>\<^sub>o\<^sub>w = \<bottom>\<^sub>o\<^sub>w"
     is order_bot_class.min_bot2.
 
 tts_lemma bot_unique:
   assumes "a \<in> U"
   shows "(a \<le>\<^sub>o\<^sub>w \<bottom>\<^sub>o\<^sub>w) = (a = \<bottom>\<^sub>o\<^sub>w)"
     is order_bot_class.bot_unique.
 
 tts_lemma bot_less:
   assumes "a \<in> U"
   shows "(a \<noteq> \<bottom>\<^sub>o\<^sub>w) = (\<bottom>\<^sub>o\<^sub>w <\<^sub>o\<^sub>w a)"
     is order_bot_class.bot_less.
 
 tts_lemma atLeast_eq_UNIV_iff:
   assumes "x \<in> U"
   shows "({x..\<^sub>o\<^sub>w} = U) = (x = \<bottom>\<^sub>o\<^sub>w)"
     is order_bot_class.atLeast_eq_UNIV_iff.
 
 tts_lemma le_bot:
   assumes "a \<in> U" and "a \<le>\<^sub>o\<^sub>w \<bottom>\<^sub>o\<^sub>w"
   shows "a = \<bottom>\<^sub>o\<^sub>w"
     is order_bot_class.le_bot.
 
 end
 
 end
 
 context order_top_ow 
 begin
 
 tts_context
   tts: (?'a to U)
   rewriting ctr_simps
   substituting order_top_ow_axioms
   eliminating through simp
 begin
 
 tts_lemma bdd_above_top:
   assumes "A \<subseteq> U"
   shows "bdd_above A"
   is order_top_class.bdd_above_top.
 
 tts_lemma not_top_less:
   assumes "a \<in> U"
   shows "\<not> \<top>\<^sub>o\<^sub>w <\<^sub>o\<^sub>w a"
     is order_top_class.not_top_less.
 
 tts_lemma max_top:
   assumes "x \<in> U"
   shows "max \<top>\<^sub>o\<^sub>w x = \<top>\<^sub>o\<^sub>w"
     is order_top_class.max_top.
 
 tts_lemma max_top2:
   assumes "x \<in> U"
   shows "max x \<top>\<^sub>o\<^sub>w = \<top>\<^sub>o\<^sub>w"
     is order_top_class.max_top2.
 
 tts_lemma min_top:
   assumes "x \<in> U"
   shows "min \<top>\<^sub>o\<^sub>w x = x"
     is order_top_class.min_top.
 
 tts_lemma min_top2:
   assumes "x \<in> U"
   shows "min x \<top>\<^sub>o\<^sub>w = x"
     is order_top_class.min_top2.
 
 tts_lemma top_unique:
   assumes "a \<in> U"
   shows "(\<top>\<^sub>o\<^sub>w \<le>\<^sub>o\<^sub>w a) = (a = \<top>\<^sub>o\<^sub>w)"
     is order_top_class.top_unique.
 
 tts_lemma less_top:
   assumes "a \<in> U"
   shows "(a \<noteq> \<top>\<^sub>o\<^sub>w) = (a <\<^sub>o\<^sub>w \<top>\<^sub>o\<^sub>w)"
     is order_top_class.less_top.
 
 tts_lemma atMost_eq_UNIV_iff:
   assumes "x \<in> U"
   shows "({..\<^sub>o\<^sub>wx} = U) = (x = \<top>\<^sub>o\<^sub>w)"
     is order_top_class.atMost_eq_UNIV_iff.
 
 tts_lemma top_le:
   assumes "a \<in> U" and "\<top>\<^sub>o\<^sub>w \<le>\<^sub>o\<^sub>w a"
   shows "a = \<top>\<^sub>o\<^sub>w"
     is order_top_class.top_le.
 
 end
 
 end
 
 text\<open>\newpage\<close>
 
 end
\ No newline at end of file
diff --git a/thys/WOOT_Strong_Eventual_Consistency/Sorting.thy b/thys/WOOT_Strong_Eventual_Consistency/Sorting.thy
--- a/thys/WOOT_Strong_Eventual_Consistency/Sorting.thy
+++ b/thys/WOOT_Strong_Eventual_Consistency/Sorting.thy
@@ -1,141 +1,141 @@
 subsection \<open>Sorting\<close>
 
 text \<open>Some preliminary lemmas about sorting.\<close>
 
 theory Sorting
   imports Main "HOL.List" "HOL-Library.Sublist"
 begin
 
 lemma insort:
   assumes "Suc l < length s"
   assumes "s ! l < (v :: 'a :: linorder)"
   assumes "s ! (l+1) > v"
   assumes "sorted_wrt (<) s"
   shows "sorted_wrt (<) ((take (Suc l) s)@v#(drop (Suc l) s))"
 proof -
   have "sorted_wrt (<) (take (Suc l) s@(drop (Suc l) s))"
     using assms(4) by simp
   moreover have
     "\<And>x. x \<in> set (take (Suc l) s) = (\<exists>i. i < (Suc l) \<and> i < length s \<and> s ! i = x)" 
     by (metis in_set_conv_nth length_take min_less_iff_conj nth_take)
   hence "\<And>x. x \<in> set (take (Suc l) s) \<Longrightarrow> x < v"
     using assms apply (simp) 
     using less_Suc_eq sorted_wrt_nth_less by fastforce
   moreover have
     "\<And>x. x \<in> set (drop (Suc l) s) = (\<exists>i. Suc l + i < length s \<and> s ! (Suc l + i) = x)"
     using assms(1) by (simp add:in_set_conv_nth add.commute less_diff_conv)
   hence "\<And>x. x \<in> set (drop (Suc l) s) \<Longrightarrow> x > v"
     using assms apply (simp) 
     by (metis add.right_neutral add_diff_cancel_left' diff_Suc_Suc diff_is_0_eq'
         leI le_less_trans less_imp_le sorted_wrt_iff_nth_less)
   ultimately show ?thesis
     by (simp add:sorted_wrt_append del:append_take_drop_id)
 qed
 
 lemma sorted_wrt_irrefl_distinct:
   assumes "irreflp r"
   shows "sorted_wrt r xs \<longrightarrow> distinct xs"
   using assms by (induction xs, simp, simp, meson irreflp_def)
 
 lemma sort_set_unique_h:
   assumes "irreflp r \<and> transp r"
   assumes "set (x#xs) = set (y#ys)" 
   assumes "\<forall>z \<in> set xs. r x z" 
   assumes "\<forall>z \<in> set ys. r y z" 
   shows "x = y \<and> set xs = set ys"
   by (metis assms insert_eq_iff irreflp_def list.set_intros(1)
       list.simps(15) set_ConsD transpD)
 
 lemma sort_set_unique_rel:
   assumes "irreflp r \<and> transp r"
   assumes "set x = set y"
   assumes "sorted_wrt r x"
   assumes "sorted_wrt r y"
   shows "x = y"
 proof -
   have "length x = length y" 
     using assms by (metis sorted_wrt_irrefl_distinct distinct_card)
   then show ?thesis using assms 
     apply(induct rule:list_induct2, simp, simp)
     by (metis assms(1) list.simps(15) sort_set_unique_h) 
 qed
 
 lemma sort_set_unique:
   assumes "set x = set y"
   assumes "sorted_wrt (<) (map (f :: ('a \<Rightarrow> ('b :: linorder)))  x)"
   assumes "sorted_wrt (<) (map f y)"
   shows "x = y"
   using assms apply (simp add:sorted_wrt_map) 
   by (metis (no_types, lifting) irreflp_def less_irrefl sort_set_unique_rel 
-      transpD transpI transp_less)
+      transpD transpI transp_on_less)
 
 text \<open>If two sequences contain the same element and strictly increasing with respect.\<close>
 
 lemma subseq_imp_sorted:
   assumes "subseq s t"
   assumes "sorted_wrt p t"
   shows "sorted_wrt p s"
 proof -
   have "sorted_wrt p s \<or> \<not> sorted_wrt p t"
   apply (rule list_emb.induct[where P="(=)"])
   using list_emb_set assms by fastforce+
   thus ?thesis using assms by blast
 qed
 
 text \<open>If a sequence @{text t} is sorted with respect to a relation @{text p} then a subsequence will 
   be as well.\<close>
 
 fun to_ord where "to_ord r x y = (\<not>(r\<^sup>*\<^sup>* y x))"
 
 lemma trancl_idemp: "r\<^sup>+\<^sup>+\<^sup>+\<^sup>+ x y = r\<^sup>+\<^sup>+ x y" 
   by (metis r_into_rtranclp reflclp_tranclp rtranclp_idemp rtranclp_reflclp 
       rtranclp_tranclp_tranclp tranclp.cases tranclp.r_into_trancl)
 
 lemma top_sort:
   fixes rp
   assumes "acyclicP r"
   shows "finite s \<longrightarrow> (\<exists>l. set l = s \<and> sorted_wrt (to_ord r) l \<and> distinct l)"
 proof (induction "card s" arbitrary:s)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   hence "s \<noteq> {}" by auto
   moreover 
   have "acyclicP (r\<^sup>+\<^sup>+)" using assms
     by (simp add:acyclic_def trancl_def trancl_idemp)
   hence "acyclic ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s)"
     by (meson acyclic_subset inf_le1)
   hence "wf ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s)" using Suc 
     by (metis card.infinite finite_Int finite_SigmaI nat.distinct(1) 
         wf_iff_acyclic_if_finite)
   ultimately obtain z where 
     "z \<in> s \<and> (\<forall>y. (y, z) \<in>  ({(x,y). r\<^sup>+\<^sup>+ x y} \<inter> s \<times> s) \<longrightarrow> y \<notin> s)" 
     by (metis ex_in_conv wf_eq_minimal)
   hence z_def: "z \<in> s \<and> (\<forall>y. r\<^sup>+\<^sup>+ y z \<longrightarrow> y \<notin> s)" by blast
   hence "card (s - {z}) = n"
     by (metis One_nat_def Suc.hyps(2) card_Diff_singleton_if card.infinite 
         diff_Suc_Suc diff_zero nat.simps(3))
   then obtain l where l_def: 
     "set l = s - {z} \<and> sorted_wrt (to_ord r) l \<and> distinct l" 
     by (metis Zero_not_Suc card.infinite finite_Diff Suc)
   hence "set (z#l) = s" using z_def by auto
   moreover have "\<forall>y \<in> set l. \<not>(r\<^sup>*\<^sup>* y z)" using z_def l_def rtranclpD by force
   ultimately show ?case 
     by (metis distinct.simps(2) insert_absorb l_def list.simps(15) 
         sorted_wrt.simps(2) to_ord.elims(3))
 qed
 
 lemma top_sort_eff:
   assumes "irreflp p\<^sup>+\<^sup>+"
   assumes "sorted_wrt (to_ord p) x" 
   assumes "i < length x"
   assumes "j < length x"
   assumes "(p\<^sup>+\<^sup>+ (x ! i) (x ! j))"
   shows "i < j"
   using assms apply (cases "i > j")
    apply (metis sorted_wrt_nth_less r_into_rtranclp reflclp_tranclp
           rtranclp_idemp rtranclp_reflclp to_ord.simps)
   by (metis irreflp_def nat_neq_iff)
 
 end
\ No newline at end of file