diff --git a/thys/Containers/Lexicographic_Order.thy b/thys/Containers/Lexicographic_Order.thy
--- a/thys/Containers/Lexicographic_Order.thy
+++ b/thys/Containers/Lexicographic_Order.thy
@@ -1,92 +1,92 @@
 (*  Title:      Containers/Lexicographic_Order.thy
     Author:     Andreas Lochbihler, KIT *)
 
 theory Lexicographic_Order imports
   List_Fusion
   "HOL-Library.Char_ord"
 begin
 
 hide_const (open) List.lexordp
 
 section \<open>List fusion for lexicographic order\<close>
 
 context linorder begin
 
 lemma lexordp_take_index_conv:
   "lexordp xs ys \<longleftrightarrow> 
    (length xs < length ys \<and> take (length xs) ys = xs) \<or>
    (\<exists>i < min (length xs) (length ys). take i xs = take i ys \<and> xs ! i < ys ! i)"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs thus ?rhs
     by induct (auto 4 3 del: disjCI intro: disjI2 exI[where x="Suc i" for i])
 next
   assume ?rhs (is "?prefix \<or> ?less") thus ?lhs 
   proof
     assume "?prefix"
     hence "ys = xs @ hd (drop (length xs) ys) # tl (drop (length xs) ys)"
       by (metis append_Nil2 append_take_drop_id less_not_refl list.collapse)
     thus ?thesis unfolding lexordp_iff by blast
   next
     assume "?less"
     then obtain i where "i < min (length xs) (length ys)"
       and "take i xs = take i ys" and nth: "xs ! i < ys ! i" by blast
     hence "xs = take i xs @ xs ! i # drop (Suc i) xs" "ys = take i xs @ ys ! i # drop (Suc i) ys"
       by -(subst append_take_drop_id[symmetric, of _ i], simp_all add: Cons_nth_drop_Suc)
     with nth show ?thesis unfolding lexordp_iff by blast
   qed
 qed
 
 \<comment> \<open>lexord is extension of partial ordering List.lex\<close> 
 lemma lexordp_lex: "(xs, ys) \<in> lex {(xs, ys). xs < ys} \<longleftrightarrow> lexordp xs ys \<and> length xs = length ys"
 proof(induct xs arbitrary: ys)
   case Nil thus ?case by clarsimp
 next
   case Cons thus ?case by(cases ys)(simp_all, safe, simp)
 qed
 
-end
+end                
 
 subsection \<open>Setup for list fusion\<close>
 
-context order begin
+context ord begin
 
 definition lexord_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where [code del]: "lexord_fusion g1 g2 s1 s2 = lexordp (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition lexord_eq_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where [code del]: "lexord_eq_fusion g1 g2 s1 s2 = lexordp_eq (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 lemma lexord_fusion_code:
   "lexord_fusion g1 g2 s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      if list.has_next g2 s2 then
        let (x, s1') = list.next g1 s1;
            (y, s2') = list.next g2 s2
        in x < y \<or> \<not> y < x \<and> lexord_fusion g1 g2 s1' s2'
      else False
    else list.has_next g2 s2)"
 unfolding lexord_fusion_def
 by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)
 
 lemma lexord_eq_fusion_code:
   "lexord_eq_fusion g1 g2 s1 s2 \<longleftrightarrow>
   (list.has_next g1 s1 \<longrightarrow>
    list.has_next g2 s2 \<and>
    (let (x, s1') = list.next g1 s1;
         (y, s2') = list.next g2 s2
     in x < y \<or> \<not> y < x \<and> lexord_eq_fusion g1 g2 s1' s2'))"
 unfolding lexord_eq_fusion_def
 by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)
 
 end
 
 lemmas [code] =
-  lexord_fusion_code order.lexord_fusion_code
-  lexord_eq_fusion_code order.lexord_eq_fusion_code
+  lexord_fusion_code ord.lexord_fusion_code
+  lexord_eq_fusion_code ord.lexord_eq_fusion_code
 
 lemmas [symmetric, code_unfold] =
-  lexord_fusion_def order.lexord_fusion_def
-  lexord_eq_fusion_def order.lexord_eq_fusion_def
+  lexord_fusion_def ord.lexord_fusion_def
+  lexord_eq_fusion_def ord.lexord_eq_fusion_def
 
 end
diff --git a/thys/Containers/List_Proper_Interval.thy b/thys/Containers/List_Proper_Interval.thy
--- a/thys/Containers/List_Proper_Interval.thy
+++ b/thys/Containers/List_Proper_Interval.thy
@@ -1,66 +1,71 @@
 (*  Title:      Containers/List_Proper_Interval.thy
     Author:     Andreas Lochbihler, ETH Zurich *)
 
 theory List_Proper_Interval imports
   "HOL-Library.List_Lexorder"
   Collection_Order
 begin
 
 section \<open>Instantiate @{class proper_interval} of for @{typ "'a list"}\<close>
 
 lemma Nil_less_conv_neq_Nil: "[] < xs \<longleftrightarrow> xs \<noteq> []"
 by(cases xs) simp_all
 
 lemma less_append_same_iff:
   fixes xs :: "'a :: preorder list"
   shows "xs < xs @ ys \<longleftrightarrow> [] < ys"
 by(induct xs) simp_all
 
 lemma less_append_same2_iff:
   fixes xs :: "'a :: preorder list"
   shows "xs @ ys < xs @ zs \<longleftrightarrow> ys < zs"
 by(induct xs) simp_all
 
 lemma Cons_less_iff:
   fixes x :: "'a :: preorder" shows
   "x # xs < ys \<longleftrightarrow> (\<exists>y ys'. ys = y # ys' \<and> (x < y \<or> x = y \<and> xs < ys'))"
 by(cases ys) auto
 
 instantiation list :: ("{proper_interval, order}") proper_interval begin
 
 definition proper_interval_list_aux :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where proper_interval_list_aux_correct:
   "proper_interval_list_aux xs ys \<longleftrightarrow> (\<exists>zs. xs < zs \<and> zs < ys)"
 
-lemma proper_interval_list_aux_simps [code]:
+lemma proper_interval_list_aux_simp_1: 
   "proper_interval_list_aux xs [] \<longleftrightarrow> False"
+  by (simp add: proper_interval_list_aux_correct)
+
+lemma proper_interval_list_aux_simp_2:
   "proper_interval_list_aux [] (y # ys) \<longleftrightarrow> ys \<noteq> [] \<or> proper_interval None (Some y)"
-  "proper_interval_list_aux (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> x = y \<and> proper_interval_list_aux xs ys"
-apply(simp_all add: proper_interval_list_aux_correct proper_interval_simps Nil_less_conv_neq_Nil)
- apply(fastforce simp add: neq_Nil_conv)
-apply(rule iffI)
- apply(fastforce simp add: Cons_less_iff intro: less_trans)
-apply(erule disjE)
- apply(rule exI[where x="x # xs @ [undefined]"])
- apply(simp add: less_append_same_iff)
-apply(auto 4 3 simp add: Cons_less_iff)
-done
+  apply(auto simp add: proper_interval_list_aux_correct proper_interval_simps Nil_less_conv_neq_Nil)
+  apply (metis Cons_less_Cons neq_Nil_conv not_less_Nil)
+  by (metis Cons_less_Cons Nil_less_Cons neq_Nil_conv)
+
+lemma proper_interval_list_aux_simp_3: 
+  "proper_interval_list_aux (x # xs) (y # ys) \<longleftrightarrow> (if x = y then proper_interval_list_aux xs ys else x < y)"
+    apply(auto simp add: proper_interval_list_aux_correct proper_interval_simps Nil_less_conv_neq_Nil Cons_less_iff)
+  apply fastforce
+  by (metis Cons_less_Cons Nil_less_Cons less_append_same_iff)
+
+lemmas proper_interval_list_aux_simps [code] = 
+  proper_interval_list_aux_simp_1 proper_interval_list_aux_simp_2 proper_interval_list_aux_simp_3
 
 fun proper_interval_list :: "'a list option \<Rightarrow> 'a list option \<Rightarrow> bool" where
   "proper_interval_list None None \<longleftrightarrow> True"
 | "proper_interval_list None (Some xs) \<longleftrightarrow> (xs \<noteq> [])"
 | "proper_interval_list (Some xs) None \<longleftrightarrow> True"
 | "proper_interval_list (Some xs) (Some ys) \<longleftrightarrow> proper_interval_list_aux xs ys"
 instance
 proof(intro_classes)
   fix xs ys :: "'a list"
   show "proper_interval None (Some ys) \<longleftrightarrow> (\<exists>zs. zs < ys)"
     by(auto simp add: Nil_less_conv_neq_Nil intro: exI[where x="[]"])
   show "proper_interval (Some xs) None \<longleftrightarrow> (\<exists>zs. xs < zs)"
     by(simp add: exI[where x="xs @ [undefined]"] less_append_same_iff)
   show "proper_interval (Some xs) (Some ys) \<longleftrightarrow> (\<exists>zs. xs < zs \<and> zs < ys)"
     by(simp add: proper_interval_list_aux_correct)
 qed simp
 end
 
 end
diff --git a/thys/Containers/Set_Impl.thy b/thys/Containers/Set_Impl.thy
--- a/thys/Containers/Set_Impl.thy
+++ b/thys/Containers/Set_Impl.thy
@@ -1,2066 +1,2064 @@
 (*  Title:      Containers/Set_Impl.thy
     Author:     Andreas Lochbihler, KIT
                 René Thiemann, UIBK *)
 
 theory Set_Impl imports
   Collection_Enum
   DList_Set
   RBT_Set2
   Closure_Set
   Containers_Generator
   Complex_Main
 begin
 
 section \<open>Different implementations of sets\<close>
 
 subsection \<open>Auxiliary functions\<close>
 
 text \<open>A simple quicksort implementation\<close>
 
 context ord begin
 
 function (sequential) quicksort_acc :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
   and quicksort_part :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "quicksort_acc ac [] = ac"
 | "quicksort_acc ac [x] = x # ac"
 | "quicksort_acc ac (x # xs) = quicksort_part ac x [] [] [] xs"
 | "quicksort_part ac x lts eqs gts [] = quicksort_acc (eqs @ x # quicksort_acc ac gts) lts"
 | "quicksort_part ac x lts eqs gts (z # zs) =
   (if z > x then quicksort_part ac x lts eqs (z # gts) zs
    else if z < x then quicksort_part ac x (z # lts) eqs gts zs
    else quicksort_part ac x lts (z # eqs) gts zs)"
 by pat_completeness simp_all
 
 lemma length_quicksort_accp:
   "quicksort_acc_quicksort_part_dom (Inl (ac, xs)) \<Longrightarrow> length (quicksort_acc ac xs) = length ac + length xs"
   and length_quicksort_partp:
   "quicksort_acc_quicksort_part_dom (Inr (ac, x, lts, eqs, gts, zs)) 
   \<Longrightarrow> length (quicksort_part ac x lts eqs gts zs) = length ac + 1 + length lts + length eqs + length gts + length zs"
 apply(induct rule: quicksort_acc_quicksort_part.pinduct)
 apply(simp_all add: quicksort_acc.psimps quicksort_part.psimps)
 done
 
 termination
 apply(relation "measure (case_sum (\<lambda>(_, xs). 2 * length xs ^ 2) (\<lambda>(_, _, lts, eqs, gts, zs). 2 * (length lts + length eqs + length gts + length zs) ^ 2 + length zs + 1))")
 apply(simp_all add: power2_eq_square add_mult_distrib add_mult_distrib2 length_quicksort_accp)
 done
 
 definition quicksort :: "'a list \<Rightarrow> 'a list"
 where "quicksort = quicksort_acc []"
 
 lemma set_quicksort_acc [simp]: "set (quicksort_acc ac xs) = set ac \<union> set xs"
   and set_quicksort_part [simp]:
   "set (quicksort_part ac x lts eqs gts zs) =
   set ac \<union> {x} \<union> set lts \<union> set eqs \<union> set gts \<union> set zs"
 by(induct ac xs and ac x lts eqs gts zs rule: quicksort_acc_quicksort_part.induct)(auto split: if_split_asm)
 
 lemma set_quicksort [simp]: "set (quicksort xs) = set xs"
 by(simp add: quicksort_def)
 
 lemma distinct_quicksort_acc: 
   "distinct (quicksort_acc ac xs) = distinct (ac @ xs)"
   and distinct_quicksort_part:
   "distinct (quicksort_part ac x lts eqs gts zs) = distinct (ac @ [x] @ lts @ eqs @ gts @ zs)"
 by(induct ac xs and ac x lts eqs gts zs rule: quicksort_acc_quicksort_part.induct) auto
 
 lemma distinct_quicksort [simp]: "distinct (quicksort xs) = distinct xs"
 by(simp add: quicksort_def distinct_quicksort_acc)
 
 end
 
 lemmas [code] =
   ord.quicksort_acc.simps quicksort_acc.simps
   ord.quicksort_part.simps quicksort_part.simps
   ord.quicksort_def quicksort_def
 
 context linorder begin
 
 lemma sorted_quicksort_acc:
   "\<lbrakk> sorted ac; \<forall>x \<in> set xs. \<forall>a \<in> set ac. x < a \<rbrakk>
   \<Longrightarrow> sorted (quicksort_acc ac xs)"
   and sorted_quicksort_part:
   "\<lbrakk> sorted ac; \<forall>y \<in> set lts \<union> {x} \<union> set eqs \<union> set gts \<union> set zs. \<forall>a \<in> set ac. y < a;
      \<forall>y \<in> set lts. y < x; \<forall>y \<in> set eqs. y = x; \<forall>y \<in> set gts. y > x \<rbrakk>
   \<Longrightarrow> sorted (quicksort_part ac x lts eqs gts zs)"
 proof(induction ac xs and ac x lts eqs gts zs rule: quicksort_acc_quicksort_part.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by(auto)
 next
   case 3 thus ?case by simp
 next
   case (4 ac x lts eqs gts)
   note ac_greater = \<open>\<forall>y\<in>set lts \<union> {x} \<union> set eqs \<union> set gts \<union> set []. \<forall>a\<in>set ac. y < a\<close>
   have "sorted eqs" "set eqs \<subseteq> {x}" using \<open>\<forall>y\<in>set eqs. y = x\<close> 
     by(induct eqs)(simp_all)
   moreover have "\<forall>y \<in> set ac \<union> set gts. x \<le> y"
     using \<open>\<forall>a\<in>set gts. x < a\<close> ac_greater by auto
   moreover have "sorted (quicksort_acc ac gts)" 
     using \<open>sorted ac\<close> ac_greater by(auto intro: "4.IH")
   ultimately have "sorted (eqs @ x # quicksort_acc ac gts)"
     by(auto simp add: sorted_append)
   moreover have "\<forall>y\<in>set lts. \<forall>a\<in>set (eqs @ x # quicksort_acc ac gts). y < a"
     using \<open>\<forall>y\<in>set lts. y < x\<close> ac_greater \<open>\<forall>a\<in>set gts. x < a\<close> \<open>\<forall>y\<in>set eqs. y = x\<close>
     by fastforce
   ultimately show ?case by(simp add: "4.IH")
 next
   case 5 thus ?case by(simp add: not_less eq_iff)
 qed
 
 lemma sorted_quicksort [simp]: "sorted (quicksort xs)"
 by(simp add: quicksort_def sorted_quicksort_acc)
 
 lemma insort_key_append1:
   "\<forall>y \<in> set ys. f x < f y \<Longrightarrow> insort_key f x (xs @ ys) = insort_key f x xs @ ys"
 proof(induct xs)
   case Nil
   thus ?case by(cases ys) auto
 qed simp
 
 lemma insort_key_append2:
   "\<forall>y \<in> set xs. f x > f y \<Longrightarrow> insort_key f x (xs @ ys) = xs @ insort_key f x ys"
 by(induct xs) auto
 
 lemma sort_key_append:
   "\<forall>x\<in>set xs. \<forall>y\<in>set ys. f x < f y \<Longrightarrow> sort_key f (xs @ ys) = sort_key f xs @ sort_key f ys"
 by(induct xs)(simp_all add: insort_key_append1)
 
 definition single_list :: "'a \<Rightarrow> 'a list" where "single_list a = [a]"
 
 lemma to_single_list: "x # xs = single_list x @ xs"
 by(simp add: single_list_def)
 
 lemma sort_snoc: "sort (xs @ [x]) = insort x (sort xs)"
 by(induct xs)(simp_all add: insort_left_comm)
 
 lemma sort_append_swap: "sort (xs @ ys) = sort (ys @ xs)"
 by(induct xs arbitrary: ys rule: rev_induct)(simp_all add: sort_snoc[symmetric])
 
 lemma sort_append_swap2: "sort (xs @ ys @ zs) = sort (ys @ xs @ zs)"
 by(induct xs)(simp_all, subst (1 2) sort_append_swap, simp)
 
 
 lemma sort_Cons_append_swap: "sort (x # xs) = sort (xs @ [x])"
 by(subst sort_append_swap) simp
 
 lemma sort_append_Cons_swap: "sort (ys @ x # xs) = sort (ys @ xs @ [x])"
 apply(induct ys)
  apply(simp only: append.simps sort_Cons_append_swap)
 apply simp
 done
 
 lemma quicksort_acc_conv_sort: 
   "quicksort_acc ac xs = sort xs @ ac"
   and quicksort_part_conv_sort: 
   "\<lbrakk> \<forall>y \<in> set lts. y < x; \<forall>y \<in> set eqs. y = x; \<forall>y \<in> set gts. y > x \<rbrakk> 
   \<Longrightarrow> quicksort_part ac x lts eqs gts zs = sort (lts @ eqs @ gts @ x # zs) @ ac"
 proof(induct ac xs and ac x lts eqs gts zs rule: quicksort_acc_quicksort_part.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by simp
 next
   case 3 thus ?case by simp
 next
   case (4 ac x lts eqs gts)
   note eqs = \<open>\<forall>y\<in>set eqs. y = x\<close>
   { fix eqs
     assume "\<forall>y\<in>set eqs. y = x"
     hence "insort x eqs = x # eqs" by(induct eqs) simp_all }
   note [simp] = this
   from eqs have [simp]: "sort eqs = eqs" by(induct eqs) simp_all
   from eqs have [simp]: "eqs @ [x] = x # eqs" by(induct eqs) simp_all
 
   show ?case using 4
     apply(subst sort_key_append)
      apply(auto 4 3 dest: bspec)[1]
     apply(simp add: append_assoc[symmetric] sort_snoc del: append_assoc)
     apply(subst sort_key_append)
     apply(auto 4 3 simp add: insort_key_append1 dest: bspec)
     done
 next
   case (5 ac x lts eqs gts z zs)
   have "\<lbrakk> \<not> z < x; \<not> x < z \<rbrakk> \<Longrightarrow> z = x" by simp
   thus ?case using 5
     apply(simp del: sort_key_simps)
     apply(safe, simp_all del: sort_key_simps add: to_single_list)
       apply(subst sort_append_swap)
       apply(fold append_assoc)
       apply(subst (2) sort_append_swap)
       apply(subst sort_append_swap2)
       apply(unfold append_assoc)
       apply(rule refl)
      apply(subst (1 5) append_assoc[symmetric])
      apply(subst (1 2) sort_append_swap)
      apply(unfold append_assoc)
      apply(subst sort_append_swap2)
      apply(subst (1 2) sort_append_swap)
      apply(unfold append_assoc)
      apply(subst sort_append_swap2)
      apply(rule refl)
     apply(subst (2 6) append_assoc[symmetric])
     apply(subst (2 5) append_assoc[symmetric])
     apply(subst (1 2) sort_append_swap2)
     apply(subst (4) append_assoc)
     apply(subst (2) sort_append_swap2)
     apply simp
     done
 qed
 
 lemma quicksort_conv_sort: "quicksort xs = sort xs"
 by(simp add: quicksort_def quicksort_acc_conv_sort)
 
 lemma sort_remdups: "sort (remdups xs) = remdups (sort xs)"
 by(rule sorted_distinct_set_unique) simp_all
 
 end
 
 text \<open>Removing duplicates from a sorted list\<close>
 
 context ord begin
 
 fun remdups_sorted :: "'a list \<Rightarrow> 'a list"
 where
   "remdups_sorted [] = []"
 | "remdups_sorted [x] = [x]"
 | "remdups_sorted (x#y#xs) = (if x < y then x # remdups_sorted (y#xs) else remdups_sorted (y#xs))"
 
 end
 
 lemmas [code] = ord.remdups_sorted.simps
 
 context linorder begin
 
 lemma [simp]:
   assumes "sorted xs"
   shows sorted_remdups_sorted: "sorted (remdups_sorted xs)"
   and set_remdups_sorted: "set (remdups_sorted xs) = set xs"
 using assms by(induct xs rule: remdups_sorted.induct)(auto)
 
 lemma distinct_remdups_sorted [simp]: "sorted xs \<Longrightarrow> distinct (remdups_sorted xs)"
 by(induct xs rule: remdups_sorted.induct)(auto)
 
 lemma remdups_sorted_conv_remdups: "sorted xs \<Longrightarrow> remdups_sorted xs = remdups xs"
 by(induct xs rule: remdups_sorted.induct)(auto)
 
 end
 
 text \<open>An specialised operation to convert a finite set into a sorted list\<close>
 
 definition csorted_list_of_set :: "'a :: ccompare set \<Rightarrow> 'a list"
 where [code del]: 
   "csorted_list_of_set A = 
   (if ID CCOMPARE('a) = None \<or> \<not> finite A then undefined else linorder.sorted_list_of_set cless_eq A)"
 
 lemma csorted_list_of_set_set [simp]:
   "\<lbrakk> ID CCOMPARE('a :: ccompare) = Some c; linorder.sorted (le_of_comp c) xs; distinct xs \<rbrakk> 
   \<Longrightarrow> linorder.sorted_list_of_set (le_of_comp c) (set xs) = xs"
 by(simp add: distinct_remdups_id linorder.sorted_list_of_set_sort_remdups[OF ID_ccompare] linorder.sorted_sort_id[OF ID_ccompare])
 
 lemma csorted_list_of_set_split:
   fixes A :: "'a :: ccompare set" shows
   "P (csorted_list_of_set A) \<longleftrightarrow> 
   (\<forall>xs. ID CCOMPARE('a) \<noteq> None \<longrightarrow> finite A \<longrightarrow> A = set xs \<longrightarrow> distinct xs \<longrightarrow> linorder.sorted cless_eq xs \<longrightarrow> P xs) \<and> 
   (ID CCOMPARE('a) = None \<or> \<not> finite A \<longrightarrow> P undefined)"
 by(auto simp add: csorted_list_of_set_def linorder.sorted_list_of_set[OF ID_ccompare])
 
 code_identifier code_module Set \<rightharpoonup> (SML) Set_Impl
   | code_module Set_Impl \<rightharpoonup> (SML) Set_Impl
 
 subsection \<open>Delete code equation with set as constructor\<close>
 
 lemma is_empty_unfold [code_unfold]:
   "set_eq A {} = Set.is_empty A"
   "set_eq {} A = Set.is_empty A"
 by(auto simp add: Set.is_empty_def set_eq_def)
 
 definition is_UNIV :: "'a set \<Rightarrow> bool"
 where [code del]: "is_UNIV A \<longleftrightarrow> A = UNIV"
 
 lemma is_UNIV_unfold [code_unfold]: 
   "A = UNIV \<longleftrightarrow> is_UNIV A" 
   "UNIV = A \<longleftrightarrow> is_UNIV A"
   "set_eq A UNIV \<longleftrightarrow> is_UNIV A"
   "set_eq UNIV A \<longleftrightarrow> is_UNIV A"
 by(auto simp add: is_UNIV_def set_eq_def)
 
 lemma [code_unfold del, symmetric, code_post del]:
   "x \<in> set xs \<equiv> List.member xs x" 
 by(simp add: List.member_def)
 
 lemma [code_unfold del, symmetric, code_post del]:
   "finite \<equiv> Cardinality.finite'" by(simp)
 
 lemma [code_unfold del, symmetric, code_post del]:
   "card \<equiv> Cardinality.card'" by simp
 
 declare [[code drop:
   Set.empty
   Set.is_empty
   uminus_set_inst.uminus_set
   Set.member
   Set.insert
   Set.remove
   UNIV
   Set.filter
   image
   Set.subset_eq
   Ball
   Bex
   Set.union
   minus_set_inst.minus_set
   Set.inter
   card
   Set.bind
   the_elem
   Pow
   sum
   Gcd
   Lcm
   Product_Type.product
   Id_on
   Image
   trancl
   relcomp
   wf
   Min
   Inf_fin
   Max
   Sup_fin
   "Inf :: 'a set set \<Rightarrow> 'a set"
   "Sup :: 'a set set \<Rightarrow> 'a set"
   sorted_list_of_set
   List.map_project
   Sup_pred_inst.Sup_pred
   finite
   Cardinality.finite'
   card
   Cardinality.card'
   Inf_pred_inst.Inf_pred
   pred_of_set
   Cardinality.subset'
   Cardinality.eq_set
   Wellfounded.acc
   Bleast
   can_select
   "set_eq :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool"
   irrefl
   bacc
   set_of_pred
   set_of_seq
   ]]
 
 declare 
   Cardinality.finite'_def[code]
   Cardinality.card'_def[code]
 
 subsection \<open>Set implementations\<close>
 
 definition Collect_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set"
 where [simp]: "Collect_set = Collect"
 
 definition DList_set :: "'a :: ceq set_dlist \<Rightarrow> 'a set"
 where "DList_set = Collect o DList_Set.member"
 
 definition RBT_set :: "'a :: ccompare set_rbt \<Rightarrow> 'a set"
 where "RBT_set = Collect o RBT_Set2.member"
 
 definition Complement :: "'a set \<Rightarrow> 'a set"
 where [simp]: "Complement A = - A"
 
 definition Set_Monad :: "'a list \<Rightarrow> 'a set"
 where [simp]: "Set_Monad = set"
 
 code_datatype Collect_set DList_set RBT_set Set_Monad Complement
 
 lemma DList_set_empty [simp]: "DList_set DList_Set.empty = {}"
 by(simp add: DList_set_def)
 
 lemma RBT_set_empty [simp]: "RBT_set RBT_Set2.empty = {}"
 by(simp add: RBT_set_def)
 
 lemma RBT_set_conv_keys: 
   "ID CCOMPARE('a :: ccompare) \<noteq> None 
   \<Longrightarrow> RBT_set (t :: 'a set_rbt) = set (RBT_Set2.keys t)"
 by(clarsimp simp add: RBT_set_def member_conv_keys)
 
 subsection \<open>Set operations\<close>
 
 text \<open>
   A collection of all the theorems about @{const Complement}.
 \<close>
 ML \<open>
 structure Set_Complement_Eqs = Named_Thms
 (
   val name = @{binding set_complement_code}
   val description = "Code equations involving set complement"
 )
 \<close>
 setup \<open>Set_Complement_Eqs.setup\<close>
 
 text \<open>Various fold operations over sets\<close>
 
 typedef ('a, 'b) comp_fun_commute = "{f :: 'a \<Rightarrow> 'b \<Rightarrow> 'b. comp_fun_commute f}"
   morphisms comp_fun_commute_apply Abs_comp_fun_commute
 by(rule exI[where x="\<lambda>_. id"])(simp, unfold_locales, auto)
 
 setup_lifting type_definition_comp_fun_commute
 
 lemma comp_fun_commute_apply' [simp]:
   "comp_fun_commute (comp_fun_commute_apply f)"
 using comp_fun_commute_apply[of f] by simp
 
 lift_definition set_fold_cfc :: "('a, 'b) comp_fun_commute \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b" is "Finite_Set.fold" .
 
 declare [[code drop: set_fold_cfc]]
 
 lemma set_fold_cfc_code [code]:
   fixes xs :: "'a :: ceq list" 
   and dxs :: "'a :: ceq set_dlist"
   and rbt :: "'b :: ccompare set_rbt"
   shows set_fold_cfc_Complement[set_complement_code]:
   "set_fold_cfc f''' b (Complement A) = Code.abort (STR ''set_fold_cfc not supported on Complement'') (\<lambda>_. set_fold_cfc f''' b (Complement A))"
   and
   "set_fold_cfc f''' b (Collect_set P) = Code.abort (STR ''set_fold_cfc not supported on Collect_set'') (\<lambda>_. set_fold_cfc f''' b (Collect_set P))"
   "set_fold_cfc f b (Set_Monad xs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''set_fold_cfc Set_Monad: ceq = None'') (\<lambda>_. set_fold_cfc f b (Set_Monad xs))
                  | Some eq \<Rightarrow> List.fold (comp_fun_commute_apply f) (equal_base.list_remdups eq xs) b)"
   (is ?Set_Monad)
   "set_fold_cfc f' b (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''set_fold_cfc DList_set: ceq = None'') (\<lambda>_. set_fold_cfc f' b (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.fold (comp_fun_commute_apply f') dxs b)"
   (is ?DList_set)
   "set_fold_cfc f'' b (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''set_fold_cfc RBT_set: ccompare = None'') (\<lambda>_. set_fold_cfc f'' b (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_Set2.fold (comp_fun_commute_apply f'') rbt b)"
   (is ?RBT_set)
 proof -
   show ?Set_Monad
     by(auto split: option.split dest!: Collection_Eq.ID_ceq simp add: set_fold_cfc_def comp_fun_commute.fold_set_fold_remdups)
   show ?DList_set
     apply(auto split: option.split simp add: DList_set_def)
     apply transfer
     apply(auto dest: Collection_Eq.ID_ceq simp add: List.member_def[abs_def] comp_fun_commute.fold_set_fold_remdups distinct_remdups_id)
     done
   show ?RBT_set
     apply(auto split: option.split simp add: RBT_set_conv_keys fold_conv_fold_keys)
     apply transfer
     apply(simp add: comp_fun_commute.fold_set_fold_remdups distinct_remdups_id linorder.distinct_keys[OF ID_ccompare] ord.is_rbt_rbt_sorted)
     done
 qed simp_all
 
 typedef ('a, 'b) comp_fun_idem = "{f :: 'a \<Rightarrow> 'b \<Rightarrow> 'b. comp_fun_idem f}"
   morphisms comp_fun_idem_apply Abs_comp_fun_idem
 by(rule exI[where x="\<lambda>_. id"])(simp, unfold_locales, auto)
 
 setup_lifting type_definition_comp_fun_idem
 
 lemma comp_fun_idem_apply' [simp]:
   "comp_fun_idem (comp_fun_idem_apply f)"
 using comp_fun_idem_apply[of f] by simp
 
 lift_definition set_fold_cfi :: "('a, 'b) comp_fun_idem \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b" is "Finite_Set.fold" .
 
 declare [[code drop: set_fold_cfi]]
 
 lemma set_fold_cfi_code [code]:
   fixes xs :: "'a list" 
   and dxs :: "'b :: ceq set_dlist"
   and rbt :: "'c :: ccompare set_rbt" shows
   "set_fold_cfi f b (Complement A) = Code.abort (STR ''set_fold_cfi not supported on Complement'') (\<lambda>_. set_fold_cfi f b (Complement A))"
   "set_fold_cfi f b (Collect_set P) = Code.abort (STR ''set_fold_cfi not supported on Collect_set'') (\<lambda>_. set_fold_cfi f b (Collect_set P))"
   "set_fold_cfi f b (Set_Monad xs) = List.fold (comp_fun_idem_apply f) xs b"
   (is ?Set_Monad)
   "set_fold_cfi f' b (DList_set dxs) =
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''set_fold_cfi DList_set: ceq = None'') (\<lambda>_. set_fold_cfi f' b (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.fold (comp_fun_idem_apply f') dxs b)"
   (is ?DList_set)
   "set_fold_cfi f'' b (RBT_set rbt) =
   (case ID CCOMPARE('c) of None \<Rightarrow> Code.abort (STR ''set_fold_cfi RBT_set: ccompare = None'') (\<lambda>_. set_fold_cfi f'' b (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_Set2.fold (comp_fun_idem_apply f'') rbt b)"
   (is ?RBT_set)
 proof -
   show ?Set_Monad
     by(auto split: option.split dest!: Collection_Eq.ID_ceq simp add: set_fold_cfi_def comp_fun_idem.fold_set_fold)
   show ?DList_set
     apply(auto split: option.split simp add: DList_set_def)
     apply transfer
     apply(auto dest: Collection_Eq.ID_ceq simp add: List.member_def[abs_def] comp_fun_idem.fold_set_fold)
     done
   show ?RBT_set
     apply(auto split: option.split simp add: RBT_set_conv_keys fold_conv_fold_keys)
     apply transfer
     apply(simp add: comp_fun_idem.fold_set_fold)
     done
 qed simp_all
 
 typedef 'a semilattice_set = "{f :: 'a \<Rightarrow> 'a \<Rightarrow> 'a. semilattice_set f}"
   morphisms semilattice_set_apply Abs_semilattice_set
 proof
   show "(\<lambda>x y. if x = y then x else undefined) \<in> ?semilattice_set"
     unfolding mem_Collect_eq by(unfold_locales) simp_all
 qed
 
 setup_lifting type_definition_semilattice_set
 
 lemma semilattice_set_apply' [simp]:
   "semilattice_set (semilattice_set_apply f)"
 using semilattice_set_apply[of f] by simp
 
 lemma comp_fun_idem_semilattice_set_apply [simp]:
   "comp_fun_idem (semilattice_set_apply f)"
 proof -
   interpret semilattice_set "semilattice_set_apply f" by simp
   show ?thesis by(unfold_locales)(simp_all add: fun_eq_iff left_commute)
 qed 
 
 lift_definition set_fold1 :: "'a semilattice_set \<Rightarrow> 'a set \<Rightarrow> 'a" is "semilattice_set.F" .
 
 lemma (in semilattice_set) F_set_conv_fold:
   "xs \<noteq> [] \<Longrightarrow> F (set xs) = Finite_Set.fold f (hd xs) (set (tl xs))"
 by(clarsimp simp add: neq_Nil_conv eq_fold)
 
 lemma set_fold1_code [code]:
   fixes rbt :: "'a :: {ccompare, lattice} set_rbt"
   and dxs :: "'b :: {ceq, lattice} set_dlist" shows
   set_fold1_Complement[set_complement_code]:
   "set_fold1 f (Complement A) = Code.abort (STR ''set_fold1: Complement'') (\<lambda>_. set_fold1 f (Complement A))"
   and "set_fold1 f (Collect_set P) = Code.abort (STR ''set_fold1: Collect_set'') (\<lambda>_. set_fold1 f (Collect_set P))"
   and "set_fold1 f (Set_Monad (x # xs)) = fold (semilattice_set_apply f) xs x" (is "?Set_Monad")
   and
   "set_fold1 f' (DList_set dxs) =
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''set_fold1 DList_set: ceq = None'') (\<lambda>_. set_fold1 f' (DList_set dxs))
                   | Some _ \<Rightarrow> if DList_Set.null dxs then Code.abort (STR ''set_fold1 DList_set: empty set'') (\<lambda>_. set_fold1 f' (DList_set dxs))
                               else DList_Set.fold (semilattice_set_apply f') (DList_Set.tl dxs) (DList_Set.hd dxs))"
   (is "?DList_set")
   and
   "set_fold1 f'' (RBT_set rbt) =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''set_fold1 RBT_set: ccompare = None'') (\<lambda>_. set_fold1 f'' (RBT_set rbt))
                      | Some _ \<Rightarrow> if RBT_Set2.is_empty rbt then Code.abort (STR ''set_fold1 RBT_set: empty set'') (\<lambda>_. set_fold1 f'' (RBT_set rbt))
                                  else RBT_Set2.fold1 (semilattice_set_apply f'') rbt)"
   (is "?RBT_set")
 proof -
   show ?Set_Monad
     by(simp add: set_fold1_def semilattice_set.eq_fold comp_fun_idem.fold_set_fold)
   show ?DList_set
     by(simp add: set_fold1_def semilattice_set.F_set_conv_fold comp_fun_idem.fold_set_fold DList_set_def DList_Set.Collect_member split: option.split)(transfer, simp)
   show ?RBT_set
     by(simp add: set_fold1_def semilattice_set.F_set_conv_fold comp_fun_idem.fold_set_fold RBT_set_def RBT_Set2.member_conv_keys RBT_Set2.fold1_conv_fold split: option.split)
 qed simp_all
 
 text \<open>Implementation of set operations\<close>
 
 lemma Collect_code [code]:
   fixes P :: "'a :: cenum \<Rightarrow> bool" shows
   "Collect P =
   (case ID CENUM('a) of None \<Rightarrow> Collect_set P
             | Some (enum, _) \<Rightarrow> Set_Monad (filter P enum))"
 by(auto split: option.split dest: in_cenum)
 
 lemma finite_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt"
   and A :: "'c :: finite_UNIV set" and P :: "'c \<Rightarrow> bool" shows
   "finite (DList_set dxs) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''finite DList_set: ceq = None'') (\<lambda>_. finite (DList_set dxs))
                  | Some _ \<Rightarrow> True)"
   "finite (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''finite RBT_set: ccompare = None'') (\<lambda>_. finite (RBT_set rbt))
                      | Some _ \<Rightarrow> True)"
   and finite_Complement [set_complement_code]:
   "finite (Complement A) \<longleftrightarrow>
   (if of_phantom (finite_UNIV :: 'c finite_UNIV) then True
    else if finite A then False
    else Code.abort (STR ''finite Complement: infinite set'') (\<lambda>_. finite (Complement A)))"
   and
   "finite (Set_Monad xs) = True"
   "finite (Collect_set P) \<longleftrightarrow>
   of_phantom (finite_UNIV :: 'c finite_UNIV) \<or> Code.abort (STR ''finite Collect_set'') (\<lambda>_. finite (Collect_set P))"
 by(auto simp add: DList_set_def RBT_set_def member_conv_keys card_gt_0_iff finite_UNIV split: option.split elim: finite_subset[rotated 1])
 
 lemma card_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" and xs :: "'a list"
   and rbt :: "'b :: ccompare set_rbt" 
   and A :: "'c :: card_UNIV set" shows
   "card (DList_set dxs) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''card DList_set: ceq = None'') (\<lambda>_. card (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.length dxs)"
   "card (RBT_set rbt) = 
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''card RBT_set: ccompare = None'') (\<lambda>_. card (RBT_set rbt))
                     | Some _ \<Rightarrow> length (RBT_Set2.keys rbt))"
   "card (Set_Monad xs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''card Set_Monad: ceq = None'') (\<lambda>_. card (Set_Monad xs))
                  | Some eq \<Rightarrow> length (equal_base.list_remdups eq xs))"
   and card_Complement [set_complement_code]:
   "card (Complement A) =
    (let a = card A; s = CARD('c)
     in if s > 0 then s - a 
        else if finite A then 0
        else Code.abort (STR ''card Complement: infinite'') (\<lambda>_. card (Complement A)))" 
 by(auto simp add: RBT_set_def member_conv_keys distinct_card DList_set_def Let_def card_UNIV Compl_eq_Diff_UNIV card_Diff_subset_Int card_gt_0_iff finite_subset[of A UNIV] List.card_set dest: Collection_Eq.ID_ceq split: option.split)
 
 lemma is_UNIV_code [code]:
   fixes rbt :: "'a :: {cproper_interval, finite_UNIV} set_rbt" 
   and A :: "'b :: card_UNIV set" shows
   "is_UNIV A \<longleftrightarrow>
    (let a = CARD('b);
         b = card A
     in if a > 0 then a = b
        else if b > 0 then False
        else Code.abort (STR ''is_UNIV called on infinite type and set'') (\<lambda>_. is_UNIV A))"
   (is ?generic)
   "is_UNIV (RBT_set rbt) = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''is_UNIV RBT_set: ccompare = None'') (\<lambda>_. is_UNIV (RBT_set rbt))
                      | Some _ \<Rightarrow> of_phantom (finite_UNIV :: 'a finite_UNIV) \<and> proper_intrvl.exhaustive_fusion cproper_interval rbt_keys_generator (RBT_Set2.init rbt))"
   (is ?rbt)
 proof -
   {
     fix c
     assume linorder: "ID CCOMPARE('a) = Some c"
     have "is_UNIV (RBT_set rbt) =
       (finite (UNIV :: 'a set) \<and> proper_intrvl.exhaustive cproper_interval (RBT_Set2.keys rbt))"
       (is "?lhs \<longleftrightarrow> ?rhs")
     proof
       assume ?lhs
       have "finite (UNIV :: 'a set)"
         unfolding \<open>?lhs\<close>[unfolded is_UNIV_def, symmetric]
         using linorder 
         by(simp add: finite_code)
       moreover
       hence "proper_intrvl.exhaustive cproper_interval (RBT_Set2.keys rbt)"
         using linorder \<open>?lhs\<close>
         by(simp add: linorder_proper_interval.exhaustive_correct[OF ID_ccompare_interval[OF linorder]] sorted_RBT_Set_keys is_UNIV_def RBT_set_conv_keys)
       ultimately show ?rhs ..
     next
       assume ?rhs
       thus ?lhs using linorder
         by(auto simp add: linorder_proper_interval.exhaustive_correct[OF ID_ccompare_interval[OF linorder]] sorted_RBT_Set_keys is_UNIV_def RBT_set_conv_keys)
     qed }
   thus ?rbt
     by(auto simp add: finite_UNIV proper_intrvl.exhaustive_fusion_def unfoldr_rbt_keys_generator is_UNIV_def split: option.split)
 
   show ?generic
     by(auto simp add: Let_def is_UNIV_def dest: card_seteq[of UNIV A] dest!: card_ge_0_finite)
 qed
 
 lemma is_empty_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" 
   and A :: "'c set" shows
   "Set.is_empty (Set_Monad xs) \<longleftrightarrow> xs = []"
   "Set.is_empty (DList_set dxs) \<longleftrightarrow> 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''is_empty DList_set: ceq = None'') (\<lambda>_. Set.is_empty (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.null dxs)" (is ?DList_set)
   "Set.is_empty (RBT_set rbt) \<longleftrightarrow> 
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''is_empty RBT_set: ccompare = None'') (\<lambda>_. Set.is_empty (RBT_set rbt))
                   | Some _ \<Rightarrow> RBT_Set2.is_empty rbt)" (is ?RBT_set)
   and is_empty_Complement [set_complement_code]:
   "Set.is_empty (Complement A) \<longleftrightarrow> is_UNIV A" (is ?Complement)
 proof -
   show ?DList_set
     by(clarsimp simp add: DList_set_def Set.is_empty_def DList_Set.member_empty_empty split: option.split)
 
   show ?RBT_set
     by(clarsimp simp add: RBT_set_def Set.is_empty_def RBT_Set2.member_empty_empty[symmetric] fun_eq_iff simp del: RBT_Set2.member_empty_empty split: option.split)
 
   show ?Complement
     by(auto simp add: is_UNIV_def Set.is_empty_def)
 qed(simp_all add: Set.is_empty_def List.null_def)
 
 lemma Set_insert_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "\<And>x. Set.insert x (Collect_set A) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''insert Collect_set: ceq = None'') (\<lambda>_. Set.insert x (Collect_set A))
                 | Some eq \<Rightarrow> Collect_set (equal_base.fun_upd eq A x True))"
   "\<And>x. Set.insert x (Set_Monad xs) = Set_Monad (x # xs)"
   "\<And>x. Set.insert x (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''insert DList_set: ceq = None'') (\<lambda>_. Set.insert x (DList_set dxs))
                   | Some _ \<Rightarrow> DList_set (DList_Set.insert x dxs))"
   "\<And>x. Set.insert x (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''insert RBT_set: ccompare = None'') (\<lambda>_. Set.insert x (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_set (RBT_Set2.insert x rbt))"
   and insert_Complement [set_complement_code]:
   "\<And>x. Set.insert x (Complement X) = Complement (Set.remove x X)"
 by(auto split: option.split dest: equal.equal_eq[OF ID_ceq] simp add: DList_set_def DList_Set.member_insert RBT_set_def)
 
 lemma Set_member_code [code]:
   fixes xs :: "'a :: ceq list" shows
   "\<And>x. x \<in> Collect_set A \<longleftrightarrow> A x"
   "\<And>x. x \<in> DList_set dxs \<longleftrightarrow> DList_Set.member dxs x"
   "\<And>x. x \<in> RBT_set rbt \<longleftrightarrow> RBT_Set2.member rbt x"
   and mem_Complement [set_complement_code]:
   "\<And>x. x \<in> Complement X \<longleftrightarrow> x \<notin> X"
   and
   "\<And>x. x \<in> Set_Monad xs \<longleftrightarrow>
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''member Set_Monad: ceq = None'') (\<lambda>_. x \<in> Set_Monad xs)
                  | Some eq \<Rightarrow> equal_base.list_member eq xs x)"
 by(auto simp add: DList_set_def RBT_set_def List.member_def split: option.split dest!: Collection_Eq.ID_ceq)
 
 lemma Set_remove_code [code]:
   fixes rbt :: "'a :: ccompare set_rbt"
   and dxs :: "'b :: ceq set_dlist" shows
   "\<And>x. Set.remove x (Collect_set A) =
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''remove Collect: ceq = None'') (\<lambda>_. Set.remove x (Collect_set A))
                  | Some eq \<Rightarrow> Collect_set (equal_base.fun_upd eq A x False))"
   "\<And>x. Set.remove x (DList_set dxs) = 
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''remove DList_set: ceq = None'') (\<lambda>_. Set.remove x (DList_set dxs))
                   | Some _ \<Rightarrow> DList_set (DList_Set.remove x dxs))"
   "\<And>x. Set.remove x (RBT_set rbt) =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''remove RBT_set: ccompare = None'') (\<lambda>_. Set.remove x (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_set (RBT_Set2.remove x rbt))"
   and remove_Complement [set_complement_code]:
   "\<And>x A. Set.remove x (Complement A) = Complement (Set.insert x A)"
 by(auto split: option.split if_split_asm dest: equal.equal_eq[OF ID_ceq] simp add: DList_set_def DList_Set.member_remove RBT_set_def)
 
 lemma Set_uminus_code [code, set_complement_code]:
   "- A = Complement A"
   "- (Collect_set P) = Collect_set (\<lambda>x. \<not> P x)"
   "- (Complement B) = B"
 by auto
 
 text \<open>
   These equations represent complements as true complements.
   If you want that the complement operations returns an explicit enumeration of the elements, use the following set of equations which use @{class cenum}.
 \<close>
 
 lemma Set_uminus_cenum:
   fixes A :: "'a :: cenum set" shows
   "- A =
   (case ID CENUM('a) of None \<Rightarrow> Complement A
             | Some (enum, _) \<Rightarrow> Set_Monad (filter (\<lambda>x. x \<notin> A) enum))"
   and "- (Complement B) = B"
 by(auto split: option.split dest: ID_cEnum)
 
 lemma Set_minus_code [code]: "A - B = A \<inter> (- B)"
 by(rule Diff_eq)
 
 lemma Set_union_code [code]:
   fixes rbt1 rbt2 :: "'a :: ccompare set_rbt"
   and rbt :: "'b :: {ccompare, ceq} set_rbt"
   and dxs :: "'b set_dlist"
   and dxs1 dxs2 :: "'c :: ceq set_dlist" shows
   "RBT_set rbt1 \<union> RBT_set rbt2 =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''union RBT_set RBT_set: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<union> RBT_set rbt2)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.union rbt1 rbt2))" (is ?RBT_set_RBT_set)
   "RBT_set rbt \<union> DList_set dxs =
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''union RBT_set DList_set: ccompare = None'') (\<lambda>_. RBT_set rbt \<union> DList_set dxs)
                       | Some _ \<Rightarrow>
        case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''union RBT_set DList_set: ceq = None'') (\<lambda>_. RBT_set rbt \<union> DList_set dxs)
                       | Some _ \<Rightarrow> RBT_set (DList_Set.fold RBT_Set2.insert dxs rbt))" (is ?RBT_set_DList_set)
   "DList_set dxs \<union> RBT_set rbt =
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''union DList_set RBT_set: ccompare = None'') (\<lambda>_. RBT_set rbt \<union> DList_set dxs)
                       | Some _ \<Rightarrow>
        case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''union DList_set RBT_set: ceq = None'') (\<lambda>_. RBT_set rbt \<union> DList_set dxs)
                       | Some _ \<Rightarrow> RBT_set (DList_Set.fold RBT_Set2.insert dxs rbt))" (is ?DList_set_RBT_set)
   "DList_set dxs1 \<union> DList_set dxs2 = 
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''union DList_set DList_set: ceq = None'') (\<lambda>_. DList_set dxs1 \<union> DList_set dxs2)
                       | Some _ \<Rightarrow> DList_set (DList_Set.union dxs1 dxs2))" (is ?DList_set_DList_set)
   "Set_Monad zs \<union> RBT_set rbt2 =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''union Set_Monad RBT_set: ccompare = None'') (\<lambda>_. Set_Monad zs \<union> RBT_set rbt2)
                       | Some _ \<Rightarrow> RBT_set (fold RBT_Set2.insert zs rbt2))" (is ?Set_Monad_RBT_set)
   "RBT_set rbt1 \<union> Set_Monad zs =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''union RBT_set Set_Monad: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<union> Set_Monad zs)
                       | Some _ \<Rightarrow> RBT_set (fold RBT_Set2.insert zs rbt1))" (is ?RBT_set_Set_Monad)
   "Set_Monad ws \<union> DList_set dxs2 =
   (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''union Set_Monad DList_set: ceq = None'') (\<lambda>_. Set_Monad ws \<union> DList_set dxs2)
                   | Some _ \<Rightarrow> DList_set (fold DList_Set.insert ws dxs2))" (is ?Set_Monad_DList_set)
   "DList_set dxs1 \<union> Set_Monad ws =
   (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''union DList_set Set_Monad: ceq = None'') (\<lambda>_. DList_set dxs1 \<union> Set_Monad ws)
                   | Some _ \<Rightarrow> DList_set (fold DList_Set.insert ws dxs1))" (is ?DList_set_Set_Monad)
   "Set_Monad xs \<union> Set_Monad ys = Set_Monad (xs @ ys)"
   "Collect_set A \<union> B = Collect_set (\<lambda>x. A x \<or> x \<in> B)"
   "B \<union> Collect_set A = Collect_set (\<lambda>x. A x \<or> x \<in> B)"
   and Set_union_Complement [set_complement_code]:
   "Complement B \<union> B' = Complement (B \<inter> - B')"
   "B' \<union> Complement B = Complement (- B' \<inter> B)"
 proof -
   show ?RBT_set_RBT_set ?Set_Monad_RBT_set ?RBT_set_Set_Monad
     by(auto split: option.split simp add: RBT_set_def)
 
   show ?RBT_set_DList_set ?DList_set_RBT_set
     by(auto split: option.split simp add: RBT_set_def DList_set_def DList_Set.fold_def DList_Set.member_def List.member_def dest: equal.equal_eq[OF ID_ceq])
 
   show ?DList_set_Set_Monad ?Set_Monad_DList_set
     by(auto split: option.split simp add: DList_set_def DList_Set.member_fold_insert)
 
   show ?DList_set_DList_set 
     by(auto split: option.split simp add: DList_set_def DList_Set.member_union)
 qed(auto)
 
 lemma Set_inter_code [code]:
   fixes rbt1 rbt2 :: "'a :: ccompare set_rbt"
   and rbt :: "'b :: {ccompare, ceq} set_rbt"
   and dxs :: "'b set_dlist"
   and dxs1 dxs2 :: "'c :: ceq set_dlist" 
   and xs1 xs2 :: "'c list"
   shows
   "Collect_set A'' \<inter> J = Collect_set (\<lambda>x. A'' x \<and> x \<in> J)" (is ?collect1)
   "J \<inter> Collect_set A'' = Collect_set (\<lambda>x. A'' x \<and> x \<in> J)" (is ?collect2)
 
   "Set_Monad xs'' \<inter> I = Set_Monad (filter (\<lambda>x. x \<in> I) xs'')" (is ?monad1)
   "I \<inter> Set_Monad xs'' = Set_Monad (filter (\<lambda>x. x \<in> I) xs'')" (is ?monad2)
 
   "DList_set dxs1 \<inter> H =
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter DList_set1: ceq = None'') (\<lambda>_. DList_set dxs1 \<inter> H)
                   | Some eq \<Rightarrow> DList_set (DList_Set.filter (\<lambda>x. x \<in> H) dxs1))" (is ?dlist1)
   "H \<inter> DList_set dxs2 =
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter DList_set2: ceq = None'') (\<lambda>_. H \<inter> DList_set dxs2)
                   | Some eq \<Rightarrow> DList_set (DList_Set.filter (\<lambda>x. x \<in> H) dxs2))" (is ?dlist2)
 
   "RBT_set rbt1 \<inter> G =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''inter RBT_set1: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<inter> G)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.filter (\<lambda>x. x \<in> G) rbt1))" (is ?rbt1)
   "G \<inter> RBT_set rbt2 =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''inter RBT_set2: ccompare = None'') (\<lambda>_. G \<inter> RBT_set rbt2)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.filter (\<lambda>x. x \<in> G) rbt2))" (is ?rbt2)
   and Set_inter_Complement [set_complement_code]:
   "Complement B'' \<inter> Complement B''' = Complement (B'' \<union> B''')" (is ?complement)
   and
   "Set_Monad xs \<inter> RBT_set rbt1 =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''inter Set_Monad RBT_set: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<inter> Set_Monad xs)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.inter_list rbt1 xs))" (is ?monad_rbt)
   "Set_Monad xs' \<inter> DList_set dxs2 =
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter Set_Monad DList_set: ceq = None'') (\<lambda>_. Set_Monad xs' \<inter> DList_set dxs2)
                   | Some eq \<Rightarrow> DList_set (DList_Set.filter (equal_base.list_member eq xs') dxs2))" (is ?monad_dlist)
   "Set_Monad xs1 \<inter> Set_Monad xs2 =
   (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter Set_Monad Set_Monad: ceq = None'') (\<lambda>_. Set_Monad xs1 \<inter> Set_Monad xs2)
                  | Some eq \<Rightarrow> Set_Monad (filter (equal_base.list_member eq xs2) xs1))" (is ?monad)
 
   "DList_set dxs \<inter> RBT_set rbt = 
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''inter DList_set RBT_set: ccompare = None'') (\<lambda>_. DList_set dxs \<inter> RBT_set rbt)
                       | Some _ \<Rightarrow>
        case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''inter DList_set RBT_set: ceq = None'') (\<lambda>_. DList_set dxs \<inter> RBT_set rbt)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.inter_list rbt (list_of_dlist dxs)))" (is ?dlist_rbt)
   "DList_set dxs1 \<inter> DList_set dxs2 =
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter DList_set DList_set: ceq = None'') (\<lambda>_. DList_set dxs1 \<inter> DList_set dxs2)
                    | Some _ \<Rightarrow> DList_set (DList_Set.filter (DList_Set.member dxs2) dxs1))" (is ?dlist)
   "DList_set dxs1 \<inter> Set_Monad xs' =
    (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''inter DList_set Set_Monad: ceq = None'') (\<lambda>_. DList_set dxs1 \<inter> Set_Monad xs')
                   | Some eq \<Rightarrow> DList_set (DList_Set.filter (equal_base.list_member eq xs') dxs1))" (is ?dlist_monad)
 
   "RBT_set rbt1 \<inter> RBT_set rbt2 =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''inter RBT_set RBT_set: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<inter> RBT_set rbt2)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.inter rbt1 rbt2))" (is ?rbt_rbt)
   "RBT_set rbt \<inter> DList_set dxs = 
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''inter RBT_set DList_set: ccompare = None'') (\<lambda>_. RBT_set rbt \<inter> DList_set dxs)
                       | Some _ \<Rightarrow>
        case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''inter RBT_set DList_set: ceq = None'') (\<lambda>_. RBT_set rbt \<inter> DList_set dxs)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.inter_list rbt (list_of_dlist dxs)))" (is ?rbt_dlist)
   "RBT_set rbt1 \<inter> Set_Monad xs =
    (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''inter RBT_set Set_Monad: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<inter> Set_Monad xs)
                       | Some _ \<Rightarrow> RBT_set (RBT_Set2.inter_list rbt1 xs))" (is ?rbt_monad) 
 proof -
   show ?rbt_rbt ?rbt1 ?rbt2 ?rbt_dlist ?rbt_monad ?dlist_rbt ?monad_rbt
     by(auto simp add: RBT_set_def DList_set_def DList_Set.member_def List.member_def dest: equal.equal_eq[OF ID_ceq] split: option.split)
   show ?dlist ?dlist1 ?dlist2 ?dlist_monad ?monad_dlist ?monad ?monad1 ?monad2 ?collect1 ?collect2 ?complement
     by(auto simp add: DList_set_def List.member_def dest!: Collection_Eq.ID_ceq split: option.splits)
 qed
 
 lemma Set_bind_code [code]:
   fixes dxs :: "'a :: ceq set_dlist"
   and rbt :: "'b :: ccompare set_rbt" shows
   "Set.bind (Set_Monad xs) f = fold ((\<union>) \<circ> f) xs (Set_Monad [])" (is ?Set_Monad)
   "Set.bind (DList_set dxs) f' =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''bind DList_set: ceq = None'') (\<lambda>_. Set.bind (DList_set dxs) f')
                   | Some _ \<Rightarrow> DList_Set.fold (union \<circ> f') dxs {})" (is ?DList)
   "Set.bind (RBT_set rbt) f'' = 
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''bind RBT_set: ccompare = None'') (\<lambda>_. Set.bind (RBT_set rbt) f'')
                      | Some _ \<Rightarrow> RBT_Set2.fold (union \<circ> f'') rbt {})" (is ?RBT)
 proof -
   show ?Set_Monad by(simp add: set_bind_conv_fold)
   show ?DList by(auto simp add: DList_set_def DList_Set.member_def List.member_def List.member_def[abs_def] set_bind_conv_fold DList_Set.fold_def split: option.split dest: equal.equal_eq[OF ID_ceq] ID_ceq)
   show ?RBT by(clarsimp split: option.split simp add: RBT_set_def RBT_Set2.fold_conv_fold_keys RBT_Set2.member_conv_keys set_bind_conv_fold)
 qed
 
 lemma UNIV_code [code]: "UNIV = - {}"
 by(simp)
 
 lift_definition inf_sls :: "'a :: lattice semilattice_set" is "inf" by unfold_locales
 
 lemma Inf_fin_code [code]: "Inf_fin A = set_fold1 inf_sls A"
 by transfer(simp add: Inf_fin_def)
 
 lift_definition sup_sls :: "'a :: lattice semilattice_set" is "sup" by unfold_locales
 
 lemma Sup_fin_code [code]: "Sup_fin A = set_fold1 sup_sls A"
 by transfer(simp add: Sup_fin_def)
 
 lift_definition inf_cfi :: "('a :: lattice, 'a) comp_fun_idem" is "inf"
 by(rule comp_fun_idem_inf)
 
 lemma Inf_code:
   fixes A :: "'a :: complete_lattice set" shows
   "Inf A = (if finite A then set_fold_cfi inf_cfi top A else Code.abort (STR ''Inf: infinite'') (\<lambda>_. Inf A))"
 by transfer(simp add: Inf_fold_inf)
 
 lift_definition sup_cfi :: "('a :: lattice, 'a) comp_fun_idem" is "sup"
 by(rule comp_fun_idem_sup)
 
 lemma Sup_code:
   fixes A :: "'a :: complete_lattice set" shows
   "Sup A = (if finite A then set_fold_cfi sup_cfi bot A else Code.abort (STR ''Sup: infinite'') (\<lambda>_. Sup A))"
 by transfer(simp add: Sup_fold_sup)
 
 lemmas Inter_code [code] = Inf_code[where ?'a = "_ :: type set"]
 lemmas Union_code [code] = Sup_code[where ?'a = "_ :: type set"]
 lemmas Predicate_Inf_code [code] = Inf_code[where ?'a = "_ :: type Predicate.pred"]
 lemmas Predicate_Sup_code [code] = Sup_code[where ?'a = "_ :: type Predicate.pred"]
 lemmas Inf_fun_code [code] = Inf_code[where ?'a = "_ :: type \<Rightarrow> _ :: complete_lattice"]
 lemmas Sup_fun_code [code] = Sup_code[where ?'a = "_ :: type \<Rightarrow> _ :: complete_lattice"]
 
 lift_definition min_sls :: "'a :: linorder semilattice_set" is min by unfold_locales
 
 lemma Min_code [code]: "Min A = set_fold1 min_sls A"
 by transfer(simp add: Min_def)
 
 lift_definition max_sls :: "'a :: linorder semilattice_set" is max by unfold_locales
 
 lemma Max_code [code]: "Max A = set_fold1 max_sls A"
 by transfer(simp add: Max_def)
 
 text \<open>
   We do not implement @{term Ball}, @{term Bex}, and @{term sorted_list_of_set} for @{term Collect_set} using @{term cEnum},
   because it should already have been converted to an explicit list of elements if that is possible.
 \<close>
 
 lemma Ball_code [code]:
   fixes rbt :: "'a :: ccompare set_rbt"
   and dxs :: "'b :: ceq set_dlist" shows
   "Ball (Set_Monad xs) P = list_all P xs"
   "Ball (DList_set dxs) P' = 
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''Ball DList_set: ceq = None'') (\<lambda>_. Ball (DList_set dxs) P')
                   | Some _ \<Rightarrow> DList_Set.dlist_all P' dxs)"
   "Ball (RBT_set rbt) P'' = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''Ball RBT_set: ccompare = None'') (\<lambda>_. Ball (RBT_set rbt) P'')
                      | Some _ \<Rightarrow> RBT_Set2.all P'' rbt)"
 by(simp_all add: DList_set_def RBT_set_def list_all_iff dlist_all_conv_member RBT_Set2.all_conv_all_member split: option.splits)
 
 lemma Bex_code [code]:
   fixes rbt :: "'a :: ccompare set_rbt"
   and dxs :: "'b :: ceq set_dlist" shows
   "Bex (Set_Monad xs) P = list_ex P xs"
   "Bex (DList_set dxs) P' = 
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''Bex DList_set: ceq = None'') (\<lambda>_. Bex (DList_set dxs) P')
                   | Some _ \<Rightarrow> DList_Set.dlist_ex P' dxs)"
   "Bex (RBT_set rbt) P'' = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''Bex RBT_set: ccompare = None'') (\<lambda>_. Bex (RBT_set rbt) P'')
                      | Some _ \<Rightarrow> RBT_Set2.ex P'' rbt)"
 by(simp_all add: DList_set_def RBT_set_def list_ex_iff dlist_ex_conv_member RBT_Set2.ex_conv_ex_member split: option.splits)
 
 lemma csorted_list_of_set_code [code]:
   fixes rbt :: "'a :: ccompare set_rbt" 
   and dxs :: "'b :: {ccompare, ceq} set_dlist" 
   and xs :: "'a :: ccompare list" shows
   "csorted_list_of_set (RBT_set rbt) =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''csorted_list_of_set RBT_set: ccompare = None'') (\<lambda>_. csorted_list_of_set (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_Set2.keys rbt)"
   "csorted_list_of_set (DList_set dxs) =
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''csorted_list_of_set DList_set: ceq = None'') (\<lambda>_. csorted_list_of_set (DList_set dxs))
               | Some _ \<Rightarrow>
      case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''csorted_list_of_set DList_set: ccompare = None'') (\<lambda>_. csorted_list_of_set (DList_set dxs))
                  | Some c \<Rightarrow> ord.quicksort (lt_of_comp c) (list_of_dlist dxs))"
   "csorted_list_of_set (Set_Monad xs) =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''csorted_list_of_set Set_Monad: ccompare = None'') (\<lambda>_. csorted_list_of_set (Set_Monad xs))
               | Some c \<Rightarrow> ord.remdups_sorted (lt_of_comp c) (ord.quicksort (lt_of_comp c) xs))"
 by(auto split: option.split simp add: RBT_set_def DList_set_def DList_Set.Collect_member member_conv_keys sorted_RBT_Set_keys linorder.sorted_list_of_set_sort_remdups[OF ID_ccompare] linorder.quicksort_conv_sort[OF ID_ccompare] distinct_remdups_id distinct_list_of_dlist linorder.remdups_sorted_conv_remdups[OF ID_ccompare] linorder.sorted_sort[OF ID_ccompare] linorder.sort_remdups[OF ID_ccompare] csorted_list_of_set_def)
 
 lemma cless_set_code [code]:
   fixes rbt rbt' :: "'a :: ccompare set_rbt"
   and rbt1 rbt2 :: "'b :: cproper_interval set_rbt"
   and A B :: "'a set" 
   and A' B' :: "'b set" shows
   "cless_set A B \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_set: ccompare = None'') (\<lambda>_. cless_set A B)
               | Some c \<Rightarrow>
-     if finite A \<and> finite B then order.lexordp (\<lambda>x y. lt_of_comp c y x) (csorted_list_of_set A) (csorted_list_of_set B)
+     if finite A \<and> finite B then ord.lexordp (\<lambda>x y. lt_of_comp c y x) (csorted_list_of_set A) (csorted_list_of_set B)
      else Code.abort (STR ''cless_set: infinite set'') (\<lambda>_. cless_set A B))"
   (is "?fin_fin")
   and cless_set_Complement2 [set_complement_code]:
   "cless_set A' (Complement B') \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_set Complement2: ccompare = None'') (\<lambda>_. cless_set A' (Complement B'))
               | Some c \<Rightarrow>
      if finite A' \<and> finite B' then
         finite (UNIV :: 'b set) \<longrightarrow>
         proper_intrvl.set_less_aux_Compl (lt_of_comp c) cproper_interval None (csorted_list_of_set A') (csorted_list_of_set B')
      else Code.abort (STR ''cless_set Complement2: infinite set'') (\<lambda>_. cless_set A' (Complement B')))"
   (is "?fin_Compl_fin")
   and cless_set_Complement1 [set_complement_code]:
   "cless_set (Complement A') B' \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_set Complement1: ccompare = None'') (\<lambda>_. cless_set (Complement A') B')
               | Some c \<Rightarrow>
       if finite A' \<and> finite B' then
         finite (UNIV :: 'b set) \<and>
         proper_intrvl.Compl_set_less_aux (lt_of_comp c) cproper_interval None (csorted_list_of_set A') (csorted_list_of_set B')
       else Code.abort (STR ''cless_set Complement1: infinite set'') (\<lambda>_. cless_set (Complement A') B'))"
   (is "?Compl_fin_fin")
   and cless_set_Complement12 [set_complement_code]:
   "cless_set (Complement A) (Complement B) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_set Complement Complement: ccompare = None'') (\<lambda>_. cless_set (Complement A) (Complement B))
                      | Some _ \<Rightarrow> cless B A)" (is ?Compl_Compl)
   and
   "cless_set (RBT_set rbt) (RBT_set rbt') \<longleftrightarrow> 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_set RBT_set RBT_set: ccompare = None'') (\<lambda>_. cless_set (RBT_set rbt) (RBT_set rbt'))
-             | Some c \<Rightarrow> order.lexord_fusion (\<lambda>x y. lt_of_comp c y x) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt) (RBT_Set2.init rbt'))"
+             | Some c \<Rightarrow> ord.lexord_fusion (\<lambda>x y. lt_of_comp c y x) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt) (RBT_Set2.init rbt'))"
     (is ?rbt_rbt)
   and cless_set_rbt_Complement2 [set_complement_code]:
   "cless_set (RBT_set rbt1) (Complement (RBT_set rbt2)) \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_set RBT_set (Complement RBT_set): ccompare = None'') (\<lambda>_. cless_set (RBT_set rbt1) (Complement (RBT_set rbt2)))
              | Some c \<Rightarrow>
      finite (UNIV :: 'b set) \<longrightarrow>
      proper_intrvl.set_less_aux_Compl_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
     (is ?rbt_Compl)
   and cless_set_rbt_Complement1 [set_complement_code]:
   "cless_set (Complement (RBT_set rbt1)) (RBT_set rbt2) \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_set (Complement RBT_set) RBT_set: ccompare = None'') (\<lambda>_. cless_set (Complement (RBT_set rbt1)) (RBT_set rbt2))
              | Some c \<Rightarrow>
      finite (UNIV :: 'b set) \<and> 
      proper_intrvl.Compl_set_less_aux_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
     (is ?Compl_rbt)
 proof -
   note [split] = option.split csorted_list_of_set_split
     and [simp] = 
     le_of_comp_of_ords_linorder[OF ID_ccompare]
     lt_of_comp_of_ords
     finite_subset[OF subset_UNIV] ccompare_set_def ID_Some
-    order.lexord_fusion_def 
+    ord.lexord_fusion_def 
     proper_intrvl.Compl_set_less_aux_fusion_def
     proper_intrvl.set_less_aux_Compl_fusion_def
     unfoldr_rbt_keys_generator
     RBT_set_def sorted_RBT_Set_keys member_conv_keys
     linorder.set_less_finite_iff[OF ID_ccompare]
     linorder.set_less_aux_code[OF ID_ccompare, symmetric]
     linorder.Compl_set_less_Compl[OF ID_ccompare]
     linorder.infinite_set_less_Complement[OF ID_ccompare]
     linorder.infinite_Complement_set_less[OF ID_ccompare]
     linorder_proper_interval.set_less_aux_Compl2_conv_set_less_aux_Compl[OF ID_ccompare_interval, symmetric]
     linorder_proper_interval.Compl1_set_less_aux_conv_Compl_set_less_aux[OF ID_ccompare_interval, symmetric]
 
   show ?Compl_Compl by simp
-  show ?rbt_rbt
-    apply (subst order.lexord_fusion_def)
-    apply (auto simp: )
+   show ?rbt_rbt
     by auto
   show ?rbt_Compl by(cases "finite (UNIV :: 'b set)") auto
   show ?Compl_rbt by(cases "finite (UNIV :: 'b set)") auto
   show ?fin_fin by auto
   show ?fin_Compl_fin by(cases "finite (UNIV :: 'b set)", auto)
   show ?Compl_fin_fin by(cases "finite (UNIV :: 'b set)") auto
 qed
 
 lemma le_of_comp_set_less_eq: 
   "le_of_comp (comp_of_ords (ord.set_less_eq le) (ord.set_less le)) = ord.set_less_eq le"
   by (rule le_of_comp_of_ords_gen, simp add: ord.set_less_def)
 
 lemma cless_eq_set_code [code]:
   fixes rbt rbt' :: "'a :: ccompare set_rbt"
   and rbt1 rbt2 :: "'b :: cproper_interval set_rbt"
   and A B :: "'a set" 
   and A' B' :: "'b set" shows
   "cless_eq_set A B \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_eq_set: ccompare = None'') (\<lambda>_. cless_eq_set A B)
               | Some c \<Rightarrow>
      if finite A \<and> finite B then 
-        order.lexordp_eq (\<lambda>x y. lt_of_comp c y x) (csorted_list_of_set A) (csorted_list_of_set B)
+        ord.lexordp_eq (\<lambda>x y. lt_of_comp c y x) (csorted_list_of_set A) (csorted_list_of_set B)
      else Code.abort (STR ''cless_eq_set: infinite set'') (\<lambda>_. cless_eq_set A B))"
   (is "?fin_fin")
   and cless_eq_set_Complement2 [set_complement_code]:
   "cless_eq_set A' (Complement B') \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_eq_set Complement2: ccompare = None'') (\<lambda>_. cless_eq_set A' (Complement B'))
               | Some c \<Rightarrow>
      if finite A' \<and> finite B' then 
         finite (UNIV :: 'b set) \<longrightarrow>
         proper_intrvl.set_less_eq_aux_Compl (lt_of_comp c) cproper_interval None (csorted_list_of_set A') (csorted_list_of_set B')
      else Code.abort (STR ''cless_eq_set Complement2: infinite set'') (\<lambda>_. cless_eq_set A' (Complement B')))"
   (is "?fin_Compl_fin")
   and cless_eq_set_Complement1 [set_complement_code]:
   "cless_eq_set (Complement A') B' \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_eq_set Complement1: ccompare = None'') (\<lambda>_. cless_eq_set (Complement A') B')
               | Some c \<Rightarrow>
     if finite A' \<and> finite B' then 
       finite (UNIV :: 'b set) \<and>
       proper_intrvl.Compl_set_less_eq_aux (lt_of_comp c) cproper_interval None (csorted_list_of_set A') (csorted_list_of_set B')
     else Code.abort (STR ''cless_eq_set Complement1: infinite set'') (\<lambda>_. cless_eq_set (Complement A') B'))"
   (is "?Compl_fin_fin")
   and cless_eq_set_Complement12 [set_complement_code]:
   "cless_eq_set (Complement A) (Complement B) \<longleftrightarrow> 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_eq_set Complement Complement: ccompare = None'') (\<lambda>_. cless_eq (Complement A) (Complement B))
              | Some c \<Rightarrow> cless_eq_set B A)" 
   (is ?Compl_Compl)
 
   "cless_eq_set (RBT_set rbt) (RBT_set rbt') \<longleftrightarrow> 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cless_eq_set RBT_set RBT_set: ccompare = None'') (\<lambda>_. cless_eq_set (RBT_set rbt) (RBT_set rbt'))
-             | Some c \<Rightarrow> order.lexord_eq_fusion (\<lambda>x y. lt_of_comp c y x) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt) (RBT_Set2.init rbt'))" 
+             | Some c \<Rightarrow> ord.lexord_eq_fusion (\<lambda>x y. lt_of_comp c y x) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt) (RBT_Set2.init rbt'))" 
     (is ?rbt_rbt)
   and cless_eq_set_rbt_Complement2 [set_complement_code]:
   "cless_eq_set (RBT_set rbt1) (Complement (RBT_set rbt2)) \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_eq_set RBT_set (Complement RBT_set): ccompare = None'') (\<lambda>_. cless_eq_set (RBT_set rbt1) (Complement (RBT_set rbt2)))
              | Some c \<Rightarrow>
      finite (UNIV :: 'b set) \<longrightarrow>
      proper_intrvl.set_less_eq_aux_Compl_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
     (is ?rbt_Compl)
   and cless_eq_set_rbt_Complement1 [set_complement_code]:
   "cless_eq_set (Complement (RBT_set rbt1)) (RBT_set rbt2) \<longleftrightarrow>
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''cless_eq_set (Complement RBT_set) RBT_set: ccompare = None'') (\<lambda>_. cless_eq_set (Complement (RBT_set rbt1)) (RBT_set rbt2))
              | Some c \<Rightarrow>
      finite (UNIV :: 'b set) \<and> 
      proper_intrvl.Compl_set_less_eq_aux_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
     (is ?Compl_rbt)
 proof -
   note [split] = option.split csorted_list_of_set_split
     and [simp] = 
     le_of_comp_set_less_eq
     finite_subset[OF subset_UNIV] ccompare_set_def ID_Some
-    order.lexord_eq_fusion_def proper_intrvl.Compl_set_less_eq_aux_fusion_def
+    ord.lexord_eq_fusion_def proper_intrvl.Compl_set_less_eq_aux_fusion_def
     proper_intrvl.set_less_eq_aux_Compl_fusion_def
     unfoldr_rbt_keys_generator
     RBT_set_def sorted_RBT_Set_keys member_conv_keys
     linorder.set_less_eq_finite_iff[OF ID_ccompare]
     linorder.set_less_eq_aux_code[OF ID_ccompare, symmetric]
     linorder.Compl_set_less_eq_Compl[OF ID_ccompare]
     linorder.infinite_set_less_eq_Complement[OF ID_ccompare]
     linorder.infinite_Complement_set_less_eq[OF ID_ccompare]
     linorder_proper_interval.set_less_eq_aux_Compl2_conv_set_less_eq_aux_Compl[OF ID_ccompare_interval, symmetric]
     linorder_proper_interval.Compl1_set_less_eq_aux_conv_Compl_set_less_eq_aux[OF ID_ccompare_interval, symmetric]
 
   show ?Compl_Compl by simp
   show ?rbt_rbt
     
     by auto
   show ?rbt_Compl by(cases "finite (UNIV :: 'b set)") auto
   show ?Compl_rbt by(cases "finite (UNIV :: 'b set)") auto
   show ?fin_fin by auto
   show ?fin_Compl_fin by (cases "finite (UNIV :: 'b set)", auto)
   show ?Compl_fin_fin by(cases "finite (UNIV :: 'b set)") auto
 qed
 
 lemma cproper_interval_set_Some_Some_code [code]:
   fixes rbt1 rbt2 :: "'a :: cproper_interval set_rbt" 
   and A B :: "'a set" shows
 
   "cproper_interval (Some A) (Some B) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval: ccompare = None'') (\<lambda>_. cproper_interval (Some A) (Some B))
               | Some c \<Rightarrow>
        finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_set_aux (lt_of_comp c) cproper_interval (csorted_list_of_set A) (csorted_list_of_set B))"
   (is ?fin_fin)
   and cproper_interval_set_Some_Some_Complement [set_complement_code]:
   "cproper_interval (Some A) (Some (Complement B)) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval Complement2: ccompare = None'') (\<lambda>_. cproper_interval (Some A) (Some (Complement B)))
               | Some c \<Rightarrow>
        finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_set_Compl_aux (lt_of_comp c) cproper_interval None 0 (csorted_list_of_set A) (csorted_list_of_set B))"
   (is ?fin_Compl_fin)
   and cproper_interval_set_Some_Complement_Some [set_complement_code]:
   "cproper_interval (Some (Complement A)) (Some B) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval Complement1: ccompare = None'') (\<lambda>_. cproper_interval (Some (Complement A)) (Some B))
               | Some c \<Rightarrow>
        finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_Compl_set_aux (lt_of_comp c) cproper_interval None (csorted_list_of_set A) (csorted_list_of_set B))"
   (is ?Compl_fin_fin)
   and cproper_interval_set_Some_Complement_Some_Complement [set_complement_code]:
   "cproper_interval (Some (Complement A)) (Some (Complement B)) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval Complement Complement: ccompare = None'') (\<lambda>_. cproper_interval (Some (Complement A)) (Some (Complement B)))
              | Some _ \<Rightarrow> cproper_interval (Some B) (Some A))"
   (is ?Compl_Compl)
 
   "cproper_interval (Some (RBT_set rbt1)) (Some (RBT_set rbt2)) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval RBT_set RBT_set: ccompare = None'') (\<lambda>_. cproper_interval (Some (RBT_set rbt1)) (Some (RBT_set rbt2)))
              | Some c \<Rightarrow>
      finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_set_aux_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
   (is ?rbt_rbt)
   and cproper_interval_set_Some_rbt_Some_Complement [set_complement_code]:
   "cproper_interval (Some (RBT_set rbt1)) (Some (Complement (RBT_set rbt2))) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval RBT_set (Complement RBT_set): ccompare = None'') (\<lambda>_. cproper_interval (Some (RBT_set rbt1)) (Some (Complement (RBT_set rbt2))))
              | Some c \<Rightarrow>
      finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_set_Compl_aux_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None 0 (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
   (is ?rbt_Compl_rbt)
   and cproper_interval_set_Some_Complement_Some_rbt [set_complement_code]:
   "cproper_interval (Some (Complement (RBT_set rbt1))) (Some (RBT_set rbt2)) \<longleftrightarrow>
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''cproper_interval (Complement RBT_set) RBT_set: ccompare = None'') (\<lambda>_. cproper_interval (Some (Complement (RBT_set rbt1))) (Some (RBT_set rbt2)))
              | Some c \<Rightarrow>
      finite (UNIV :: 'a set) \<and> proper_intrvl.proper_interval_Compl_set_aux_fusion (lt_of_comp c) cproper_interval rbt_keys_generator rbt_keys_generator None (RBT_Set2.init rbt1) (RBT_Set2.init rbt2))"
   (is ?Compl_rbt_rbt)
 proof -
   note [split] = option.split csorted_list_of_set_split
     and [simp] = 
     lt_of_comp_of_ords
     finite_subset[OF subset_UNIV] ccompare_set_def ID_Some
     linorder.set_less_finite_iff[OF ID_ccompare]
     RBT_set_def sorted_RBT_Set_keys member_conv_keys
     linorder.distinct_entries[OF ID_ccompare]
     unfoldr_rbt_keys_generator
     proper_intrvl.proper_interval_set_aux_fusion_def
     proper_intrvl.proper_interval_set_Compl_aux_fusion_def
     proper_intrvl.proper_interval_Compl_set_aux_fusion_def 
     linorder_proper_interval.proper_interval_set_aux[OF ID_ccompare_interval]
     linorder_proper_interval.proper_interval_set_Compl_aux[OF ID_ccompare_interval]
     linorder_proper_interval.proper_interval_Compl_set_aux[OF ID_ccompare_interval]
     and [cong] = conj_cong
 
   show ?Compl_Compl
     by(clarsimp simp add: Complement_cproper_interval_set_Complement simp del: cproper_interval_set_Some_Some)
   
   show ?rbt_rbt ?rbt_Compl_rbt ?Compl_rbt_rbt by auto
   show ?fin_fin ?fin_Compl_fin ?Compl_fin_fin by auto
 qed
 
 context ord begin
 
 fun sorted_list_subset :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "sorted_list_subset eq [] ys = True"
 | "sorted_list_subset eq (x # xs) [] = False"
 | "sorted_list_subset eq (x # xs) (y # ys) \<longleftrightarrow>
   (if eq x y then sorted_list_subset eq xs ys
    else x > y \<and> sorted_list_subset eq (x # xs) ys)"
 
 end
 
 context linorder begin
 
 lemma sorted_list_subset_correct:
   "\<lbrakk> sorted xs; distinct xs; sorted ys; distinct ys \<rbrakk> 
   \<Longrightarrow> sorted_list_subset (=) xs ys \<longleftrightarrow> set xs \<subseteq> set ys"
 apply(induct "(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool" xs ys rule: sorted_list_subset.induct)
 apply(auto 6 2)
 apply auto
 by (metis eq_iff insert_iff subsetD)
 
 end
 
 context ord begin
 
 definition sorted_list_subset_fusion :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where "sorted_list_subset_fusion eq g1 g2 s1 s2 = sorted_list_subset eq (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 lemma sorted_list_subset_fusion_code:
   "sorted_list_subset_fusion eq g1 g2 s1 s2 =
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in list.has_next g2 s2 \<and> (
         let (y, s2') = list.next g2 s2 
         in if eq x y then sorted_list_subset_fusion eq g1 g2 s1' s2' 
            else y < x \<and> sorted_list_subset_fusion eq g1 g2 s1 s2')
    else True)"
 unfolding sorted_list_subset_fusion_def
 by(subst (1 2 5) list.unfoldr.simps)(simp add: split_beta Let_def)
 
 end
 
 lemmas [code] = ord.sorted_list_subset_fusion_code
 
 text \<open>
   Define a new constant for the subset operation
   because @{theory "HOL-Library.Cardinality"} introduces @{const "Cardinality.subset'"}
   and rewrites @{const "subset"} to @{const "Cardinality.subset'"} 
   based on the sort of the element type.
 \<close>
 
 definition subset_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
 where [simp, code del]: "subset_eq = (\<subseteq>)"
 
 lemma subseteq_code [code]: "(\<subseteq>) = subset_eq"
 by simp
 
 lemma subset'_code [code]: "Cardinality.subset' = subset_eq"
 by simp
 
 lemma subset_eq_code [folded subset_eq_def, code]:
   fixes A1 A2 :: "'a set"
   and rbt :: "'b :: ccompare set_rbt"
   and rbt1 rbt2 :: "'d :: {ccompare, ceq} set_rbt"
   and dxs :: "'c :: ceq set_dlist" 
   and xs :: "'c list" shows
   "RBT_set rbt \<subseteq> B \<longleftrightarrow> 
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''subset RBT_set1: ccompare = None'') (\<lambda>_. RBT_set rbt \<subseteq> B)
                      | Some _ \<Rightarrow> list_all_fusion rbt_keys_generator (\<lambda>x. x \<in> B) (RBT_Set2.init rbt))" (is ?rbt)
   "DList_set dxs \<subseteq> C \<longleftrightarrow> 
   (case ID CEQ('c) of None \<Rightarrow> Code.abort (STR ''subset DList_set1: ceq = None'') (\<lambda>_. DList_set dxs \<subseteq> C)
                      | Some _ \<Rightarrow> DList_Set.dlist_all (\<lambda>x. x \<in> C) dxs)" (is ?dlist)
   "Set_Monad xs \<subseteq> C \<longleftrightarrow> list_all (\<lambda>x. x \<in> C) xs" (is ?Set_Monad)
   and Collect_subset_eq_Complement [folded subset_eq_def, set_complement_code]:
   "Collect_set P \<subseteq> Complement A \<longleftrightarrow> A \<subseteq> {x. \<not> P x}" (is ?Collect_set_Compl)
   and Complement_subset_eq_Complement [folded subset_eq_def, set_complement_code]:
   "Complement A1 \<subseteq> Complement A2 \<longleftrightarrow> A2 \<subseteq> A1" (is ?Compl)
   and
   "RBT_set rbt1 \<subseteq> RBT_set rbt2 \<longleftrightarrow>
   (case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''subset RBT_set RBT_set: ccompare = None'') (\<lambda>_. RBT_set rbt1 \<subseteq> RBT_set rbt2)
                      | Some c \<Rightarrow> 
     (case ID CEQ('d) of None \<Rightarrow> ord.sorted_list_subset_fusion (lt_of_comp c) (\<lambda> x y. c x y = Eq) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt1) (RBT_Set2.init rbt2)
                    | Some eq \<Rightarrow> ord.sorted_list_subset_fusion (lt_of_comp c) eq rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt1) (RBT_Set2.init rbt2)))" 
   (is ?rbt_rbt)
 proof -
   show ?rbt_rbt 
     by (auto simp add: comparator.eq[OF ID_ccompare'] RBT_set_def member_conv_keys unfoldr_rbt_keys_generator ord.sorted_list_subset_fusion_def linorder.sorted_list_subset_correct[OF ID_ccompare] sorted_RBT_Set_keys split: option.split dest!: ID_ceq[THEN equal.equal_eq] del: iffI)
   show ?rbt
     by(auto simp add: RBT_set_def member_conv_keys list_all_fusion_def unfoldr_rbt_keys_generator keys.rep_eq list_all_iff split: option.split)
   show ?dlist by(auto simp add: DList_set_def dlist_all_conv_member split: option.split)
   show ?Set_Monad by(auto simp add: list_all_iff split: option.split)
   show ?Collect_set_Compl ?Compl by auto
 qed
 
 hide_const (open) subset_eq
 hide_fact (open) subset_eq_def
 
 lemma eq_set_code [code]: "Cardinality.eq_set = set_eq"
 by(simp add: set_eq_def)
 
 lemma set_eq_code [code]:
   fixes rbt1 rbt2 :: "'b :: {ccompare, ceq} set_rbt" shows
   "set_eq A B \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
   and set_eq_Complement_Complement [set_complement_code]:
   "set_eq (Complement A) (Complement B) = set_eq A B"
   and
   "set_eq (RBT_set rbt1) (RBT_set rbt2) = 
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''set_eq RBT_set RBT_set: ccompare = None'') (\<lambda>_. set_eq (RBT_set rbt1) (RBT_set rbt2))
                      | Some c \<Rightarrow> 
      (case ID CEQ('b) of None \<Rightarrow> list_all2_fusion (\<lambda> x y. c x y = Eq) rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt1) (RBT_Set2.init rbt2)
                     | Some eq \<Rightarrow> list_all2_fusion eq rbt_keys_generator rbt_keys_generator (RBT_Set2.init rbt1) (RBT_Set2.init rbt2)))"
   (is ?rbt_rbt)
 proof -
   show ?rbt_rbt
     by (auto 4 3 split: option.split simp add: comparator.eq[OF ID_ccompare'] sorted_RBT_Set_keys list_all2_fusion_def unfoldr_rbt_keys_generator RBT_set_conv_keys set_eq_def list.rel_eq dest!: ID_ceq[THEN equal.equal_eq] intro: linorder.sorted_distinct_set_unique[OF ID_ccompare])
 qed(auto simp add: set_eq_def)
 
 lemma Set_project_code [code]:
   "Set.filter P A = A \<inter> Collect_set P"
 by(auto simp add: Set.filter_def)
 
 lemma Set_image_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "image f (Set_Monad xs) = Set_Monad (map f xs)"
   "image f (Collect_set A) = Code.abort (STR ''image Collect_set'') (\<lambda>_. image f (Collect_set A))"
   and image_Complement_Complement [set_complement_code]:
   "image f (Complement (Complement B)) = image f B"
   and
   "image g (DList_set dxs) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''image DList_set: ceq = None'') (\<lambda>_. image g (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.fold (insert \<circ> g) dxs {})"
   (is ?dlist)
   "image h (RBT_set rbt) = 
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''image RBT_set: ccompare = None'') (\<lambda>_. image h (RBT_set rbt))
                       | Some _ \<Rightarrow> RBT_Set2.fold (insert \<circ> h) rbt {})"
    (is ?rbt)
 proof -
   { fix xs have "fold (insert \<circ> g) xs {} = g ` set xs"
       by(induct xs rule: rev_induct) simp_all }
   thus ?dlist
     by(simp add: DList_set_def DList_Set.fold_def DList_Set.Collect_member split: option.split)
   { fix xs have "fold (insert \<circ> h) xs {} = h ` set xs"
       by(induct xs rule: rev_induct) simp_all }
   thus ?rbt by(auto simp add: RBT_set_def fold_conv_fold_keys member_conv_keys split: option.split)
 qed simp_all
 
 lemma the_elem_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "the_elem (Set_Monad [x]) = x"
   "the_elem (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''the_elem DList_set: ceq = None'') (\<lambda>_. the_elem (DList_set dxs))
                   | Some _ \<Rightarrow> 
      case list_of_dlist dxs of [x] \<Rightarrow> x 
        | _ \<Rightarrow> Code.abort (STR ''the_elem DList_set: not unique'') (\<lambda>_. the_elem (DList_set dxs)))"
   "the_elem (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''the_elem RBT_set: ccompare = None'') (\<lambda>_. the_elem (RBT_set rbt))
                      | Some _ \<Rightarrow> 
      case RBT_Mapping2.impl_of rbt of RBT_Impl.Branch _ RBT_Impl.Empty x _ RBT_Impl.Empty \<Rightarrow> x
        | _ \<Rightarrow> Code.abort (STR ''the_elem RBT_set: not unique'') (\<lambda>_. the_elem (RBT_set rbt)))"
 by(auto simp add: RBT_set_def DList_set_def DList_Set.Collect_member the_elem_def member_conv_keys split: option.split list.split rbt.split)(simp add: RBT_Set2.keys_def)
 
 lemma Pow_set_conv_fold:
   "Pow (set xs \<union> A) = fold (\<lambda>x A. A \<union> insert x ` A) xs (Pow A)"
 by(induct xs rule: rev_induct)(auto simp add: Pow_insert)
 
 lemma Pow_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "Pow A = Collect_set (\<lambda>B. B \<subseteq> A)"
   "Pow (Set_Monad xs) = fold (\<lambda>x A. A \<union> insert x ` A) xs {{}}"
   "Pow (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''Pow DList_set: ceq = None'') (\<lambda>_. Pow (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.fold (\<lambda>x A. A \<union> insert x ` A) dxs {{}})"
   "Pow (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''Pow RBT_set: ccompare = None'') (\<lambda>_. Pow (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>x A. A \<union> insert x ` A) rbt {{}})"
 by(auto simp add: DList_set_def DList_Set.Collect_member DList_Set.fold_def RBT_set_def fold_conv_fold_keys member_conv_keys Pow_set_conv_fold[where A="{}", simplified] split: option.split)
 
 lemma fold_singleton: "Finite_Set.fold f x {y} = f y x"
 by(fastforce simp add: Finite_Set.fold_def intro: fold_graph.intros elim: fold_graph.cases)
 
 lift_definition sum_cfc :: "('a \<Rightarrow> 'b :: comm_monoid_add) \<Rightarrow> ('a, 'b) comp_fun_commute"
 is "\<lambda>f :: 'a \<Rightarrow> 'b. plus \<circ> f"
 by(unfold_locales)(simp add: fun_eq_iff add.left_commute)
 
 lemma sum_code [code]:
   "sum f A = (if finite A then set_fold_cfc (sum_cfc f) 0 A else 0)"
   by transfer(simp add: sum.eq_fold)
 
 lemma product_code [code]:
   fixes dxs :: "'a :: ceq set_dlist"
   and dys :: "'b :: ceq set_dlist" 
   and rbt1 :: "'c :: ccompare set_rbt"
   and rbt2 :: "'d :: ccompare set_rbt" shows
   "Product_Type.product A B = Collect_set (\<lambda>(x, y). x \<in> A \<and> y \<in> B)"
 
   "Product_Type.product (Set_Monad xs) (Set_Monad ys) = 
    Set_Monad (fold (\<lambda>x. fold (\<lambda>y rest. (x, y) # rest) ys) xs [])"
   (is ?Set_Monad)
 
   "Product_Type.product (DList_set dxs) B1 = 
    (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''product DList_set1: ceq = None'') (\<lambda>_. Product_Type.product (DList_set dxs) B1)
                    | Some _ \<Rightarrow>  DList_Set.fold (\<lambda>x rest. Pair x ` B1 \<union> rest) dxs {})" 
   (is "?dlist1")
 
   "Product_Type.product A1 (DList_set dys) = 
    (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''product DList_set2: ceq = None'') (\<lambda>_. Product_Type.product A1 (DList_set dys))
                    | Some _ \<Rightarrow> DList_Set.fold (\<lambda>y rest. (\<lambda>x. (x, y)) ` A1 \<union> rest) dys {})"
   (is "?dlist2")
 
   "Product_Type.product (DList_set dxs) (DList_set dys) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''product DList_set DList_set: ceq1 = None'') (\<lambda>_. Product_Type.product (DList_set dxs) (DList_set dys))
                   | Some _ \<Rightarrow> 
      case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''product DList_set DList_set: ceq2 = None'') (\<lambda>_. Product_Type.product (DList_set dxs) (DList_set dys))
                     | Some _ \<Rightarrow> DList_set (DList_Set.product dxs dys))"
 
   "Product_Type.product (RBT_set rbt1) B2 =
   (case ID CCOMPARE('c) of None \<Rightarrow> Code.abort (STR ''product RBT_set: ccompare1 = None'') (\<lambda>_. Product_Type.product (RBT_set rbt1) B2)
                      | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>x rest. Pair x ` B2 \<union> rest) rbt1 {})"
   (is "?rbt1")
 
   "Product_Type.product A2 (RBT_set rbt2) =
   (case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''product RBT_set: ccompare2 = None'') (\<lambda>_. Product_Type.product A2 (RBT_set rbt2))
                      | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>y rest. (\<lambda>x. (x, y)) ` A2 \<union> rest) rbt2 {})"
   (is "?rbt2")
 
   "Product_Type.product (RBT_set rbt1) (RBT_set rbt2) =
   (case ID CCOMPARE('c) of None \<Rightarrow> Code.abort (STR ''product RBT_set RBT_set: ccompare1 = None'') (\<lambda>_. Product_Type.product (RBT_set rbt1) (RBT_set rbt2))
                      | Some _ \<Rightarrow>
      case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''product RBT_set RBT_set: ccompare2 = None'') (\<lambda>_. Product_Type.product (RBT_set rbt1) (RBT_set rbt2))
                        | Some _ \<Rightarrow> RBT_set (RBT_Set2.product rbt1 rbt2))"
 proof -
   have [simp]: "\<And>a zs. fold (\<lambda>y. (#) (a, y)) ys zs = rev (map (Pair a) ys) @ zs"
     by(induct ys) simp_all
   have [simp]: "\<And>zs. fold (\<lambda>x. fold (\<lambda>y rest. (x, y) # rest) ys) xs zs = rev (concat (map (\<lambda>x. map (Pair x) ys) xs)) @ zs"
     by(induct xs) simp_all
   show ?Set_Monad by(auto simp add: Product_Type.product_def)
 
   { fix xs :: "'a list"
     have "fold (\<lambda>x. (\<union>) (Pair x ` B1)) xs {} = set xs \<times> B1"
       by(induct xs rule: rev_induct) auto }
   thus ?dlist1 
     by(simp add: Product_Type.product_def DList_set_def DList_Set.fold.rep_eq DList_Set.Collect_member split: option.split) 
 
   { fix ys :: "'b list"
     have "fold (\<lambda>y. (\<union>) ((\<lambda>x. (x, y)) ` A1)) ys {} = A1 \<times> set ys"
       by(induct ys rule: rev_induct) auto }
   thus ?dlist2
     by(simp add: Product_Type.product_def DList_set_def DList_Set.fold.rep_eq DList_Set.Collect_member split: option.split)
 
   { fix xs :: "'c list"
     have "fold (\<lambda>x. (\<union>) (Pair x ` B2)) xs {} = set xs \<times> B2"
       by(induct xs rule: rev_induct) auto }
   thus ?rbt1
     by(simp add: Product_Type.product_def RBT_set_def RBT_Set2.member_product RBT_Set2.member_conv_keys fold_conv_fold_keys split: option.split)
 
   { fix ys :: "'d list"
     have "fold (\<lambda>y. (\<union>) ((\<lambda>x. (x, y)) ` A2)) ys {} = A2 \<times> set ys"
       by(induct ys rule: rev_induct) auto }
   thus ?rbt2
     by(simp add: Product_Type.product_def RBT_set_def RBT_Set2.member_product RBT_Set2.member_conv_keys fold_conv_fold_keys split: option.split)
 qed(auto simp add: RBT_set_def DList_set_def Product_Type.product_def DList_Set.product_member RBT_Set2.member_product split: option.split)
 
 lemma Id_on_code [code]: 
   fixes A :: "'a :: ceq set"
   and dxs :: "'a set_dlist" 
   and P :: "'a \<Rightarrow> bool" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "Id_on B = (\<lambda>x. (x, x)) ` B"
   and Id_on_Complement [set_complement_code]:
   "Id_on (Complement A) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''Id_on Complement: ceq = None'') (\<lambda>_. Id_on (Complement A))
                  | Some eq \<Rightarrow> Collect_set (\<lambda>(x, y). eq x y \<and> x \<notin> A))"
   and
   "Id_on (Collect_set P) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''Id_on Collect_set: ceq = None'') (\<lambda>_. Id_on (Collect_set P))
                  | Some eq \<Rightarrow> Collect_set (\<lambda>(x, y). eq x y \<and> P x))"
   "Id_on (DList_set dxs) = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''Id_on DList_set: ceq = None'') (\<lambda>_. Id_on (DList_set dxs))
                   | Some _ \<Rightarrow> DList_set (DList_Set.Id_on dxs))"
   "Id_on (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''Id_on RBT_set: ccompare = None'') (\<lambda>_. Id_on (RBT_set rbt))
                      | Some _ \<Rightarrow> RBT_set (RBT_Set2.Id_on rbt))"
 by(auto simp add: DList_set_def RBT_set_def DList_Set.member_Id_on RBT_Set2.member_Id_on dest: equal.equal_eq[OF ID_ceq] split: option.split)
 
 lemma Image_code [code]:
   fixes dxs :: "('a :: ceq \<times> 'b :: ceq) set_dlist" 
   and rbt :: "('c :: ccompare \<times> 'd :: ccompare) set_rbt" shows
   "X `` Y = snd ` Set.filter (\<lambda>(x, y). x \<in> Y) X"
   (is ?generic)
 
   "Set_Monad rxs `` A = Set_Monad (fold (\<lambda>(x, y) rest. if x \<in> A then y # rest else rest) rxs [])"
   (is ?Set_Monad)
   "DList_set dxs `` B = 
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''Image DList_set: ceq1 = None'') (\<lambda>_. DList_set dxs `` B)
                   | Some _ \<Rightarrow>
      case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''Image DList_set: ceq2 = None'') (\<lambda>_. DList_set dxs `` B)
                     | Some _ \<Rightarrow>
         DList_Set.fold (\<lambda>(x, y) acc. if x \<in> B then insert y acc else acc) dxs {})"
   (is ?DList_set)
   "RBT_set rbt `` C =
    (case ID CCOMPARE('c) of None \<Rightarrow> Code.abort (STR ''Image RBT_set: ccompare1 = None'') (\<lambda>_. RBT_set rbt `` C)
                       | Some _ \<Rightarrow>
       case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''Image RBT_set: ccompare2 = None'') (\<lambda>_. RBT_set rbt `` C)
                         | Some _ \<Rightarrow>
         RBT_Set2.fold (\<lambda>(x, y) acc. if x \<in> C then insert y acc else acc) rbt {})"
   (is ?RBT_set)
 proof -
   show ?generic by(auto intro: rev_image_eqI)
 
   have "set (fold (\<lambda>(x, y) rest. if x \<in> A then y # rest else rest) rxs []) = set rxs `` A"
     by(induct rxs rule: rev_induct)(auto split: if_split_asm)
   thus ?Set_Monad by(auto)
 
   { fix dxs :: "('a \<times> 'b) list"
     have "fold (\<lambda>(x, y) acc. if x \<in> B then insert y acc else acc) dxs {} = set dxs `` B"
       by(induct dxs rule: rev_induct)(auto split: if_split_asm) }
   thus ?DList_set
     by(clarsimp simp add: DList_set_def Collect_member ceq_prod_def ID_Some DList_Set.fold.rep_eq split: option.split)
 
 
   { fix rbt :: "(('c \<times> 'd) \<times> unit) list"
     have "fold (\<lambda>(a, _). case a of (x, y) \<Rightarrow> \<lambda>acc. if x \<in> C then insert y acc else acc) rbt {} = (fst ` set rbt) `` C"
       by(induct rbt rule: rev_induct)(auto simp add: split_beta split: if_split_asm) }
   thus ?RBT_set
     by(clarsimp simp add: RBT_set_def ccompare_prod_def ID_Some RBT_Set2.fold.rep_eq member_conv_keys RBT_Set2.keys.rep_eq RBT_Impl.fold_def RBT_Impl.keys_def split: option.split)
 qed
 
 lemma insert_relcomp: "insert (a, b) A O B = A O B \<union> {a} \<times> {c. (b, c) \<in> B}"
 by auto
 
 lemma trancl_code [code]:
   "trancl A = 
   (if finite A then ntrancl (card A - 1) A else Code.abort (STR ''trancl: infinite set'') (\<lambda>_. trancl A))"
 by (simp add: finite_trancl_ntranl)
 
 lemma set_relcomp_set:
   "set xs O set ys = fold (\<lambda>(x, y). fold (\<lambda>(y', z) A. if y = y' then insert (x, z) A else A) ys) xs {}"
 proof(induct xs rule: rev_induct)
   case Nil show ?case by simp
 next
   case (snoc x xs)
   note [[show_types]]
   { fix a :: 'a and b :: 'c and X :: "('a \<times> 'b) set"
     have "fold (\<lambda>(y', z) A. if b = y' then insert (a, z) A else A) ys X = X \<union> {a} \<times> {c. (b, c) \<in> set ys}"
       by(induct ys arbitrary: X rule: rev_induct)(auto split: if_split_asm) }
   thus ?case using snoc by(cases x)(simp add: insert_relcomp)
 qed
 
 lemma If_not: "(if \<not> a then b else c) = (if a then c else b)" 
 by auto
 
 lemma relcomp_code [code]:
   fixes rbt1 :: "('a :: ccompare \<times> 'b :: ccompare) set_rbt"
   and rbt2 :: "('b \<times> 'c :: ccompare) set_rbt"
   and rbt3 :: "('a \<times> 'd :: {ccompare, ceq}) set_rbt" 
   and rbt4 :: "('d \<times> 'a) set_rbt"
   and rbt5 :: "('b \<times> 'a) set_rbt"
   and dxs1 :: "('d \<times> 'e :: ceq) set_dlist" 
   and dxs2 :: "('e \<times> 'd) set_dlist"
   and dxs3 :: "('e \<times> 'f :: ceq) set_dlist"
   and dxs4 :: "('f \<times> 'g :: ceq) set_dlist"
   and xs1 :: "('h \<times> 'i :: ceq) list"
   and xs2 :: "('i \<times> 'j) list"
   and xs3 :: "('b \<times> 'h) list"
   and xs4 :: "('h \<times> 'b) list"
   and xs5 :: "('f \<times> 'h) list"
   and xs6 :: "('h \<times> 'f) list"
   shows
   "RBT_set rbt1 O RBT_set rbt2 = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set RBT_set: ccompare1 = None'') (\<lambda>_. RBT_set rbt1 O RBT_set rbt2)
                      | Some _ \<Rightarrow>
      case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set RBT_set: ccompare2 = None'') (\<lambda>_. RBT_set rbt1 O RBT_set rbt2)
            | Some c_b \<Rightarrow>
        case ID CCOMPARE('c) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set RBT_set: ccompare3 = None'') (\<lambda>_. RBT_set rbt1 O RBT_set rbt2)
                          | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>(x, y). RBT_Set2.fold (\<lambda>(y', z) A. if c_b y y' \<noteq> Eq then A else insert (x, z) A) rbt2) rbt1 {})"
   (is ?rbt_rbt)
 
   "RBT_set rbt3 O DList_set dxs1 = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set DList_set: ccompare1 = None'') (\<lambda>_. RBT_set rbt3 O DList_set dxs1)
                      | Some _ \<Rightarrow>
      case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set DList_set: ccompare2 = None'') (\<lambda>_. RBT_set rbt3 O DList_set dxs1)
                        | Some _ \<Rightarrow>
        case ID CEQ('d) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set DList_set: ceq2 = None'') (\<lambda>_. RBT_set rbt3 O DList_set dxs1)
                      | Some eq \<Rightarrow>
          case ID CEQ('e) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set DList_set: ceq3 = None'') (\<lambda>_. RBT_set rbt3 O DList_set dxs1)
                         | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>(x, y). DList_Set.fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) dxs1) rbt3 {})"
   (is ?rbt_dlist)
 
   "DList_set dxs2 O RBT_set rbt4 = 
   (case ID CEQ('e) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set RBT_set: ceq1 = None'') (\<lambda>_. DList_set dxs2 O RBT_set rbt4)
                   | Some _ \<Rightarrow>
      case ID CCOMPARE('d) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set RBT_set: ceq2 = None'') (\<lambda>_. DList_set dxs2 O RBT_set rbt4)
                        | Some _ \<Rightarrow>
        case ID CEQ('d) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set RBT_set: ccompare2 = None'') (\<lambda>_. DList_set dxs2 O RBT_set rbt4)
                      | Some eq \<Rightarrow>
          case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set RBT_set: ccompare3 = None'') (\<lambda>_. DList_set dxs2 O RBT_set rbt4)
                            | Some _ \<Rightarrow> DList_Set.fold (\<lambda>(x, y). RBT_Set2.fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) rbt4) dxs2 {})"
   (is ?dlist_rbt)
 
   "DList_set dxs3 O DList_set dxs4 =
   (case ID CEQ('e) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set DList_set: ceq1 = None'') (\<lambda>_. DList_set dxs3 O DList_set dxs4)
                   | Some _ \<Rightarrow>
      case ID CEQ('f) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set DList_set: ceq2 = None'') (\<lambda>_. DList_set dxs3 O DList_set dxs4)
                    | Some eq \<Rightarrow>
        case ID CEQ('g) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set DList_set: ceq3 = None'') (\<lambda>_. DList_set dxs3 O DList_set dxs4)
                       | Some _ \<Rightarrow> DList_Set.fold (\<lambda>(x, y). DList_Set.fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) dxs4) dxs3 {})"
   (is ?dlist_dlist)
 
   "Set_Monad xs1 O Set_Monad xs2 =
   (case ID CEQ('i) of None \<Rightarrow> Code.abort (STR ''relcomp Set_Monad Set_Monad: ceq = None'') (\<lambda>_. Set_Monad xs1 O Set_Monad xs2)
                  | Some eq \<Rightarrow> fold (\<lambda>(x, y). fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) xs2) xs1 {})"
   (is ?monad_monad)
 
   "RBT_set rbt1 O Set_Monad xs3 =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set Set_Monad: ccompare1 = None'') (\<lambda>_. RBT_set rbt1 O Set_Monad xs3)
                      | Some _ \<Rightarrow>
      case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''relcomp RBT_set Set_Monad: ccompare2 = None'') (\<lambda>_. RBT_set rbt1 O Set_Monad xs3)
            | Some c_b \<Rightarrow> RBT_Set2.fold (\<lambda>(x, y). fold (\<lambda>(y', z) A. if c_b y y' \<noteq> Eq then A else insert (x, z) A) xs3) rbt1 {})"
   (is ?rbt_monad)
 
   "Set_Monad xs4 O RBT_set rbt5 =
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''relcomp Set_Monad RBT_set: ccompare1 = None'') (\<lambda>_. Set_Monad xs4 O RBT_set rbt5)
                      | Some _ \<Rightarrow>
      case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''relcomp Set_Monad RBT_set: ccompare2 = None'') (\<lambda>_. Set_Monad xs4 O RBT_set rbt5)
            | Some c_b \<Rightarrow> fold (\<lambda>(x, y). RBT_Set2.fold (\<lambda>(y', z) A. if c_b y y' \<noteq> Eq then A else insert (x, z) A) rbt5) xs4 {})"
   (is ?monad_rbt)
 
   "DList_set dxs3 O Set_Monad xs5 =
   (case ID CEQ('e) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set Set_Monad: ceq1 = None'') (\<lambda>_. DList_set dxs3 O Set_Monad xs5)
                   | Some _ \<Rightarrow>
      case ID CEQ('f) of None \<Rightarrow> Code.abort (STR ''relcomp DList_set Set_Monad: ceq2 = None'') (\<lambda>_. DList_set dxs3 O Set_Monad xs5)
                    | Some eq \<Rightarrow> DList_Set.fold (\<lambda>(x, y). fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) xs5) dxs3 {})"
   (is ?dlist_monad)
 
   "Set_Monad xs6 O DList_set dxs4 =
   (case ID CEQ('f) of None \<Rightarrow> Code.abort (STR ''relcomp Set_Monad DList_set: ceq1 = None'') (\<lambda>_. Set_Monad xs6 O DList_set dxs4)
                       | Some eq \<Rightarrow>
      case ID CEQ('g) of None \<Rightarrow> Code.abort (STR ''relcomp Set_Monad DList_set: ceq2 = None'') (\<lambda>_. Set_Monad xs6 O DList_set dxs4)
                    | Some _ \<Rightarrow> fold (\<lambda>(x, y). DList_Set.fold (\<lambda>(y', z) A. if eq y y' then insert (x, z) A else A) dxs4) xs6 {})"
   (is ?monad_dlist)
 proof -
 
   show ?rbt_rbt ?rbt_monad ?monad_rbt
     by(auto simp add: comparator.eq[OF ID_ccompare'] RBT_set_def ccompare_prod_def member_conv_keys ID_Some RBT_Set2.fold_conv_fold_keys' RBT_Set2.keys.rep_eq If_not set_relcomp_set split: option.split del: equalityI)
 
   show ?rbt_dlist ?dlist_rbt ?dlist_dlist ?monad_monad ?dlist_monad ?monad_dlist
     by(auto simp add: RBT_set_def DList_set_def member_conv_keys ID_Some ccompare_prod_def ceq_prod_def Collect_member RBT_Set2.fold_conv_fold_keys' RBT_Set2.keys.rep_eq DList_Set.fold.rep_eq set_relcomp_set dest: equal.equal_eq[OF ID_ceq] split: option.split del: equalityI)
 qed
 
 lemma irrefl_code [code]:
   fixes r :: "('a :: {ceq, ccompare} \<times> 'a) set" shows
   "irrefl r \<longleftrightarrow> 
   (case ID CEQ('a) of Some eq \<Rightarrow> (\<forall>(x, y) \<in> r. \<not> eq x y) | None \<Rightarrow>
     case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''irrefl: ceq = None & ccompare = None'') (\<lambda>_. irrefl r)
                 | Some c \<Rightarrow> (\<forall>(x, y) \<in> r. c x y \<noteq> Eq))"
 apply(auto simp add: irrefl_distinct comparator.eq[OF ID_ccompare'] split: option.split dest!: ID_ceq[THEN equal.equal_eq])
 done
 
 lemma wf_code [code]:
   fixes rbt :: "('a :: ccompare \<times> 'a) set_rbt" 
   and dxs :: "('b :: ceq \<times> 'b) set_dlist" shows
   "wf (Set_Monad xs) = acyclic (Set_Monad xs)"
   "wf (RBT_set rbt) = 
   (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''wf RBT_set: ccompare = None'') (\<lambda>_. wf (RBT_set rbt))
                      | Some _ \<Rightarrow> acyclic (RBT_set rbt))"
   "wf (DList_set dxs) =
   (case ID CEQ('b) of None \<Rightarrow> Code.abort (STR ''wf DList_set: ceq = None'') (\<lambda>_. wf (DList_set dxs))
                      | Some _ \<Rightarrow> acyclic (DList_set dxs))"
 by(auto simp add: wf_iff_acyclic_if_finite split: option.split del: iffI)(simp_all add: wf_iff_acyclic_if_finite finite_code ccompare_prod_def ceq_prod_def ID_Some)
 
 lemma bacc_code [code]:
   "bacc R 0 = - snd ` R"
   "bacc R (Suc n) = (let rec = bacc R n in rec \<union> - snd ` (Set.filter (\<lambda>(y, x). y \<notin> rec) R))"
 by(auto intro: rev_image_eqI simp add: Let_def)
 
 (* TODO: acc could also be computed for infinite universes if r is finite *)
 
 lemma acc_code [code]:
   fixes A :: "('a :: {finite, card_UNIV} \<times> 'a) set" shows
   "Wellfounded.acc A = bacc A (of_phantom (card_UNIV :: 'a card_UNIV))"
 by(simp add: card_UNIV acc_bacc_eq)
 
 lemma sorted_list_of_set_code [code]:
   fixes dxs :: "'a :: {linorder, ceq} set_dlist"
   and rbt :: "'b :: {linorder, ccompare} set_rbt"
   shows
   "sorted_list_of_set (Set_Monad xs) = sort (remdups xs)"
   "sorted_list_of_set (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''sorted_list_of_set DList_set: ceq = None'') (\<lambda>_. sorted_list_of_set (DList_set dxs))
                   | Some _ \<Rightarrow> sort (list_of_dlist dxs))"
   "sorted_list_of_set (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''sorted_list_of_set RBT_set: ccompare = None'') (\<lambda>_. sorted_list_of_set (RBT_set rbt))
                      | Some _ \<Rightarrow> sort (RBT_Set2.keys rbt))"
   \<comment> \<open>We must sort the keys because @{term ccompare}'s ordering need not coincide with @{term linorder}'s.\<close>
 by(auto simp add: DList_set_def RBT_set_def sorted_list_of_set_sort_remdups Collect_member distinct_remdups_id distinct_list_of_dlist member_conv_keys split: option.split)
 
 lemma map_project_set: "List.map_project f (set xs) = set (List.map_filter f xs)"
 by(auto simp add: List.map_project_def List.map_filter_def intro: rev_image_eqI)
 
 lemma map_project_simps:
   shows map_project_empty: "List.map_project f {} = {}"
   and map_project_insert: 
   "List.map_project f (insert x A) = 
   (case f x of None \<Rightarrow> List.map_project f A 
    | Some y \<Rightarrow> insert y (List.map_project f A))"
 by(auto simp add: List.map_project_def split: option.split)
 
 lemma map_project_conv_fold: 
   "List.map_project f (set xs) = 
    fold (\<lambda>x A. case f x of None \<Rightarrow> A | Some y \<Rightarrow> insert y A) xs {}"
 by(induct xs rule: rev_induct)(simp_all add: map_project_simps cong: option.case_cong)
 
 lemma map_project_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "List.map_project f (Set_Monad xs) = Set_Monad (List.map_filter f xs)"
   "List.map_project g (DList_set dxs) = 
    (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''map_project DList_set: ceq = None'') (\<lambda>_. List.map_project g (DList_set dxs))
                    | Some _ \<Rightarrow> DList_Set.fold (\<lambda>x A. case g x of None \<Rightarrow> A | Some y \<Rightarrow> insert y A) dxs {})"
   (is ?dlist)
   "List.map_project h (RBT_set rbt) = 
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''map_project RBT_set: ccompare = None'') (\<lambda>_. List.map_project h (RBT_set rbt))
                       | Some _ \<Rightarrow> RBT_Set2.fold (\<lambda>x A. case h x of None \<Rightarrow> A | Some y \<Rightarrow> insert y A) rbt {})"
   (is ?rbt)
 proof -
   show ?dlist ?rbt
     by(auto split: option.split simp add: RBT_set_def DList_set_def DList_Set.fold.rep_eq Collect_member map_project_conv_fold RBT_Set2.fold_conv_fold_keys member_conv_keys del: equalityI)
 qed(auto simp add: List.map_project_def List.map_filter_def intro: rev_image_eqI)
 
 lemma Bleast_code [code]:
   "Bleast A P = 
   (if finite A then case filter P (sorted_list_of_set A) of [] \<Rightarrow> abort_Bleast A P | x # xs \<Rightarrow> x 
    else abort_Bleast A P)"
 proof(cases "finite A")
   case True
   hence *: "A = set (sorted_list_of_set A)" by(simp add: sorted_list_of_set)
   show ?thesis using True
     by(subst (1 3) *)(unfold Bleast_code, simp add: sorted_sort_id)
 qed(simp add: abort_Bleast_def Bleast_def)
 
 lemma can_select_code [code]:
   fixes xs :: "'a :: ceq list" 
   and dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "can_select P (Set_Monad xs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''can_select Set_Monad: ceq = None'') (\<lambda>_. can_select P (Set_Monad xs))
                  | Some eq \<Rightarrow> case filter P xs of Nil \<Rightarrow> False | x # xs \<Rightarrow> list_all (eq x) xs)"
   (is ?Set_Monad)
   "can_select Q (DList_set dxs) =
   (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''can_select DList_set: ceq = None'') (\<lambda>_. can_select Q (DList_set dxs))
                   | Some _ \<Rightarrow> DList_Set.length (DList_Set.filter Q dxs) = 1)"
   (is ?dlist)
   "can_select R (RBT_set rbt) =
   (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''can_select RBT_set: ccompare = None'') (\<lambda>_. can_select R (RBT_set rbt))
                  | Some _ \<Rightarrow> singleton_list_fusion (filter_generator R rbt_keys_generator) (RBT_Set2.init rbt))"
   (is ?rbt)
 proof -
   show ?Set_Monad
     apply(auto split: option.split list.split dest!: ID_ceq[THEN equal.equal_eq] dest: filter_eq_ConsD simp add: can_select_def filter_empty_conv list_all_iff)
     apply(drule filter_eq_ConsD, fastforce)
     apply(drule filter_eq_ConsD, clarsimp, blast)
     done
   
   show ?dlist
     by(clarsimp simp add: can_select_def card_eq_length[symmetric] Set_member_code card_eq_Suc_0_ex1 simp del: card_eq_length split: option.split)
   
   note [simp del] = distinct_keys
   show ?rbt
     using distinct_keys[of rbt]
     apply(auto simp add: can_select_def singleton_list_fusion_def unfoldr_filter_generator unfoldr_rbt_keys_generator Set_member_code member_conv_keys filter_empty_conv empty_filter_conv split: option.split list.split dest: filter_eq_ConsD)
       apply(drule filter_eq_ConsD, fastforce)
      apply(drule filter_eq_ConsD, fastforce simp add: empty_filter_conv)
     apply(drule filter_eq_ConsD)
     apply clarsimp
     apply(drule Cons_eq_filterD)
     apply clarify
     apply(simp (no_asm_use))
     apply blast
     done
 qed
 
 lemma pred_of_set_code [code]:
   fixes dxs :: "'a :: ceq set_dlist" 
   and rbt :: "'b :: ccompare set_rbt" shows
   "pred_of_set (Set_Monad xs) = fold (sup \<circ> Predicate.single) xs bot"
   "pred_of_set (DList_set dxs) =
    (case ID CEQ('a) of None \<Rightarrow> Code.abort (STR ''pred_of_set DList_set: ceq = None'') (\<lambda>_. pred_of_set (DList_set dxs))
                    | Some _ \<Rightarrow> DList_Set.fold (sup \<circ> Predicate.single) dxs bot)"
   "pred_of_set (RBT_set rbt) =
    (case ID CCOMPARE('b) of None \<Rightarrow> Code.abort (STR ''pred_of_set RBT_set: ccompare = None'') (\<lambda>_. pred_of_set (RBT_set rbt))
                       | Some _ \<Rightarrow> RBT_Set2.fold (sup \<circ> Predicate.single) rbt bot)"
 by(auto simp add: pred_of_set_set_fold_sup fold_map DList_set_def RBT_set_def Collect_member member_conv_keys DList_Set.fold.rep_eq fold_conv_fold_keys split: option.split)
 
 text \<open>
   @{typ "'a Predicate.pred"} is implemented as a monad, 
   so we keep the monad when converting to @{typ "'a set"}. 
   For this case, @{term insert_monad} and @{term union_monad} 
   avoid the unnecessary dictionary construction.
 \<close>
 
 definition insert_monad :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set"
 where [simp]: "insert_monad = insert"
 
 definition union_monad :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
 where [simp]: "union_monad = (\<union>)"
 
 lemma insert_monad_code [code]:
   "insert_monad x (Set_Monad xs) = Set_Monad (x # xs)"
 by simp
 
 lemma union_monad_code [code]:
   "union_monad (Set_Monad xs) (Set_Monad ys) = Set_Monad (xs @ ys)"
 by(simp)
 
 lemma set_of_pred_code [code]:
   "set_of_pred (Predicate.Seq f) = 
   (case f () of seq.Empty \<Rightarrow> Set_Monad []
    | seq.Insert x P \<Rightarrow> insert_monad x (set_of_pred P)
    | seq.Join P xq \<Rightarrow> union_monad (set_of_pred P) (set_of_seq xq))"
 by(simp add: of_pred_code cong: seq.case_cong)
 
 lemma set_of_seq_code [code]:
   "set_of_seq seq.Empty = Set_Monad []"
   "set_of_seq (seq.Insert x P) = insert_monad x (set_of_pred P)"
   "set_of_seq (seq.Join P xq) = union_monad (set_of_pred P) (set_of_seq xq)"
 by(simp_all add: of_seq_code)
 
 hide_const (open) insert_monad union_monad
 
 subsection \<open>Type class instantiations\<close>
 
 datatype set_impl = Set_IMPL
 declare
   set_impl.eq.simps [code del]
   set_impl.size [code del]
   set_impl.rec [code del]
   set_impl.case [code del]
 
 lemma [code]: 
   fixes x :: set_impl
   shows "size x = 0"
   and "size_set_impl x = 0"
 by(case_tac [!] x) simp_all
 
 definition set_Choose :: set_impl where [simp]: "set_Choose = Set_IMPL"
 definition set_Collect :: set_impl where [simp]: "set_Collect = Set_IMPL"
 definition set_DList :: set_impl where [simp]: "set_DList = Set_IMPL"
 definition set_RBT :: set_impl where [simp]: "set_RBT = Set_IMPL"
 definition set_Monad :: set_impl where [simp]: "set_Monad = Set_IMPL"
 
 code_datatype set_Choose set_Collect set_DList set_RBT set_Monad
 
 definition set_empty_choose :: "'a set" where [simp]: "set_empty_choose = {}"
 
 lemma set_empty_choose_code [code]:
   "(set_empty_choose :: 'a :: {ceq, ccompare} set) =
    (case CCOMPARE('a) of Some _  \<Rightarrow> RBT_set RBT_Set2.empty
     | None \<Rightarrow> case CEQ('a) of None \<Rightarrow> Set_Monad [] | Some _ \<Rightarrow> DList_set (DList_Set.empty))"
 by(simp split: option.split)
 
 definition set_impl_choose2 :: "set_impl \<Rightarrow> set_impl \<Rightarrow> set_impl"
 where [simp]: "set_impl_choose2 = (\<lambda>_ _. Set_IMPL)"
 
 lemma set_impl_choose2_code [code]:
   "set_impl_choose2 x y = set_Choose"
   "set_impl_choose2 set_Collect set_Collect = set_Collect"
   "set_impl_choose2 set_DList set_DList = set_DList"
   "set_impl_choose2 set_RBT set_RBT = set_RBT"
   "set_impl_choose2 set_Monad set_Monad = set_Monad"
 by(simp_all)
 
 definition set_empty :: "set_impl \<Rightarrow> 'a set"
 where [simp]: "set_empty = (\<lambda>_. {})"
 
 lemma set_empty_code [code]:
   "set_empty set_Collect = Collect_set (\<lambda>_. False)"
   "set_empty set_DList = DList_set DList_Set.empty"
   "set_empty set_RBT = RBT_set RBT_Set2.empty"
   "set_empty set_Monad = Set_Monad []"
   "set_empty set_Choose = set_empty_choose"
 by(simp_all)
 
 class set_impl =
   fixes set_impl :: "('a, set_impl) phantom"
 
 syntax (input)
   "_SET_IMPL" :: "type => logic"  ("(1SET'_IMPL/(1'(_')))")
 
 parse_translation \<open>
 let
   fun set_impl_tr [ty] =
      (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "set_impl"} $
        (Syntax.const @{type_syntax phantom} $ ty $ Syntax.const @{type_syntax set_impl}))
     | set_impl_tr ts = raise TERM ("set_impl_tr", ts);
 in [(@{syntax_const "_SET_IMPL"}, K set_impl_tr)] end
 \<close>
 
 declare [[code drop: "{}"]]
 
 lemma empty_code [code, code_unfold]: 
   "({} :: 'a :: set_impl set) = set_empty (of_phantom SET_IMPL('a))"
 by simp
 
 subsection \<open>Generator for the @{class set_impl}-class\<close>
 
 text \<open>
 This generator registers itself at the derive-manager for the classes @{class set_impl}.
 Here, one can choose
 the desired implementation via the parameter.
 
 \begin{itemize}
 \item \texttt{instantiation type :: (type,\ldots,type) (rbt,dlist,collect,monad,choose, or arbitrary constant name) set-impl}
 \end{itemize}
 \<close>
 
 
 text \<open>
 This generator can be used for arbitrary types, not just datatypes. 
 \<close>
 
 ML_file \<open>set_impl_generator.ML\<close> 
 
 derive (dlist) set_impl unit bool
 derive (rbt) set_impl nat
 derive (set_RBT) set_impl int (* shows usage of constant names *)
 derive (dlist) set_impl Enum.finite_1 Enum.finite_2 Enum.finite_3
 derive (rbt) set_impl integer natural
 derive (rbt) set_impl char
 
 instantiation sum :: (set_impl, set_impl) set_impl begin
 definition "SET_IMPL('a + 'b) = Phantom('a + 'b) 
   (set_impl_choose2 (of_phantom SET_IMPL('a)) (of_phantom SET_IMPL('b)))"
 instance ..
 end
 
 instantiation prod :: (set_impl, set_impl) set_impl begin
 definition "SET_IMPL('a * 'b) = Phantom('a * 'b) 
   (set_impl_choose2 (of_phantom SET_IMPL('a)) (of_phantom SET_IMPL('b)))"
 instance ..
 end
 
 derive (choose) set_impl list
 derive (rbt) set_impl String.literal
 
 instantiation option :: (set_impl) set_impl begin
 definition "SET_IMPL('a option) = Phantom('a option) (of_phantom SET_IMPL('a))"
 instance ..
 end
 
 derive (monad) set_impl "fun"
 derive (choose) set_impl set
 
 instantiation phantom :: (type, set_impl) set_impl begin
 definition "SET_IMPL(('a, 'b) phantom) = Phantom (('a, 'b) phantom) (of_phantom SET_IMPL('b))"
 instance ..
 end
 
 text \<open>
   We enable automatic implementation selection for sets constructed by @{const set},
   although they could be directly converted using @{const Set_Monad} in constant time.
   However, then it is more likely that the parameters of binary operators have 
   different implementations, which can lead to less efficient execution.
 
   However, we test whether automatic selection picks @{const Set_Monad} anyway and
   take a short-cut.
 \<close>
 
 definition set_aux :: "set_impl \<Rightarrow> 'a list \<Rightarrow> 'a set"
 where [simp, code del]: "set_aux _ = set"
 
 lemma set_aux_code [code]:
   defines "conv \<equiv> foldl (\<lambda>s (x :: 'a). insert x s)"
   shows
   "set_aux impl = conv (set_empty impl)" (is "?thesis1")
   "set_aux set_Choose = 
    (case CCOMPARE('a :: {ccompare, ceq}) of Some _  \<Rightarrow> conv (RBT_set RBT_Set2.empty)
     | None \<Rightarrow> case CEQ('a) of None \<Rightarrow> Set_Monad
               | Some _ \<Rightarrow> conv (DList_set DList_Set.empty))" (is "?thesis2")
   "set_aux set_Monad = Set_Monad"
 proof -
   have "conv {} = set"
     by(rule ext)(induct_tac x rule: rev_induct, simp_all add: conv_def)
   thus ?thesis1 ?thesis2
     by(simp_all split: option.split)
 qed simp
 
 lemma set_code [code]:
   fixes xs :: "'a :: set_impl list"
   shows "set xs = set_aux (of_phantom (ID SET_IMPL('a))) xs"
 by(simp)
 
 subsection \<open>Pretty printing for sets\<close>
 
 text \<open>
   @{term code_post} marks contexts (as hypothesis) in which we use code\_post as a
   decision procedure rather than a pretty-printing engine. 
   The intended use is to enable more rules when proving assumptions of rewrite rules.
 \<close>
 
 definition code_post :: bool where "code_post = True"
 
 lemma conj_code_post [code_post]: 
   assumes code_post
   shows "True & x \<longleftrightarrow> x" "False & x \<longleftrightarrow> False"
 by simp_all
 
 text \<open>
   A flag to switch post-processing of sets on and off.
   Use \verb$declare pretty_sets[code_post del]$ to disable pretty printing of sets in value.
 \<close>
 
 definition code_post_set :: bool
 where pretty_sets [code_post, simp]: "code_post_set = True"
 
 definition collapse_RBT_set :: "'a set_rbt \<Rightarrow> 'a :: ccompare set \<Rightarrow> 'a set"
 where "collapse_RBT_set r M = set (RBT_Set2.keys r) \<union> M"
 
 lemma RBT_set_collapse_RBT_set [code_post]:
   fixes r :: "'a :: ccompare set_rbt"
   assumes "code_post \<Longrightarrow> is_ccompare TYPE('a)" and code_post_set
   shows "RBT_set r = collapse_RBT_set r {}"
 using assms
 by(clarsimp simp add: code_post_def is_ccompare_def RBT_set_def member_conv_keys collapse_RBT_set_def)
 
 lemma collapse_RBT_set_Branch [code_post]: 
   "collapse_RBT_set (Mapping_RBT (Branch c l x v r)) M =
    collapse_RBT_set (Mapping_RBT l) (insert x (collapse_RBT_set (Mapping_RBT r) M))"
 unfolding collapse_RBT_set_def
 by(auto simp add: is_ccompare_def set_keys_Mapping_RBT)
 
 lemma collapse_RBT_set_Empty [code_post]: 
   "collapse_RBT_set (Mapping_RBT rbt.Empty) M = M"
 by(auto simp add: collapse_RBT_set_def set_keys_Mapping_RBT)
 
 definition collapse_DList_set :: "'a :: ceq set_dlist \<Rightarrow> 'a set"
 where "collapse_DList_set dxs = set (DList_Set.list_of_dlist dxs)"
 
 lemma DList_set_collapse_DList_set [code_post]:
   fixes dxs :: "'a :: ceq set_dlist"
   assumes "code_post \<Longrightarrow> is_ceq TYPE('a)" and code_post_set
   shows "DList_set dxs = collapse_DList_set dxs"
 using assms
 by(clarsimp simp add: code_post_def DList_set_def is_ceq_def collapse_DList_set_def Collect_member)
 
 lemma collapse_DList_set_empty [code_post]: "collapse_DList_set (Abs_dlist []) = {}"
 by(simp add: collapse_DList_set_def Abs_dlist_inverse)
 
 lemma collapse_DList_set_Cons [code_post]: 
   "collapse_DList_set (Abs_dlist (x # xs)) = insert x (collapse_DList_set (Abs_dlist xs))"
 by(simp add: collapse_DList_set_def set_list_of_dlist_Abs_dlist)
 
 lemma Set_Monad_code_post [code_post]:
   assumes code_post_set
   shows "Set_Monad [] = {}"
   and "Set_Monad (x#xs) = insert x (Set_Monad xs)"
 by simp_all
 
 end
diff --git a/thys/Containers/Set_Linorder.thy b/thys/Containers/Set_Linorder.thy
--- a/thys/Containers/Set_Linorder.thy
+++ b/thys/Containers/Set_Linorder.thy
@@ -1,2481 +1,2481 @@
 (*  Title:      Containers/Set_Linorder.thy
     Author:     Andreas Lochbihler, KIT *)
 
 theory Set_Linorder 
 imports
   Containers_Auxiliary
   Lexicographic_Order
   Extend_Partial_Order
   "HOL-Library.Cardinality"
 begin
 
 section \<open>An executable linear order on sets\<close>
 
 subsection \<open>Definition of the linear order\<close>
 
 subsubsection \<open>Extending finite and cofinite sets\<close>
 
 text \<open>
   Partition sets into finite and cofinite sets and distribute the rest arbitrarily such that
   complement switches between the two.
 \<close>
 
 consts infinite_complement_partition :: "'a set set"
 
 specification (infinite_complement_partition)
   finite_complement_partition: "finite (A :: 'a set) \<Longrightarrow> A \<in> infinite_complement_partition"
   complement_partition: "\<not> finite (UNIV :: 'a set)
     \<Longrightarrow> (A :: 'a set) \<in> infinite_complement_partition \<longleftrightarrow> - A \<notin> infinite_complement_partition"
 proof(cases "finite (UNIV :: 'a set)")
   case False
   define Field_r where "Field_r = {\<P> :: 'a set set. (\<forall>C \<in> \<P>. - C \<notin> \<P>) \<and> (\<forall>A. finite A \<longrightarrow> A \<in> \<P>)}"
   define r where "r = {(\<P>1, \<P>2). \<P>1 \<subseteq> \<P>2 \<and> \<P>1 \<in> Field_r \<and> \<P>2 \<in> Field_r}"
   have in_Field_r [simp]: "\<And>\<P>. \<P> \<in> Field_r \<longleftrightarrow> (\<forall>C \<in> \<P>. - C \<notin> \<P>) \<and> (\<forall>A. finite A \<longrightarrow> A \<in> \<P>)"
     unfolding Field_r_def by simp
   have in_r [simp]: "\<And>\<P>1 \<P>2. (\<P>1, \<P>2) \<in> r \<longleftrightarrow> \<P>1 \<subseteq> \<P>2 \<and> \<P>1 \<in> Field_r \<and> \<P>2 \<in> Field_r"
     unfolding r_def by simp
   have Field_r [simp]: "Field r = Field_r" by(auto simp add: Field_def Field_r_def)
   
   have "Partial_order r"
     by(auto simp add: Field_def r_def partial_order_on_def preorder_on_def intro!: refl_onI transI antisymI)
   moreover have "\<exists>\<B> \<in> Field r. \<forall>\<A> \<in> \<CC>. (\<A>, \<B>) \<in> r" if \<CC>: "\<CC> \<in> Chains r" for \<CC>
   proof -
     let ?\<B> = "\<Union>\<CC> \<union> {A. finite A}"
     have *: "?\<B> \<in> Field r" using False \<CC>
       by clarsimp(safe, drule (2) ChainsD, auto 4 4 dest: Chains_Field)
     hence "\<And>\<A>. \<A> \<in> \<CC> \<Longrightarrow> (\<A>, ?\<B>) \<in> r"
       using \<CC> by(auto simp del: in_Field_r dest: Chains_Field)
     with * show "\<exists>\<B> \<in> Field r. \<forall>\<A> \<in> \<CC>. (\<A>, \<B>) \<in> r" by blast
   qed
   ultimately have "\<exists>\<P> \<in> Field r. \<forall>\<A> \<in> Field r. (\<P>, \<A>) \<in> r \<longrightarrow> \<A> = \<P>"
     by(rule Zorns_po_lemma)
   then obtain \<P> where \<P>: "\<P> \<in> Field r" 
     and max: "\<And>\<A>. \<lbrakk> \<A> \<in> Field r; (\<P>, \<A>) \<in> r \<rbrakk> \<Longrightarrow> \<A> = \<P>" by blast
   have "\<forall>A. finite A \<longrightarrow> A \<in> \<P>" using \<P> by simp
   moreover {
     fix C
     have "C \<in> \<P> \<or> - C \<in> \<P>"
     proof(rule ccontr)
       assume "\<not> ?thesis"
       hence C: "C \<notin> \<P>" "- C \<notin> \<P>" by simp_all
       let ?\<A> = "insert C \<P>"
       have *: "?\<A> \<in> Field r" using C \<P> by auto
       hence "(\<P>, ?\<A>) \<in> r" using \<P> by auto
       with * have "?\<A> = \<P>" by(rule max)
       thus False using C by auto
     qed
     hence "C \<in> \<P> \<longleftrightarrow> - C \<notin> \<P>" using \<P> by auto }
   ultimately have "\<exists>\<P> :: 'a set set. (\<forall>A. finite A \<longrightarrow> A \<in> \<P>) \<and> (\<forall>C. C \<in> \<P> \<longleftrightarrow> - C \<notin> \<P>)"
     by blast
   thus ?thesis by metis
 qed auto
 
 lemma not_in_complement_partition:
   "\<not> finite (UNIV :: 'a set)
   \<Longrightarrow> (A :: 'a set) \<notin> infinite_complement_partition \<longleftrightarrow> - A \<in> infinite_complement_partition"
 by(metis complement_partition)
 
 lemma not_in_complement_partition_False:
   "\<lbrakk> (A :: 'a set) \<in> infinite_complement_partition; \<not> finite (UNIV :: 'a set) \<rbrakk> 
   \<Longrightarrow> - A \<in> infinite_complement_partition = False"
 by(simp add: not_in_complement_partition)
 
 lemma infinite_complement_partition_finite [simp]:
   "finite (UNIV :: 'a set) \<Longrightarrow> infinite_complement_partition = (UNIV :: 'a set set)"
 by(auto intro: finite_subset finite_complement_partition)
 
 lemma Compl_eq_empty_iff: "- A = {} \<longleftrightarrow> A = UNIV"
 by auto
 
 subsubsection \<open>A lexicographic-style order on finite subsets\<close>
 
 context ord begin
 
 definition set_less_aux :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubset>''" 50)
 where "A \<sqsubset>' B \<longleftrightarrow> finite A \<and> finite B \<and> (\<exists>y \<in> B - A. \<forall>z \<in> (A - B) \<union> (B - A). y \<le> z \<and> (z \<le> y \<longrightarrow> y = z))"
 
 definition set_less_eq_aux :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''" 50)
 where "A \<sqsubseteq>' B \<longleftrightarrow> A \<in> infinite_complement_partition \<and> A = B \<or> A \<sqsubset>' B"
 
 lemma set_less_aux_irrefl [iff]: "\<not> A \<sqsubset>' A"
 by(auto simp add: set_less_aux_def)
 
 lemma set_less_eq_aux_refl [iff]: "A \<sqsubseteq>' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 by(simp add: set_less_eq_aux_def)
 
 lemma set_less_aux_empty [simp]: "\<not> A \<sqsubset>' {}"
 by(auto simp add: set_less_aux_def intro: finite_subset finite_complement_partition)
 
 lemma set_less_eq_aux_empty [simp]: "A \<sqsubseteq>' {} \<longleftrightarrow> A = {}"
 by(auto simp add: set_less_eq_aux_def finite_complement_partition)
 
 lemma set_less_aux_antisym: "\<lbrakk> A \<sqsubset>' B; B \<sqsubset>' A \<rbrakk> \<Longrightarrow> False"
 by(auto simp add: set_less_aux_def split: if_split_asm)
 
 lemma set_less_aux_conv_set_less_eq_aux:
   "A \<sqsubset>' B \<longleftrightarrow> A \<sqsubseteq>' B \<and> \<not> B \<sqsubseteq>' A"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_antisym)
 
 lemma set_less_eq_aux_antisym: "\<lbrakk> A \<sqsubseteq>' B; B \<sqsubseteq>' A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_antisym)
 
 lemma set_less_aux_finiteD: "A \<sqsubset>' B \<Longrightarrow> finite A \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_aux_def finite_complement_partition)
 
 lemma set_less_eq_aux_infinite_complement_partitionD:
   "A \<sqsubseteq>' B \<Longrightarrow> A \<in> infinite_complement_partition \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_finiteD intro: finite_complement_partition)
 
 lemma Compl_set_less_aux_Compl:
   "finite (UNIV :: 'a set) \<Longrightarrow> - A \<sqsubset>' - B \<longleftrightarrow> B \<sqsubset>' A"
 by(auto simp add: set_less_aux_def finite_subset[OF subset_UNIV])
 
 lemma Compl_set_less_eq_aux_Compl: 
   "finite (UNIV :: 'a set) \<Longrightarrow> - A \<sqsubseteq>' - B \<longleftrightarrow> B \<sqsubseteq>' A"
 by(auto simp add: set_less_eq_aux_def Compl_set_less_aux_Compl)
 
 lemma set_less_aux_insert_same:
   "x \<in> A \<longleftrightarrow> x \<in> B \<Longrightarrow> insert x A \<sqsubset>' insert x B \<longleftrightarrow> A \<sqsubset>' B"
 by(auto simp add: set_less_aux_def)
 
 lemma set_less_eq_aux_insert_same:
   "\<lbrakk> A \<in> infinite_complement_partition; insert x B \<in> infinite_complement_partition;
     x \<in> A \<longleftrightarrow> x \<in> B \<rbrakk>
   \<Longrightarrow> insert x A \<sqsubseteq>' insert x B \<longleftrightarrow> A \<sqsubseteq>' B"
 by(auto simp add: set_less_eq_aux_def set_less_aux_insert_same)
 
 end
 
 context order begin
 
 lemma set_less_aux_singleton_iff: "A \<sqsubset>' {x} \<longleftrightarrow> finite A \<and> (\<forall>a\<in>A. x < a)"
 by(auto simp add: set_less_aux_def less_le Bex_def)
 
 end
 
 context linorder begin
 
 lemma wlog_le [case_names sym le]:
   assumes "\<And>a b. P a b \<Longrightarrow> P b a"
   and "\<And>a b. a \<le> b \<Longrightarrow> P a b"
   shows "P b a"
 by (metis assms linear)
 
 lemma empty_set_less_aux [simp]: "{} \<sqsubset>' A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
 by(auto 4 3 simp add: set_less_aux_def intro!: Min_eqI intro: bexI[where x="Min A"] order_trans[where y="Min A"] Min_in)
 
 lemma empty_set_less_eq_aux [simp]: "{} \<sqsubseteq>' A \<longleftrightarrow> finite A"
 by(auto simp add: set_less_eq_aux_def finite_complement_partition)
 
 lemma set_less_aux_trans:
   assumes AB: "A \<sqsubset>' B" and BC: "B \<sqsubset>' C"
   shows "A \<sqsubset>' C"
 proof -
   from AB BC have A: "finite A" and B: "finite B" and C: "finite C"
     by(auto simp add: set_less_aux_def)
   from AB A B obtain ab where ab: "ab \<in> B - A"
     and minAB: "\<And>x. \<lbrakk> x \<in> A; x \<notin> B \<rbrakk> \<Longrightarrow> ab \<le> x \<and> (x \<le> ab \<longrightarrow> ab = x)"
     and minBA: "\<And>x. \<lbrakk> x \<in> B; x \<notin> A \<rbrakk> \<Longrightarrow> ab \<le> x \<and> (x \<le> ab \<longrightarrow> ab = x)" 
     unfolding set_less_aux_def by auto
   from BC B C obtain bc where bc: "bc \<in> C - B"
     and minBC: "\<And>x. \<lbrakk> x \<in> B; x \<notin> C \<rbrakk> \<Longrightarrow> bc \<le> x \<and> (x \<le> bc \<longrightarrow> bc = x)"
     and minCB: "\<And>x. \<lbrakk> x \<in> C; x \<notin> B \<rbrakk> \<Longrightarrow> bc \<le> x \<and> (x \<le> bc \<longrightarrow> bc = x)"
     unfolding set_less_aux_def by auto
   show ?thesis
   proof(cases "ab \<le> bc")
     case True
     hence "ab \<in> C - A" "ab \<notin> A - C"
       using ab bc by(auto dest: minBC antisym)
     moreover {
       fix x
       assume x: "x \<in> (C - A) \<union> (A - C)"
       hence "ab \<le> x" 
         by(cases "x \<in> B")(auto dest: minAB minBA minBC minCB intro: order_trans[OF True])
       moreover hence "ab \<noteq> x \<longrightarrow> \<not> x \<le> ab" using ab bc x
         by(cases "x \<in> B")(auto dest: antisym)
       moreover note calculation }
     ultimately show ?thesis using A C unfolding set_less_aux_def by auto
   next
     case False
     with linear[of ab bc] have "bc \<le> ab" by simp
     with ab bc have "bc \<in> C - A" "bc \<notin> A - C" by(auto dest: minAB antisym)
     moreover {
       fix x
       assume x: "x \<in> (C - A) \<union> (A - C)"
       hence "bc \<le> x"
         by(cases "x \<in> B")(auto dest: minAB minBA minBC minCB intro: order_trans[OF \<open>bc \<le> ab\<close>])
       moreover hence "bc \<noteq> x \<longrightarrow> \<not> x \<le> bc" using ab bc x
         by(cases "x \<in> B")(auto dest: antisym) 
       moreover note calculation }
     ultimately show ?thesis using A C unfolding set_less_aux_def by auto
   qed
 qed
 
 lemma set_less_eq_aux_trans [trans]:
   "\<lbrakk> A \<sqsubseteq>' B; B \<sqsubseteq>' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' C"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_trans)
 
 lemma set_less_trans_set_less_eq [trans]:
   "\<lbrakk> A \<sqsubset>' B; B \<sqsubseteq>' C \<rbrakk> \<Longrightarrow> A \<sqsubset>' C"
 by(auto simp add: set_less_eq_aux_def dest: set_less_aux_trans)
 
 lemma set_less_eq_aux_porder: "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>' B}"
 by(auto simp add: preorder_on_def partial_order_on_def intro!: refl_onI transI antisymI dest: set_less_eq_aux_infinite_complement_partitionD intro: set_less_eq_aux_antisym set_less_eq_aux_trans del: equalityI)
 
 lemma psubset_finite_imp_set_less_aux:
   assumes AsB: "A \<subset> B" and B: "finite B"
   shows "A \<sqsubset>' B"
 proof -
   from AsB B have A: "finite A" by(auto intro: finite_subset)
   moreover from AsB B have "Min (B - A) \<in> B - A" by - (rule Min_in, auto)
   ultimately show ?thesis using B AsB
     by(auto simp add: set_less_aux_def intro!: rev_bexI[where x="Min (B - A)"] Min_eqI dest: Min_ge_iff[THEN iffD1, rotated 2])
 qed
 
 lemma subset_finite_imp_set_less_eq_aux:
   "\<lbrakk> A \<subseteq> B; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B"
 by(cases "A = B")(auto simp add: set_less_eq_aux_def finite_complement_partition intro: psubset_finite_imp_set_less_aux)
 
 lemma empty_set_less_aux_finite_iff: 
   "finite A \<Longrightarrow> {} \<sqsubset>' A \<longleftrightarrow> A \<noteq> {}"
 by(auto intro: psubset_finite_imp_set_less_aux)
 
 lemma set_less_aux_finite_total:
   assumes A: "finite A" and B: "finite B"
   shows "A \<sqsubset>' B \<or> A = B \<or> B \<sqsubset>' A"
 proof(cases "A \<subseteq> B \<or> B \<subseteq> A")
   case True thus ?thesis
     using A B psubset_finite_imp_set_less_aux[of A B] psubset_finite_imp_set_less_aux[of B A]
     by auto
 next
   case False
   hence A': "\<not> A \<subseteq> B" and B': "\<not> B \<subseteq> A" and AnB: "A \<noteq> B" by auto
   thus ?thesis using A B
   proof(induct "Min (B - A)" "Min (A - B)" arbitrary: A B rule: wlog_le)
     case (sym m n)
     from sym.hyps[OF refl refl] sym.prems show ?case by blast
   next
     case (le A B)
     note A = \<open>finite A\<close> and B = \<open>finite B\<close>
       and A' = \<open>\<not> A \<subseteq> B\<close> and B' = \<open>\<not> B \<subseteq> A\<close>
     { fix z
       assume z: "z \<in> (A - B) \<union> (B - A)"
       hence "Min (B - A) \<le> z \<and> (z \<le> Min (B - A) \<longrightarrow> Min (B - A) = z)"
       proof
         assume "z \<in> B - A" 
         hence "Min (B - A) \<le> z" by(simp add: B)
         thus ?thesis by auto
       next
         assume "z \<in> A - B"
         hence "Min (A - B) \<le> z" by(simp add: A)
         with le.hyps show ?thesis by(auto)
       qed }
     moreover have "Min (B - A) \<in> B - A" by(rule Min_in)(simp_all add: B B')
     ultimately have "A \<sqsubset>' B" using A B by(auto simp add: set_less_aux_def)
     thus ?case ..
   qed
 qed
 
 lemma set_less_eq_aux_finite_total:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B \<or> A = B \<or> B \<sqsubseteq>' A"
 by(drule (1) set_less_aux_finite_total)(auto simp add: set_less_eq_aux_def)
 
 lemma set_less_eq_aux_finite_total2:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq>' B \<or> B \<sqsubseteq>' A"
 by(drule (1) set_less_eq_aux_finite_total)(auto simp add: finite_complement_partition)
 
 lemma set_less_aux_rec:
   assumes A: "finite A" and B: "finite B"
   and A': "A \<noteq> {}" and B': "B \<noteq> {}"
   shows "A \<sqsubset>' B \<longleftrightarrow> Min B < Min A \<or> Min A = Min B \<and> A - {Min A} \<sqsubset>' B - {Min A}"
 proof(cases "Min A = Min B")
   case True
   from A A' B B' have "insert (Min A) A = A" "insert (Min B) B = B"
     by(auto simp add: ex_in_conv[symmetric] exI)
   with True show ?thesis
     by(subst (2) set_less_aux_insert_same[symmetric, where x="Min A"]) simp_all
 next
   case False
   have "A \<sqsubset>' B \<longleftrightarrow> Min B < Min A"
   proof
     assume AB: "A \<sqsubset>' B"
     with B A obtain ab where ab: "ab \<in> B - A"
       and AB: "\<And>x. \<lbrakk> x \<in> A; x \<notin> B \<rbrakk> \<Longrightarrow> ab \<le> x"
       by(auto simp add: set_less_aux_def)
     { fix a assume "a \<in> A"
       hence "Min B \<le> a" using A A' B B' ab
         by(cases "a \<in> B")(auto intro: order_trans[where y=ab] dest: AB) }
     hence "Min B \<le> Min A" using A A' by simp
     with False show "Min B < Min A" using False by auto
   next
     assume "Min B < Min A"
     hence "\<forall>z\<in>A - B \<union> (B - A). Min B \<le> z \<and> (z \<le> Min B \<longrightarrow> Min B = z)"
       using A B A' B' by(auto 4 4 intro: Min_in Min_eqI dest: bspec bspec[where x="Min B"])
     moreover have "Min B \<notin> A" using \<open>Min B < Min A\<close> by (metis A Min_le not_less)
     ultimately show "A \<sqsubset>' B" using A B A' B' by(simp add: set_less_aux_def bexI[where x="Min B"])
   qed
   thus ?thesis using False by simp
 qed
 
 lemma set_less_eq_aux_rec:
   assumes "finite A" "finite B" "A \<noteq> {}" "B \<noteq> {}"
   shows "A \<sqsubseteq>' B \<longleftrightarrow> Min B < Min A \<or> Min A = Min B \<and> A - {Min A} \<sqsubseteq>' B - {Min A}"
 proof(cases "A = B")
   case True thus ?thesis using assms by(simp add: finite_complement_partition)
 next
   case False
   moreover 
   hence "Min A = Min B \<Longrightarrow> A - {Min A} \<noteq> B - {Min B}"
     by (metis (lifting) assms Min_in insert_Diff)
   ultimately show ?thesis using set_less_aux_rec[OF assms]
     by(simp add: set_less_eq_aux_def cong: conj_cong)
 qed
 
 lemma set_less_aux_Min_antimono:
   "\<lbrakk> Min A < Min B;  finite A; finite B; A \<noteq> {} \<rbrakk> \<Longrightarrow> B \<sqsubset>' A"
 using set_less_aux_rec[of B A] 
 by(cases "B = {}")(simp_all add: empty_set_less_aux_finite_iff)
 
 lemma sorted_Cons_Min: "sorted (x # xs) \<Longrightarrow> Min (insert x (set xs)) = x"
   by(auto simp add: intro: Min_eqI)
 
 lemma set_less_aux_code:
   "\<lbrakk> sorted xs; distinct xs; sorted ys; distinct ys \<rbrakk>
-  \<Longrightarrow> set xs \<sqsubset>' set ys \<longleftrightarrow> order.lexordp (>) xs ys"
+  \<Longrightarrow> set xs \<sqsubset>' set ys \<longleftrightarrow> ord.lexordp (>) xs ys"
   apply(induct xs ys rule: list_induct2')
-     apply(simp_all add: order.lexordp_simps[OF local.dual_order] empty_set_less_aux_finite_iff sorted_Cons_Min set_less_aux_rec neq_Nil_conv)
+     apply(simp_all add: empty_set_less_aux_finite_iff sorted_Cons_Min set_less_aux_rec neq_Nil_conv)
   apply(auto cong: conj_cong)
   done
 
 lemma set_less_eq_aux_code:
   assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys"
-  shows "set xs \<sqsubseteq>' set ys \<longleftrightarrow> order.lexordp_eq (>) xs ys"
+  shows "set xs \<sqsubseteq>' set ys \<longleftrightarrow> ord.lexordp_eq (>) xs ys"
 proof -
   have dual: "class.linorder (\<ge>) (>)"
     by(rule linorder.dual_linorder) unfold_locales
   from assms show ?thesis
     by(auto simp add: set_less_eq_aux_def finite_complement_partition linorder.lexordp_eq_conv_lexord[OF dual] set_less_aux_code intro: sorted_distinct_set_unique)
 qed
 
 end
 
 subsubsection \<open>Extending @{term set_less_eq_aux} to have @{term "{}"} as least element\<close>
 
 context ord begin
 
 definition set_less_eq_aux' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''''" 50)
 where "A \<sqsubseteq>'' B \<longleftrightarrow> A \<sqsubseteq>' B \<or> A = {} \<and> B \<in> infinite_complement_partition"
 
 lemma set_less_eq_aux'_refl:
   "A \<sqsubseteq>'' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def)
 
 lemma set_less_eq_aux'_antisym: "\<lbrakk> A \<sqsubseteq>'' B; B \<sqsubseteq>'' A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_aux'_def intro: set_less_eq_aux_antisym del: equalityI)
 
 lemma set_less_eq_aux'_infinite_complement_partitionD:
   "A \<sqsubseteq>'' B \<Longrightarrow> A \<in> infinite_complement_partition \<and> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def intro: finite_complement_partition dest: set_less_eq_aux_infinite_complement_partitionD)
 
 lemma empty_set_less_eq_def [simp]: "{} \<sqsubseteq>'' B \<longleftrightarrow> B \<in> infinite_complement_partition"
 by(auto simp add: set_less_eq_aux'_def dest: set_less_eq_aux_infinite_complement_partitionD)
 
 end
 
 context linorder begin
 
 lemma set_less_eq_aux'_trans: "\<lbrakk> A \<sqsubseteq>'' B; B \<sqsubseteq>'' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>'' C"
 by(auto simp add: set_less_eq_aux'_def del: equalityI intro: set_less_eq_aux_trans dest: set_less_eq_aux_infinite_complement_partitionD)
 
 lemma set_less_eq_aux'_porder: "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>'' B}"
 by(auto simp add: partial_order_on_def preorder_on_def intro!: refl_onI transI antisymI dest: set_less_eq_aux'_antisym set_less_eq_aux'_infinite_complement_partitionD simp add: set_less_eq_aux'_refl intro: set_less_eq_aux'_trans)
 
 end
 
 subsubsection \<open>Extend @{term set_less_eq_aux'} to a total order on @{term infinite_complement_partition}\<close>
 
 context ord begin
 
 definition set_less_eq_aux'' :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>''''''" 50)
 where "set_less_eq_aux'' =
   (SOME sleq. 
     (linear_order_on UNIV {(a, b). a \<le> b} \<longrightarrow> linear_order_on infinite_complement_partition {(A, B). sleq A B}) \<and> order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). sleq A B})"
 
 lemma set_less_eq_aux''_spec:
   shows "linear_order {(a, b). a \<le> b} \<Longrightarrow> linear_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>''' B}"
   (is "PROP ?thesis1")
   and "order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). A \<sqsubseteq>''' B}" (is ?thesis2)
 proof -
   let ?P = "\<lambda>sleq. (linear_order {(a, b). a \<le> b} \<longrightarrow> linear_order_on infinite_complement_partition {(A, B). sleq A B}) \<and> 
                   order_consistent {(A, B). A \<sqsubseteq>'' B} {(A, B). sleq A B}"
   have "Ex ?P"
   proof(cases "linear_order {(a, b). a \<le> b}")
     case False
     have "antisym {(a, b). a \<sqsubseteq>'' b}"
       by (rule antisymI) (simp add: set_less_eq_aux'_antisym)
     then show ?thesis using False
       by (auto intro: antisym_order_consistent_self)
   next
     case True
     hence "partial_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>'' B}"
       by(rule linorder.set_less_eq_aux'_porder[OF linear_order_imp_linorder])
     then obtain s where "linear_order_on infinite_complement_partition s"
       and "order_consistent {(A, B). A \<sqsubseteq>'' B} s" by(rule porder_extend_to_linorder)
     thus ?thesis by(auto intro: exI[where x="\<lambda>A B. (A, B) \<in> s"])
   qed
   hence "?P (Eps ?P)" by(rule someI_ex)
   thus "PROP ?thesis1" ?thesis2 by(simp_all add: set_less_eq_aux''_def)
 qed
 
 end
 
 context linorder begin
 
 lemma set_less_eq_aux''_linear_order:
   "linear_order_on infinite_complement_partition {(A, B). A \<sqsubseteq>''' B}"
 by(rule set_less_eq_aux''_spec)(rule linear_order)
 
 lemma set_less_eq_aux''_refl [iff]: "A \<sqsubseteq>''' A \<longleftrightarrow> A \<in> infinite_complement_partition"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: refl_onD refl_onD1)
 
 lemma set_less_eq_aux'_into_set_less_eq_aux'':
   assumes "A \<sqsubseteq>'' B" 
   shows "A \<sqsubseteq>''' B"
 proof(rule ccontr)
   assume nleq: "\<not> ?thesis"
   moreover from assms have A: "A \<in> infinite_complement_partition" 
     and B: "B \<in> infinite_complement_partition"
     by(auto dest: set_less_eq_aux'_infinite_complement_partitionD)
   with set_less_eq_aux''_linear_order have "A \<sqsubseteq>''' B \<or> A = B \<or> B \<sqsubseteq>''' A"
     by(auto simp add: linear_order_on_def dest: total_onD)
   ultimately have "B \<sqsubseteq>''' A" using B by auto
   with assms have "A = B" using set_less_eq_aux''_spec(2)
     by(simp add: order_consistent_def)
   with A nleq show False by simp
 qed
 
 lemma finite_set_less_eq_aux''_finite:
   assumes "finite A" and "finite B"
   shows "A \<sqsubseteq>''' B \<longleftrightarrow> A \<sqsubseteq>'' B"
 proof
   assume "A \<sqsubseteq>''' B"
   from assms have "A \<sqsubseteq>' B \<or> B \<sqsubseteq>' A" by(rule set_less_eq_aux_finite_total2)
   hence "A \<sqsubseteq>'' B \<or> B \<sqsubseteq>'' A" by(auto simp add: set_less_eq_aux'_def)
   thus "A \<sqsubseteq>'' B"
   proof
     assume "B \<sqsubseteq>'' A"
     hence "B \<sqsubseteq>''' A" by(rule set_less_eq_aux'_into_set_less_eq_aux'')
     with \<open>A \<sqsubseteq>''' B\<close> set_less_eq_aux''_linear_order have "A = B"
       by(auto simp add: linear_order_on_def partial_order_on_def dest: antisymD)
     thus ?thesis using assms by(simp add: finite_complement_partition set_less_eq_aux'_def)
   qed
 qed(rule set_less_eq_aux'_into_set_less_eq_aux'')
 
 lemma set_less_eq_aux''_finite:
   "finite (UNIV :: 'a set) \<Longrightarrow> set_less_eq_aux'' = set_less_eq_aux"
 by(auto simp add: fun_eq_iff finite_set_less_eq_aux''_finite set_less_eq_aux'_def finite_subset[OF subset_UNIV])
 
 lemma set_less_eq_aux''_antisym:
   "\<lbrakk> A \<sqsubseteq>''' B; B \<sqsubseteq>''' A; 
      A \<in> infinite_complement_partition; B \<in> infinite_complement_partition \<rbrakk>
   \<Longrightarrow> A = B"
 using set_less_eq_aux''_linear_order 
 by(auto simp add: linear_order_on_def partial_order_on_def dest: antisymD del: equalityI)
 
 lemma set_less_eq_aux''_trans: "\<lbrakk> A \<sqsubseteq>''' B; B \<sqsubseteq>''' C \<rbrakk> \<Longrightarrow> A \<sqsubseteq>''' C"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: transD)
 
 lemma set_less_eq_aux''_total:
   "\<lbrakk> A \<in> infinite_complement_partition; B \<in> infinite_complement_partition \<rbrakk>
   \<Longrightarrow> A \<sqsubseteq>''' B \<or> B \<sqsubseteq>''' A"
 using set_less_eq_aux''_linear_order
 by(auto simp add: linear_order_on_def dest: total_onD)
 
 end
 
 subsubsection \<open>Extend @{term set_less_eq_aux''} to cofinite sets\<close>
 
 context ord begin
 
 definition set_less_eq :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
 where 
   "A \<sqsubseteq> B \<longleftrightarrow> 
   (if A \<in> infinite_complement_partition then A \<sqsubseteq>''' B \<or> B \<notin> infinite_complement_partition
    else B \<notin> infinite_complement_partition \<and> - B \<sqsubseteq>''' - A)"
 
 definition set_less :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<sqsubset>" 50)
 where "A \<sqsubset> B \<longleftrightarrow> A \<sqsubseteq> B \<and> \<not> B \<sqsubseteq> A"
 
 lemma set_less_eq_def2:
   "A \<sqsubseteq> B \<longleftrightarrow>
   (if finite (UNIV :: 'a set) then A \<sqsubseteq>''' B 
    else if A \<in> infinite_complement_partition then A \<sqsubseteq>''' B \<or> B \<notin> infinite_complement_partition
    else B \<notin> infinite_complement_partition \<and> - B \<sqsubseteq>''' - A)"
 by(simp add: set_less_eq_def)
 
 end
 
 context linorder begin
 
 lemma set_less_eq_refl [iff]: "A \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 not_in_complement_partition)
 
 lemma set_less_eq_antisym: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> A \<rbrakk> \<Longrightarrow> A = B"
 by(auto simp add: set_less_eq_def2 set_less_eq_aux''_finite not_in_complement_partition not_in_complement_partition_False del: equalityI split: if_split_asm dest: set_less_eq_aux_antisym set_less_eq_aux''_antisym)
 
 lemma set_less_eq_trans: "\<lbrakk> A \<sqsubseteq> B; B \<sqsubseteq> C \<rbrakk> \<Longrightarrow> A \<sqsubseteq> C"
 by(auto simp add: set_less_eq_def split: if_split_asm intro: set_less_eq_aux''_trans)
 
 lemma set_less_eq_total: "A \<sqsubseteq> B \<or> B \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 set_less_eq_aux''_finite not_in_complement_partition not_in_complement_partition_False intro: set_less_eq_aux_finite_total2 finite_subset[OF subset_UNIV] del: disjCI dest: set_less_eq_aux''_total)
 
 lemma set_less_eq_linorder: "class.linorder (\<sqsubseteq>) (\<sqsubset>)"
 by(unfold_locales)(auto simp add: set_less_def set_less_eq_antisym set_less_eq_total intro: set_less_eq_trans)
 
 lemma set_less_eq_conv_set_less: "set_less_eq A B \<longleftrightarrow> A = B \<or> set_less A B"
 by(auto simp add: set_less_def del: equalityI dest: set_less_eq_antisym)
 
 lemma Compl_set_less_eq_Compl: "- A \<sqsubseteq> - B \<longleftrightarrow> B \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def2 not_in_complement_partition_False not_in_complement_partition set_less_eq_aux''_finite Compl_set_less_eq_aux_Compl)
 
 lemma Compl_set_less_Compl: "- A \<sqsubset> - B \<longleftrightarrow> B \<sqsubset> A"
 by(simp add: set_less_def Compl_set_less_eq_Compl)
 
 lemma set_less_eq_finite_iff: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubseteq> B \<longleftrightarrow> A \<sqsubseteq>' B"
 by(auto simp add: set_less_eq_def finite_complement_partition set_less_eq_aux'_def finite_set_less_eq_aux''_finite)
 
 lemma set_less_finite_iff: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> A \<sqsubset> B \<longleftrightarrow> A \<sqsubset>' B"
 by(simp add: set_less_def set_less_aux_conv_set_less_eq_aux set_less_eq_finite_iff)
 
 lemma infinite_set_less_eq_Complement:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> A \<sqsubseteq> - B"
 by(simp add: set_less_eq_def finite_complement_partition not_in_complement_partition)
 
 lemma infinite_set_less_Complement:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> A \<sqsubset> - B"
 by(auto simp add: set_less_def dest: set_less_eq_antisym intro: infinite_set_less_eq_Complement)
 
 lemma infinite_Complement_set_less_eq:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> \<not> - A \<sqsubseteq> B"
 using infinite_set_less_eq_Complement[of A B] Compl_set_less_eq_Compl[of A "- B"]
 by(auto dest: set_less_eq_antisym)
 
 lemma infinite_Complement_set_less:
   "\<lbrakk> finite A; finite B; \<not> finite (UNIV :: 'a set) \<rbrakk> \<Longrightarrow> \<not> - A \<sqsubset> B"
 using infinite_Complement_set_less_eq[of A B]
 by(simp add: set_less_def)
 
 lemma empty_set_less_eq [iff]: "{} \<sqsubseteq> A"
 by(auto simp add: set_less_eq_def finite_complement_partition intro: set_less_eq_aux'_into_set_less_eq_aux'')
 
 lemma set_less_eq_empty [iff]: "A \<sqsubseteq> {} \<longleftrightarrow> A = {}"
 by (metis empty_set_less_eq set_less_eq_antisym)
 
 lemma empty_set_less_iff [iff]: "{} \<sqsubset> A \<longleftrightarrow> A \<noteq> {}"
 by(simp add: set_less_def)
 
 lemma not_set_less_empty [simp]: "\<not> A \<sqsubset> {}"
 by(simp add: set_less_def)
 
 lemma set_less_eq_UNIV [iff]: "A \<sqsubseteq> UNIV"
 using Compl_set_less_eq_Compl[of "- A" "{}"] by simp
 
 lemma UNIV_set_less_eq [iff]: "UNIV \<sqsubseteq> A \<longleftrightarrow> A = UNIV"
 using Compl_set_less_eq_Compl[of "{}" "- A"]
 by(simp add: Compl_eq_empty_iff)
 
 lemma set_less_UNIV_iff [iff]: "A \<sqsubset> UNIV \<longleftrightarrow> A \<noteq> UNIV"
 by(simp add: set_less_def)
 
 lemma not_UNIV_set_less [simp]: "\<not> UNIV \<sqsubset> A"
 by(simp add: set_less_def)
 
 end
 
 subsection \<open>Implementation based on sorted lists\<close>
 
 type_synonym 'a proper_interval = "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
 
 class proper_intrvl = ord +
   fixes proper_interval :: "'a proper_interval"
 
 class proper_interval = proper_intrvl +
   assumes proper_interval_simps:
   "proper_interval None None = True"
   "proper_interval None (Some y) = (\<exists>z. z < y)"
   "proper_interval (Some x) None = (\<exists>z. x < z)"
   "proper_interval (Some x) (Some y) = (\<exists>z. x < z \<and> z < y)"
 
 context proper_intrvl begin
 
 function set_less_eq_aux_Compl :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "set_less_eq_aux_Compl ao [] ys \<longleftrightarrow> True"
 | "set_less_eq_aux_Compl ao xs [] \<longleftrightarrow> True"
 | "set_less_eq_aux_Compl ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then proper_interval ao (Some x) \<or> set_less_eq_aux_Compl (Some x) xs (y # ys)
    else if y < x then proper_interval ao (Some y) \<or> set_less_eq_aux_Compl (Some y) (x # xs) ys
    else proper_interval ao (Some y))"
 by(pat_completeness) simp_all
 termination by(lexicographic_order)
 
 fun Compl_set_less_eq_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "Compl_set_less_eq_aux ao [] [] \<longleftrightarrow> \<not> proper_interval ao None"
 | "Compl_set_less_eq_aux ao [] (y # ys) \<longleftrightarrow> \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux (Some y) [] ys"
 | "Compl_set_less_eq_aux ao (x # xs) [] \<longleftrightarrow> \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux (Some x) xs []"
 | "Compl_set_less_eq_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux (Some x) xs (y # ys)
    else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some y))"
 
 fun set_less_aux_Compl :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "set_less_aux_Compl ao [] [] \<longleftrightarrow> proper_interval ao None"
 | "set_less_aux_Compl ao [] (y # ys) \<longleftrightarrow> proper_interval ao (Some y) \<or> set_less_aux_Compl (Some y) [] ys"
 | "set_less_aux_Compl ao (x # xs) [] \<longleftrightarrow> proper_interval ao (Some x) \<or> set_less_aux_Compl (Some x) xs []"
 | "set_less_aux_Compl ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then proper_interval ao (Some x) \<or> set_less_aux_Compl (Some x) xs (y # ys)
    else if y < x then proper_interval ao (Some y) \<or> set_less_aux_Compl (Some y) (x # xs) ys
    else proper_interval ao (Some y))"
 
 function Compl_set_less_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "Compl_set_less_aux ao [] ys \<longleftrightarrow> False"
 | "Compl_set_less_aux ao xs [] \<longleftrightarrow> False"
 | "Compl_set_less_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_aux (Some x) xs (y # ys)
    else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some y))"
 by pat_completeness simp_all
 termination by lexicographic_order
 
 end
 
 lemmas [code] =
   proper_intrvl.set_less_eq_aux_Compl.simps
   proper_intrvl.set_less_aux_Compl.simps
   proper_intrvl.Compl_set_less_eq_aux.simps
   proper_intrvl.Compl_set_less_aux.simps
 
 class linorder_proper_interval = linorder + proper_interval 
 begin
 
 theorem assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs"
   and ys: "sorted ys" "distinct ys"
   shows set_less_eq_aux_Compl2_conv_set_less_eq_aux_Compl:
   "set xs \<sqsubseteq>' - set ys \<longleftrightarrow> set_less_eq_aux_Compl None xs ys" (is ?Compl2)
   and Compl1_set_less_eq_aux_conv_Compl_set_less_eq_aux:
   "- set xs \<sqsubseteq>' set ys \<longleftrightarrow> Compl_set_less_eq_aux None xs ys" (is ?Compl1)
 proof -
   note fin' [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     and proper_interval_None2: "\<And>ao. proper_interval ao None \<longleftrightarrow> above ao \<noteq> {}"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao x A B
     assume ex: "proper_interval ao (Some x)"
       and A: "\<forall>a \<in> A. x \<le> a"
       and B: "\<forall>b \<in> B. x \<le> b"
     from ex obtain z where z_ao: "z \<in> above ao" and z: "z < x"
       by(auto simp add: proper_interval_Some2)
     with A have A_eq: "A \<inter> above ao = A"
       by(auto simp add: above_upclosed)
     from z_ao z B have B_eq: "B \<inter> above ao = B"
       by(auto simp add: above_upclosed)
     define w where "w = Min (above ao)"
     with z_ao have "w \<le> z" "\<forall>z \<in> above ao. w \<le> z" "w \<in> above ao"
       by(auto simp add: Min_le_iff intro: Min_in)
     hence "A \<inter> above ao \<sqsubset>' (- B) \<inter> above ao" (is "?lhs \<sqsubset>' ?rhs")
       using A B z by(auto simp add: set_less_aux_def intro!: bexI[where x="w"])
     hence "A \<sqsubseteq>' ?rhs" unfolding A_eq by(simp add: set_less_eq_aux_def)
     moreover 
     from z_ao z A B have "z \<in> - A \<inter> above ao" "z \<notin> B" by auto
     hence neq: "- A \<inter> above ao \<noteq> B \<inter> above ao" by auto
     have "\<not> - A \<inter> above ao \<sqsubset>' B \<inter> above ao" (is "\<not> ?lhs' \<sqsubset>' ?rhs'")
       using A B z z_ao by(force simp add: set_less_aux_def not_less dest: bspec[where x=z])
     with neq have "\<not> ?lhs' \<sqsubseteq>' B" unfolding B_eq by(auto simp add: set_less_eq_aux_def)
     moreover note calculation }
   note proper_interval_set_less_eqI = this(1)
     and proper_interval_not_set_less_eq_auxI = this(2)
 
   { fix ao
     assume "set xs \<union> set ys \<subseteq> above ao"
     with xs ys
     have "set_less_eq_aux_Compl ao xs ys \<longleftrightarrow> set xs \<sqsubseteq>' (- set ys) \<inter> above ao"
     proof(induction ao xs ys rule: set_less_eq_aux_Compl.induct)
       case 1 thus ?case by simp
     next
       case 2 thus ?case by(auto intro: subset_finite_imp_set_less_eq_aux)
     next
       case (3 ao x xs y ys)
       note ao = \<open>set (x # xs) \<union> set (y # ys) \<subseteq> above ao\<close>
       hence x_ao: "x \<in> above ao" and y_ao: "y \<in> above ao" by simp_all
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y' \<in> set ys. y < y'"
         by(auto simp add: less_le)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x' \<in> set xs. x < x'"
         by(auto simp add: less_le)
       let ?lhs = "set (x # xs)" and ?rhs = "- set (y # ys) \<inter> above ao"
       show ?case
       proof(cases "x < y")
         case True
         show ?thesis
         proof(cases "proper_interval ao (Some x)")
           case True
           hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x < y\<close>
             by(auto intro!: proper_interval_set_less_eqI)
           with True show ?thesis using \<open>x < y\<close> by simp
         next
           case False
           have "set xs \<union> set (y # ys) \<subseteq> above (Some x)" using True x_Min y_Min by auto
           with True xs yys
           have IH: "set_less_eq_aux_Compl (Some x) xs (y # ys) = 
             (set xs \<sqsubseteq>' - set (y # ys) \<inter> above (Some x))"
             by(rule "3.IH")
           from True y_Min x_ao have "x \<in> - set (y # ys) \<inter> above ao" by auto
           hence "?rhs \<noteq> {}" by blast
           moreover have "Min ?lhs = x" using x_Min x_ao by(auto intro!: Min_eqI)
           moreover have "Min ?rhs = x" using \<open>x < y\<close> y_Min x_ao False
             by(auto intro!: Min_eqI simp add: proper_interval_Some2)
           moreover have "set xs = set xs - {x}"
             using ao x_Min by auto
           moreover have "- set (y # ys) \<inter> above (Some x) = - set (y # ys) \<inter> above ao - {x}"
             using False x_ao by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           ultimately show ?thesis using True False IH
             by(simp del: set_simps)(subst (2) set_less_eq_aux_rec, simp_all add: x_ao)
         qed
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis
           proof(cases "proper_interval ao (Some y)")
             case True
             hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>\<not> x < y\<close>
               by(auto intro!: proper_interval_set_less_eqI)
             with True show ?thesis using \<open>\<not> x < y\<close> by simp
           next
             case False
             have "set (x # xs) \<union> set ys \<subseteq> above (Some y)"
               using \<open>y < x\<close> x_Min y_Min by auto
             with \<open>\<not> x < y\<close> \<open>y < x\<close> xxs ys
             have IH: "set_less_eq_aux_Compl (Some y) (x # xs) ys = 
               (set (x # xs) \<sqsubseteq>' - set ys \<inter> above (Some y))"
               by(rule "3.IH")
             moreover have "- set ys \<inter> above (Some y) = ?rhs"
               using y_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
             ultimately show ?thesis using \<open>\<not> x < y\<close> True False by simp
           qed
         next
           case False with \<open>\<not> x < y\<close> have "x = y" by auto
           { assume "proper_interval ao (Some y)"
             hence "?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x = y\<close>
               by(auto intro!: proper_interval_set_less_eqI) }
           moreover
           { assume "?lhs \<sqsubseteq>' ?rhs"
             moreover have "?lhs \<noteq> ?rhs"
             proof
               assume eq: "?lhs = ?rhs"
               have "x \<in> ?lhs" using x_ao by simp
               also note eq also note \<open>x = y\<close>
               finally show False by simp
             qed
             ultimately obtain z where "z \<in> above ao" "z < y" using \<open>x = y\<close> y_ao
               by(fastforce simp add: set_less_eq_aux_def set_less_aux_def not_le dest!: bspec[where x=y])
             hence "proper_interval ao (Some y)" by(auto simp add: proper_interval_Some2) }
           ultimately show ?thesis using \<open>x = y\<close> \<open>\<not> x < y\<close> \<open>\<not> y < x\<close> by auto
         qed
       qed
     qed }
   from this[of None] show ?Compl2 by simp
   
   { fix ao
     assume "set xs \<union> set ys \<subseteq> above ao"
     with xs ys
     have "Compl_set_less_eq_aux ao xs ys \<longleftrightarrow> (- set xs) \<inter> above ao \<sqsubseteq>' set ys"
     proof(induction ao xs ys rule: Compl_set_less_eq_aux.induct)
       case 1 thus ?case by(simp add: proper_interval_None2)
     next
       case (2 ao y ys)
       from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       have ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y' \<in> set ys. y < y'"
         by(auto simp add: less_le)
       show ?case
       proof(cases "proper_interval ao (Some y)")
         case True 
         hence "\<not> - set [] \<inter> above ao \<sqsubseteq>' set (y # ys)" using y_Min
           by -(erule proper_interval_not_set_less_eq_auxI, auto)
         thus ?thesis using True by simp
       next
         case False
         note ao = \<open>set [] \<union> set (y # ys) \<subseteq> above ao\<close> 
         hence y_ao: "y \<in> above ao" by simp
         from ao y_Min have "set [] \<union> set ys \<subseteq> above (Some y)" by auto
         with \<open>sorted []\<close> \<open>distinct []\<close> ys
         have "Compl_set_less_eq_aux (Some y) [] ys \<longleftrightarrow> - set [] \<inter> above (Some y) \<sqsubseteq>' set ys"
           by(rule "2.IH")
         moreover have "above ao \<noteq> {}" using y_ao by auto
         moreover have "Min (above ao) = y" 
           and "Min (set (y # ys)) = y"
           using y_ao False ao by(auto intro!: Min_eqI simp add: proper_interval_Some2 not_less)
         moreover have "above ao - {y} = above (Some y)" using False y_ao
           by(auto simp add: proper_interval_Some2 intro: above_upclosed)
         moreover have "set ys - {y} = set ys" 
           using y_Min y_ao by(auto)
         ultimately show ?thesis using False y_ao
           by(simp)(subst (2) set_less_eq_aux_rec, simp_all)
       qed
     next
       case (3 ao x xs)
       from \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       have xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       show ?case
       proof(cases "proper_interval ao (Some x)")
         case True
         then obtain z where "z \<in> above ao" "z < x" by(auto simp add: proper_interval_Some2)
         hence "z \<in> - set (x # xs) \<inter> above ao" using x_Min by auto
         thus ?thesis using True by auto
       next
         case False
         note ao = \<open>set (x # xs) \<union> set [] \<subseteq> above ao\<close>
         hence x_ao: "x \<in> above ao" by simp
         from ao have "set xs \<union> set [] \<subseteq> above (Some x)" using x_Min by auto
         with xs \<open>sorted []\<close> \<open>distinct []\<close> 
         have "Compl_set_less_eq_aux (Some x) xs [] \<longleftrightarrow>
           - set xs \<inter> above (Some x) \<sqsubseteq>' set []"
           by(rule "3.IH")
         moreover have "- set (x # xs) \<inter> above ao = - set xs \<inter> above (Some x)" 
           using False x_ao by(auto simp add: proper_interval_Some2 intro: above_upclosed)
         ultimately show ?thesis using False by simp
       qed
     next
       case (4 ao x xs y ys)
       note ao = \<open>set (x # xs) \<union> set (y # ys) \<subseteq> above ao\<close>
       hence x_ao: "x \<in> above ao" and y_ao: "y \<in> above ao" by simp_all
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
       let ?lhs = "- set (x # xs) \<inter> above ao" and ?rhs = "set (y # ys)"
       show ?case
       proof(cases "x < y")
         case True
         show ?thesis
         proof(cases "proper_interval ao (Some x)")
           case True
           hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x < y\<close>
             by -(erule proper_interval_not_set_less_eq_auxI, auto)
           thus ?thesis using True \<open>x < y\<close> by simp
         next
           case False
           have "set xs \<union> set (y # ys) \<subseteq> above (Some x)" 
             using ao x_Min y_Min True by auto
           with True xs yys
           have "Compl_set_less_eq_aux (Some x) xs (y # ys) \<longleftrightarrow> 
             - set xs \<inter> above (Some x) \<sqsubseteq>' set (y # ys)"
             by(rule "4.IH")
           moreover have "- set xs \<inter> above (Some x) = ?lhs"
             using x_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
           ultimately show ?thesis using False True by simp
         qed
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis
           proof(cases "proper_interval ao (Some y)")
             case True
             hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>y < x\<close>
               by -(erule proper_interval_not_set_less_eq_auxI, auto)
             thus ?thesis using True \<open>y < x\<close> \<open>\<not> x < y\<close> by simp
           next
             case False
             from ao True x_Min y_Min 
             have "set (x # xs) \<union> set ys \<subseteq> above (Some y)" by auto
             with \<open>\<not> x < y\<close> True xxs ys
             have "Compl_set_less_eq_aux (Some y) (x # xs) ys \<longleftrightarrow>
               - set (x # xs) \<inter> above (Some y) \<sqsubseteq>' set ys"
               by(rule "4.IH")
             moreover have "y \<in> ?lhs" using True x_Min y_ao by auto
             hence "?lhs \<noteq> {}" by auto
             moreover have "Min ?lhs = y" using True False x_Min y_ao
               by(auto intro!: Min_eqI simp add: not_le not_less proper_interval_Some2)
             moreover have "Min ?rhs = y" using y_Min y_ao by(auto intro!: Min_eqI)
             moreover have "- set (x # xs) \<inter> above (Some y) = ?lhs - {y}"
               using y_ao False by(auto intro: above_upclosed simp add: proper_interval_Some2)
             moreover have "set ys = set ys - {y}"
               using y_ao y_Min by(auto intro: above_upclosed)
             ultimately show ?thesis using True False \<open>\<not> x < y\<close> y_ao
               by(simp)(subst (2) set_less_eq_aux_rec, simp_all)
           qed
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by auto
           { assume "proper_interval ao (Some y)"
             hence "\<not> ?lhs \<sqsubseteq>' ?rhs" using x_Min y_Min \<open>x = y\<close>
               by -(erule proper_interval_not_set_less_eq_auxI, auto) }
           moreover
           { assume "\<not> ?lhs \<sqsubseteq>' ?rhs"
             also have "?rhs = set (y # ys) \<inter> above ao"
               using ao by auto
             finally obtain z where "z \<in> above ao" "z < y" 
               using \<open>x = y\<close> x_ao x_Min[unfolded Ball_def]
               by(fastforce simp add: set_less_eq_aux_def set_less_aux_def simp add: less_le not_le dest!: bspec[where x=y])
             hence "proper_interval ao (Some y)" 
               by(auto simp add: proper_interval_Some2) }
           ultimately show ?thesis using \<open>x = y\<close> by auto
         qed
       qed
     qed }
   from this[of None] show ?Compl1 by simp
 qed
 
 lemma set_less_aux_Compl_iff:
   "set_less_aux_Compl ao xs ys \<longleftrightarrow> set_less_eq_aux_Compl ao xs ys \<and> \<not> Compl_set_less_eq_aux ao ys xs"
 by(induct ao xs ys rule: set_less_aux_Compl.induct)(auto simp add: not_less_iff_gr_or_eq)
 
 lemma Compl_set_less_aux_Compl_iff:
   "Compl_set_less_aux ao xs ys \<longleftrightarrow> Compl_set_less_eq_aux ao xs ys \<and> \<not> set_less_eq_aux_Compl ao ys xs"
 by(induct ao xs ys rule: Compl_set_less_aux.induct)(auto simp add: not_less_iff_gr_or_eq)
 
 theorem assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs"
   and ys: "sorted ys" "distinct ys"
   shows set_less_aux_Compl2_conv_set_less_aux_Compl:
   "set xs \<sqsubset>' - set ys \<longleftrightarrow> set_less_aux_Compl None xs ys" (is ?Compl2)
   and Compl1_set_less_aux_conv_Compl_set_less_aux:
   "- set xs \<sqsubset>' set ys \<longleftrightarrow> Compl_set_less_aux None xs ys" (is ?Compl1)
 using assms
 by(simp_all only: set_less_aux_conv_set_less_eq_aux set_less_aux_Compl_iff Compl_set_less_aux_Compl_iff set_less_eq_aux_Compl2_conv_set_less_eq_aux_Compl Compl1_set_less_eq_aux_conv_Compl_set_less_eq_aux)
 
 end
 
 subsection \<open>Implementation of proper intervals for sets\<close>
 
 definition length_last :: "'a list \<Rightarrow> nat \<times> 'a"
 where "length_last xs = (length xs, last xs)"
 
 lemma length_last_Nil [code]: "length_last [] = (0, undefined)"
 by(simp add: length_last_def last_def)
 
 lemma length_last_Cons_code [symmetric, code]:
   "fold (\<lambda>x (n, _) . (n + 1, x)) xs (1, x) = length_last (x # xs)"
 by(induct xs rule: rev_induct)(simp_all add: length_last_def)
 
 context proper_intrvl begin
 
 fun exhaustive_above :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
   "exhaustive_above x [] \<longleftrightarrow> \<not> proper_interval (Some x) None"
 | "exhaustive_above x (y # ys) \<longleftrightarrow> \<not> proper_interval (Some x) (Some y) \<and> exhaustive_above y ys"
 
 fun exhaustive :: "'a list \<Rightarrow> bool" where 
   "exhaustive [] = False"
 | "exhaustive (x # xs) \<longleftrightarrow> \<not> proper_interval None (Some x) \<and> exhaustive_above x xs"
 
 fun proper_interval_set_aux :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_set_aux xs [] \<longleftrightarrow> False"
 | "proper_interval_set_aux [] (y # ys) \<longleftrightarrow> ys \<noteq> [] \<or> proper_interval (Some y) None"
 | "proper_interval_set_aux (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then False
    else if y < x then proper_interval (Some y) (Some x) \<or> ys \<noteq> [] \<or> \<not> exhaustive_above x xs
    else proper_interval_set_aux xs ys)"
 
 fun proper_interval_set_Compl_aux :: "'a option \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_set_Compl_aux ao n [] [] \<longleftrightarrow>
    CARD('a) > n + 1"
 | "proper_interval_set_Compl_aux ao n [] (y # ys) \<longleftrightarrow>
    (let m = CARD('a) - n; (len_y, y') = length_last (y # ys)
     in m \<noteq> len_y \<and> (m = len_y + 1 \<longrightarrow> \<not> proper_interval (Some y') None))"
 | "proper_interval_set_Compl_aux ao n (x # xs) [] \<longleftrightarrow>
    (let m = CARD('a) - n; (len_x, x') = length_last (x # xs)
     in m \<noteq> len_x \<and> (m = len_x + 1 \<longrightarrow> \<not> proper_interval (Some x') None))"
 | "proper_interval_set_Compl_aux ao n (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then 
      proper_interval ao (Some x) \<or> 
      proper_interval_set_Compl_aux (Some x) (n + 1) xs (y # ys)
    else if y < x then 
      proper_interval ao (Some y) \<or> 
      proper_interval_set_Compl_aux (Some y) (n + 1) (x # xs) ys
    else proper_interval ao (Some x) \<and> 
      (let m = card (UNIV :: 'a set) - n in m - length ys \<noteq> 2 \<or> m - length xs \<noteq> 2))"
 
 fun proper_interval_Compl_set_aux :: "'a option \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   "proper_interval_Compl_set_aux ao (x # xs) (y # ys) \<longleftrightarrow>
   (if x < y then 
      \<not> proper_interval ao (Some x) \<and> 
      proper_interval_Compl_set_aux (Some x) xs (y # ys)
    else if y < x then
      \<not> proper_interval ao (Some y) \<and>
      proper_interval_Compl_set_aux (Some y) (x # xs) ys
    else \<not> proper_interval ao (Some x) \<and> (ys = [] \<longrightarrow> xs \<noteq> []))"
 | "proper_interval_Compl_set_aux ao _ _ \<longleftrightarrow> False"
 
 end
 
 lemmas [code] = 
   proper_intrvl.exhaustive_above.simps
   proper_intrvl.exhaustive.simps
   proper_intrvl.proper_interval_set_aux.simps
   proper_intrvl.proper_interval_set_Compl_aux.simps
   proper_intrvl.proper_interval_Compl_set_aux.simps
 
 context linorder_proper_interval begin
 
 lemma exhaustive_above_iff:
   "\<lbrakk> sorted xs; distinct xs; \<forall>x'\<in>set xs. x < x' \<rbrakk> \<Longrightarrow> exhaustive_above x xs \<longleftrightarrow> set xs = {z. z > x}"
 proof(induction x xs rule: exhaustive_above.induct)
   case 1 thus ?case by(simp add: proper_interval_simps)
 next
   case (2 x y ys)
   from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
   have ys: "sorted ys" "distinct ys" and y: "\<forall>y'\<in>set ys. y < y'"
     by(auto simp add: less_le)
   hence "exhaustive_above y ys = (set ys = {z. y < z})" by(rule "2.IH")
   moreover from \<open>\<forall>y'\<in>set (y # ys). x < y'\<close> have "x < y" by simp
   ultimately show ?case using y 
     by(fastforce simp add: proper_interval_simps)
 qed
 
 lemma exhaustive_correct:
   assumes "sorted xs" "distinct xs"
   shows "exhaustive xs \<longleftrightarrow> set xs = UNIV"
 proof(cases xs)
   case Nil thus ?thesis by auto
 next
   case Cons
   show ?thesis using assms unfolding Cons exhaustive.simps
     apply(subst exhaustive_above_iff)
     apply(auto simp add: less_le proper_interval_simps not_less)
     by (metis List.set_simps(2) UNIV_I eq_iff set_ConsD)
 qed
 
 theorem proper_interval_set_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys"
   shows "proper_interval_set_aux xs ys \<longleftrightarrow> (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
   show ?thesis using xs ys
   proof(induction xs ys rule: proper_interval_set_aux.induct)
     case 1 thus ?case by simp
   next
     case (2 y ys)
     hence "\<forall>y'\<in>set ys. y < y'" by(auto simp add: less_le)
     thus ?case
       by(cases ys)(auto simp add: proper_interval_simps set_less_aux_singleton_iff intro: psubset_finite_imp_set_less_aux)
   next
     case (3 x xs y ys)
     from \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
     have xs: "sorted xs" "distinct xs" and x: "\<forall>x'\<in>set xs. x < x'"
       by(auto simp add: less_le)
     from \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
     have ys: "sorted ys" "distinct ys" and y: "\<forall>y'\<in>set ys. y < y'"
       by(auto simp add: less_le)
     have Minxxs: "Min (set (x # xs)) = x" and xnxs: "x \<notin> set xs"
       using x by(auto intro!: Min_eqI)
     have Minyys: "Min (set (y # ys)) = y" and ynys: "y \<notin> set ys" 
       using y by(auto intro!: Min_eqI)
     show ?case
     proof(cases "x < y")
       case True
       hence "set (y # ys) \<sqsubset>' set (x # xs)" using Minxxs Minyys
         by -(rule set_less_aux_Min_antimono, simp_all)
       thus ?thesis using True by(auto dest: set_less_aux_trans set_less_aux_antisym)
     next
       case False
       show ?thesis
       proof(cases "y < x")
         case True
         { assume "proper_interval (Some y) (Some x)"
           then obtain z where z: "y < z" "z < x" by(auto simp add: proper_interval_simps)
           hence "set (x # xs) \<sqsubset>' {z}" using x
             by -(rule set_less_aux_Min_antimono, auto)
           moreover have "{z} \<sqsubset>' set (y # ys)" using z y Minyys
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { assume "ys \<noteq> []"
           hence "{y} \<sqsubset>' set (y # ys)" using y
             by -(rule psubset_finite_imp_set_less_aux, auto simp add: neq_Nil_conv)
           moreover have "set (x # xs) \<sqsubset>' {y}" using False True x
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { assume "\<not> exhaustive_above x xs"
           then obtain z where z: "z > x" "z \<notin> set xs" using x
             by(auto simp add: exhaustive_above_iff[OF xs x])
           let ?A = "insert z (set (x # xs))"
           have "set (x # xs) \<sqsubset>' ?A" using z
             by -(rule psubset_finite_imp_set_less_aux, auto)
           moreover have "?A \<sqsubset>' set (y # ys)" using Minyys False True z x
             by -(rule set_less_aux_Min_antimono, auto)
           ultimately have "\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys)" by blast }
         moreover
         { fix A
           assume A: "set (x # xs) \<sqsubset>' A" and A': "A \<sqsubset>' {y}"
             and pi: "\<not> proper_interval (Some y) (Some x)"
           from A have nempty: "A \<noteq> {}" by auto
           have "y \<notin> A"
           proof
             assume "y \<in> A"
             moreover with A' have "A \<noteq> {y}" by auto
             ultimately have "{y} \<sqsubset>' A" by -(rule psubset_finite_imp_set_less_aux, auto)
             with A' show False by(rule set_less_aux_antisym)
           qed
           have "y < Min A" unfolding not_le[symmetric]
           proof
             assume "Min A \<le> y"
             moreover have "Min A \<noteq> y" using \<open>y \<notin> A\<close> nempty by clarsimp
             ultimately have "Min A < Min {y}" by simp
             hence "{y} \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' show False by(rule set_less_aux_antisym)
           qed
           with pi nempty have "x \<le> Min A" by(auto simp add: proper_interval_simps)
           moreover
           from A obtain z where z: "z \<in> A" "z \<notin> set (x # xs)"
             by(auto simp add: set_less_aux_def)
           with \<open>x \<le> Min A\<close> nempty have "x < z" by auto
           with z have "\<not> exhaustive_above x xs"
             by(auto simp add: exhaustive_above_iff[OF xs x]) }
         ultimately show ?thesis using True False by fastforce
       next
         case False
         with \<open>\<not> x < y\<close> have "x = y" by auto
         from \<open>\<not> x < y\<close> False
         have "proper_interval_set_aux xs ys = (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)" 
           using xs ys by(rule "3.IH")
         also have "\<dots> = (\<exists>A. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' set (y # ys))"
           (is "?lhs = ?rhs")
         proof
           assume ?lhs
           then obtain A where A: "set xs \<sqsubset>' A" 
             and A': "A \<sqsubset>' set ys" by blast
           hence nempty: "A \<noteq> {}" "ys \<noteq> []" by auto
           let ?A = "insert y A"
           { assume "Min A \<le> y"
             also from y nempty have "y < Min (set ys)" by auto
             finally have "set ys \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' have False by(rule set_less_aux_antisym) }
           hence MinA: "y < Min A" by(metis not_le)
           with nempty have "y \<notin> A" by auto
           moreover
           with MinA nempty have MinyA: "Min ?A = y" by -(rule Min_eqI, auto)
           ultimately have A1: "set (x # xs) \<sqsubset>' ?A" using \<open>x = y\<close> A Minxxs xnxs
             by(subst set_less_aux_rec) simp_all
           moreover
           have "?A \<sqsubset>' set (y # ys)" using \<open>x = y\<close> MinyA \<open>y \<notin> A\<close> A' Minyys ynys
             by(subst set_less_aux_rec) simp_all
           ultimately show ?rhs by blast
         next
           assume "?rhs"
           then obtain A where A: "set (x # xs) \<sqsubset>' A"
             and A': "A \<sqsubset>' set (y # ys)" by blast
           let ?A = "A - {x}"
           from A have nempty: "A \<noteq> {}" by auto
           { assume "x < Min A"
             hence "Min (set (x # xs)) < Min A" unfolding Minxxs .
             hence "A \<sqsubset>' set (x # xs)"
               by(rule set_less_aux_Min_antimono) simp_all
             with A have False by(rule set_less_aux_antisym) }
           moreover
           { assume "Min A < x"
             hence "Min A < Min (set (y # ys))" unfolding \<open>x = y\<close> Minyys .
             hence "set (y # ys) \<sqsubset>' A" by(rule set_less_aux_Min_antimono)(simp_all add: nempty)
             with A' have False by(rule set_less_aux_antisym) }
           ultimately have MinA: "Min A = x" by(metis less_linear)
           hence "x \<in> A" using nempty by(metis Min_in \<open>finite A\<close>)
           
           from A nempty Minxxs xnxs have "set xs \<sqsubset>' ?A"
             by(subst (asm) set_less_aux_rec)(auto simp add: MinA)
           moreover from A' \<open>x = y\<close> nempty Minyys MinA ynys have "?A \<sqsubset>' set ys"
             by(subst (asm) set_less_aux_rec) simp_all
           ultimately show ?lhs by blast
         qed
         finally show ?thesis using \<open>x = y\<close> by simp
       qed
     qed
   qed
 qed
 
 lemma proper_interval_set_Compl_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys" 
   shows "proper_interval_set_Compl_aux None 0 xs ys \<longleftrightarrow> (\<exists>A. set xs \<sqsubset>' A \<and> A \<sqsubset>' - set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao n
     assume "set xs \<subseteq> above ao" "set ys \<subseteq> above ao"
     from xs \<open>set xs \<subseteq> above ao\<close> ys \<open>set ys \<subseteq> above ao\<close>
     have "proper_interval_set_Compl_aux ao (card (UNIV - above ao)) xs ys \<longleftrightarrow>
           (\<exists>A \<subseteq> above ao. set xs \<sqsubset>' A \<and> A \<sqsubset>' - set ys \<inter> above ao)"
     proof(induct ao n\<equiv>"card (UNIV - above ao)" xs ys rule: proper_interval_set_Compl_aux.induct)
       case (1 ao)
       have "card (UNIV - above ao) + 1 < CARD('a) \<longleftrightarrow> (\<exists>A \<subseteq> above ao. A \<noteq> {} \<and> A \<sqsubset>' above ao)"
         (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence "card (UNIV - (UNIV - above ao)) > 1" by(simp add: card_Diff_subset)
         from card_gt_1D[OF this]
         obtain x y where above: "x \<in> above ao" "y \<in> above ao"
           and neq: "x \<noteq> y" by blast
         hence "{x} \<sqsubset>' {x, y} \<inter> above ao"
           by(simp_all add: psubsetI psubset_finite_imp_set_less_aux)
         also have "\<dots> \<sqsubseteq>' above ao"
           by(auto intro: subset_finite_imp_set_less_eq_aux)
         finally show ?rhs using above by blast
       next
         assume ?rhs
         then obtain A where nempty: "A \<inter> above ao \<noteq> {}"
           and subset: "A \<subseteq> above ao"
           and less: "A \<sqsubset>' above ao" by blast
         from nempty obtain x where x: "x \<in> A" "x \<in> above ao" by blast
         show ?lhs
         proof(rule ccontr)
           assume "\<not> ?lhs"
           moreover have "CARD('a) \<ge> card (UNIV - above ao)" by(rule card_mono) simp_all
           moreover from card_Un_disjoint[of "UNIV - above ao" "above ao"]
           have "CARD('a) = card (UNIV - above ao) + card (above ao)" by auto
           ultimately have "card (above ao) = 1" using x
             by(cases "card (above ao)")(auto simp add: not_less_eq less_Suc_eq_le)
           with x have "above ao = {x}" unfolding card_eq_1_iff by auto
           moreover with x subset have A: "A = {x}" by auto
           ultimately show False using less by simp
         qed
       qed
       thus ?case by simp
     next
       case (2 ao y ys)
       note ys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close> \<open>set (y # ys) \<subseteq> above ao\<close>
       have len_ys: "length ys = card (set ys)"
         using ys by(auto simp add: List.card_set intro: sym)
 
       define m where "m = CARD('a) - card (UNIV - above ao)"
       have "CARD('a) = card (above ao) + card (UNIV - above ao)"
         using card_Un_disjoint[of "above ao" "UNIV - above ao"] by auto
       hence m_eq: "m = card (above ao)" unfolding m_def by simp
         
       have "m \<noteq> length ys + 1 \<and> (m = length ys + 2 \<longrightarrow> \<not> proper_interval (Some (last (y # ys))) None) \<longleftrightarrow>
         (\<exists>A \<subseteq> above ao. A \<noteq> {} \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)" (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence m: "m \<noteq> length ys + 1"
           and pi: "m = length ys + 2 \<Longrightarrow> \<not> proper_interval (Some (last (y # ys))) None"
           by simp_all
         have "length ys + 1 = card (set (y # ys))" using ys len_ys by simp
         also have "\<dots> \<le> m" unfolding m_eq by(rule card_mono)(simp, rule ys)
         finally have "length ys + 2 \<le> m" using m by simp
         show ?rhs
         proof(cases "m = length ys + 2")
           case True
           hence "card (UNIV - (UNIV - above ao) - set (y # ys)) = 1"
             using ys len_ys
             by(subst card_Diff_subset)(auto simp add: m_def card_Diff_subset)
           then obtain z where z: "z \<in> above ao" "z \<noteq> y" "z \<notin> set ys"
             unfolding card_eq_1_iff by auto
           from True have "\<not> proper_interval (Some (last (y # ys))) None" by(rule pi)
           hence "z \<le> last (y # ys)" by(simp add: proper_interval_simps not_less del: last.simps)
           moreover have ly: "last (y # ys) \<in> set (y # ys)" by(rule last_in_set) simp
           with z have "z \<noteq> last (y # ys)" by auto
           ultimately have "z < last (y # ys)" by simp
           hence "{last (y # ys)} \<sqsubset>' {z}"
             using z ly ys by(auto 4 3 simp add: set_less_aux_def)
           also have "\<dots> \<sqsubseteq>' - set (y # ys) \<inter> above ao"
             using z by(auto intro: subset_finite_imp_set_less_eq_aux)
           also have "{last (y # ys)} \<noteq> {}" using ly ys by blast
           moreover have "{last (y # ys)} \<subseteq> above ao" using ys by auto
           ultimately show ?thesis by blast
         next
           case False
           with \<open>length ys + 2 \<le> m\<close> ys len_ys
           have "card (UNIV - (UNIV - above ao) - set (y # ys)) > 1"
             by(subst card_Diff_subset)(auto simp add: card_Diff_subset m_def)
           from card_gt_1D[OF this]
           obtain x x' where x: "x \<in> above ao" "x \<noteq> y" "x \<notin> set ys"
             and x': "x' \<in> above ao" "x' \<noteq> y" "x' \<notin> set ys"
             and neq: "x \<noteq> x'" by auto
           hence "{x} \<sqsubset>' {x, x'} \<inter> above ao"
             by(simp_all add: psubsetI psubset_finite_imp_set_less_aux)
           also have "\<dots> \<sqsubseteq>' - set (y # ys) \<inter> above ao" using x x' ys
             by(auto intro: subset_finite_imp_set_less_eq_aux)
           also have "{x} \<inter> above ao \<noteq> {}" using x by simp
           ultimately show ?rhs by blast
         qed
       next
         assume ?rhs
         then obtain A where nempty: "A \<noteq> {}"
           and less: "A \<sqsubset>' - set (y # ys) \<inter> above ao"
           and subset: "A \<subseteq> above ao" by blast
         have "card (set (y # ys)) \<le> card (above ao)" using ys(3) by(simp add: card_mono)
         hence "length ys + 1 \<le> m" unfolding m_eq using ys by(simp add: len_ys)
         have "m \<noteq> length ys + 1"
         proof
           assume "m = length ys + 1"
           hence "card (above ao) \<le> card (set (y # ys))"
             unfolding m_eq using ys len_ys by auto
           from card_seteq[OF _ _ this] ys have "set (y # ys) = above ao" by simp
           with nempty less show False by(auto simp add: set_less_aux_def)
         qed
         moreover
         { assume "m = length ys + 2"
           hence "card (above ao - set (y # ys)) = 1"
             using ys len_ys m_eq by(auto simp add: card_Diff_subset)
           then obtain z where z: "above ao - set (y # ys) = {z}"
             unfolding card_eq_1_iff ..
           hence eq_z: "- set (y # ys) \<inter> above ao = {z}" by auto
           with less have "A \<sqsubset>' {z}" by simp
           have "\<not> proper_interval (Some (last (y # ys))) None"
           proof
             assume "proper_interval (Some (last (y # ys))) None"
             then obtain z' where z': "last (y # ys) < z'"
               by(clarsimp simp add: proper_interval_simps)
             have "last (y # ys) \<in> set (y # ys)" by(rule last_in_set) simp
             with ys z' have "z' \<in> above ao" "z' \<notin> set (y # ys)"
               by(auto simp del: last.simps sorted.simps(2) intro: above_upclosed dest: sorted_last)
             with eq_z have "z = z'" by fastforce
             from z' have "\<And>x. x \<in> set (y # ys) \<Longrightarrow> x < z'" using ys
               by(auto dest: sorted_last simp del: sorted.simps(2))
             with eq_z \<open>z = z'\<close>
             have "\<And>x. x \<in> above ao \<Longrightarrow> x \<le> z'" by(fastforce)
             with \<open>A \<sqsubset>' {z}\<close> nempty \<open>z = z'\<close> subset
             show False by(auto simp add: set_less_aux_def)
           qed }
         ultimately show ?lhs by simp
       qed
       thus ?case by(simp add: length_last_def m_def Let_def)
     next
       case (3 ao x xs)
       note xs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close> \<open>set (x # xs) \<subseteq> above ao\<close>
       have len_xs: "length xs = card (set xs)"
         using xs by(auto simp add: List.card_set intro: sym)
       
       define m where "m = CARD('a) - card (UNIV - above ao)"
       have "CARD('a) = card (above ao) + card (UNIV - above ao)"
         using card_Un_disjoint[of "above ao" "UNIV - above ao"] by auto
       hence m_eq: "m = card (above ao)" unfolding m_def by simp
       have "m \<noteq> length xs + 1 \<and> (m = length xs + 2 \<longrightarrow> \<not> proper_interval (Some (last (x # xs))) None) \<longleftrightarrow>
         (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' above ao)" (is "?lhs \<longleftrightarrow> ?rhs")
       proof
         assume ?lhs
         hence m: "m \<noteq> length xs + 1"
           and pi: "m = length xs + 2 \<Longrightarrow> \<not> proper_interval (Some (last (x # xs))) None"
           by simp_all
         have "length xs + 1 = card (set (x # xs))" using xs len_xs by simp
         also have "\<dots> \<le> m" unfolding m_eq by(rule card_mono)(simp, rule xs)
         finally have "length xs + 2 \<le> m" using m by simp
         show ?rhs
         proof(cases "m = length xs + 2")
           case True
           hence "card (UNIV - (UNIV - above ao) - set (x # xs)) = 1"
             using xs len_xs
             by(subst card_Diff_subset)(auto simp add: m_def card_Diff_subset)
           then obtain z where z: "z \<in> above ao" "z \<noteq> x" "z \<notin> set xs"
             unfolding card_eq_1_iff by auto
           define A where "A = insert z {y. y \<in> set (x # xs) \<and> y < z}"
 
           from True have "\<not> proper_interval (Some (last (x # xs))) None" by(rule pi)
           hence "z \<le> last (x # xs)" by(simp add: proper_interval_simps not_less del: last.simps)
           moreover have lx: "last (x # xs) \<in> set (x # xs)" by(rule last_in_set) simp
           with z have "z \<noteq> last (x # xs)" by auto
           ultimately have "z < last (x # xs)" by simp
           hence "set (x # xs) \<sqsubset>' A" 
             using z xs by(auto simp add: A_def set_less_aux_def intro: rev_bexI[where x=z])
           moreover have "last (x # xs) \<notin> A" using xs \<open>z < last (x # xs)\<close>
             by(auto simp add: A_def simp del: last.simps)
           hence "A \<subset> insert (last (x # xs)) A" by blast
           hence less': "A \<sqsubset>' insert (last (x # xs)) A"
             by(rule psubset_finite_imp_set_less_aux) simp
           have "\<dots> \<subseteq> above ao" using xs lx z
             by(auto simp del: last.simps simp add: A_def)
           hence "insert (last (x # xs)) A \<sqsubseteq>' above ao"
             by(auto intro: subset_finite_imp_set_less_eq_aux)
           with less' have "A \<sqsubset>' above ao"
             by(rule set_less_trans_set_less_eq)
           moreover have "A \<subseteq> above ao" using xs z by(auto simp add: A_def)
           ultimately show ?thesis by blast
         next
           case False
           with \<open>length xs + 2 \<le> m\<close> xs len_xs
           have "card (UNIV - (UNIV - above ao) - set (x # xs)) > 1"
             by(subst card_Diff_subset)(auto simp add: card_Diff_subset m_def)
           from card_gt_1D[OF this]
           obtain y y' where y: "y \<in> above ao" "y \<noteq> x" "y \<notin> set xs"
             and y': "y' \<in> above ao" "y' \<noteq> x" "y' \<notin> set xs"
             and neq: "y \<noteq> y'" by auto
           define A where "A = insert y (set (x # xs) \<inter> above ao)"
           hence "set (x # xs) \<subset> A" using y xs by auto
           hence "set (x # xs) \<sqsubset>' \<dots>"
             by(fastforce intro: psubset_finite_imp_set_less_aux)
           moreover have *: "\<dots> \<subset> above ao"
             using y y' neq by(auto simp add: A_def)
           moreover from * have "A \<sqsubset>' above ao"
             by(auto intro: psubset_finite_imp_set_less_aux)
           ultimately show ?thesis by blast
         qed
       next
         assume ?rhs
         then obtain A where lessA: "set (x # xs) \<sqsubset>' A"
           and Aless: "A \<sqsubset>' above ao" and subset: "A \<subseteq> above ao" by blast
         have "card (set (x # xs)) \<le> card (above ao)" using xs(3) by(simp add: card_mono)
         hence "length xs + 1 \<le> m" unfolding m_eq using xs by(simp add: len_xs)
         have "m \<noteq> length xs + 1"
         proof
           assume "m = length xs + 1"
           hence "card (above ao) \<le> card (set (x # xs))"
             unfolding m_eq using xs len_xs by auto
           from card_seteq[OF _ _ this] xs have "set (x # xs) = above ao" by simp
           with lessA Aless show False by(auto dest: set_less_aux_antisym)
         qed
         moreover
         { assume "m = length xs + 2"
           hence "card (above ao - set (x # xs)) = 1"
             using xs len_xs m_eq by(auto simp add: card_Diff_subset)
           then obtain z where z: "above ao - set (x # xs) = {z}"
             unfolding card_eq_1_iff ..
           have "\<not> proper_interval (Some (last (x # xs))) None"
           proof
             assume "proper_interval (Some (last (x # xs))) None"
             then obtain z' where z': "last (x # xs) < z'"
               by(clarsimp simp add: proper_interval_simps)
             have "last (x # xs) \<in> set (x # xs)" by(rule last_in_set) simp
             with xs z' have "z' \<in> above ao" "z' \<notin> set (x # xs)"
               by(auto simp del: last.simps sorted.simps(2) intro: above_upclosed dest: sorted_last)
             with z have "z = z'" by fastforce
             from z' have y_less: "\<And>y. y \<in> set (x # xs) \<Longrightarrow> y < z'" using xs
               by(auto simp del: sorted.simps(2) dest: sorted_last)
             with z \<open>z = z'\<close> have "\<And>y. y \<in> above ao \<Longrightarrow> y \<le> z'" by(fastforce)
             
             from lessA subset obtain y where y: "y \<in> A" "y \<in> above ao" "y \<notin> set (x # xs)"
               and min: "\<And>y'. \<lbrakk> y' \<in> set (x # xs); y' \<in> above ao; y' \<notin> A \<rbrakk> \<Longrightarrow> y \<le> y'"
               by(auto simp add: set_less_aux_def)
             with z \<open>z = z'\<close> have "y = z'" by auto
             have "set (x # xs) \<subseteq> A"
             proof
               fix y'
               assume y': "y' \<in> set (x # xs)"
               show "y' \<in> A"
               proof(rule ccontr)
                 assume "y' \<notin> A"
                 from y' xs have "y' \<in> above ao" by auto
                 with y' have "y \<le> y'" using \<open>y' \<notin> A\<close> by(rule min)
                 moreover from y' have "y' < z'" by(rule y_less)
                 ultimately show False using \<open>y = z'\<close> by simp
               qed
             qed
             moreover from z xs have "above ao = insert z (set (x # xs))" by auto
             ultimately have "A = above ao" using y \<open>y = z'\<close> \<open>z = z'\<close> subset by auto
             with Aless show False by simp
           qed }
         ultimately show ?lhs by simp
       qed
       thus ?case by(simp add: length_last_def m_def Let_def del: last.simps)
     next
       case (4 ao x xs y ys)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
         and yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
         and xxs_above = \<open>set (x # xs) \<subseteq> above ao\<close>
         and yys_above = \<open>set (y # ys) \<subseteq> above ao\<close>
       from xxs have xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x'\<in>set xs. x < x'"
         by(auto simp add: less_le)
       from yys have ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
 
       have len_xs: "length xs = card (set xs)"
         using xs by(auto simp add: List.card_set intro: sym)
       have len_ys: "length ys = card (set ys)"
         using ys by(auto simp add: List.card_set intro: sym)
 
       show ?case
       proof(cases "x < y")
         case True
 
         have "proper_interval ao (Some x) \<or>
           proper_interval_set_Compl_aux (Some x) (card (UNIV - above ao) + 1) xs (y # ys) \<longleftrightarrow>
           (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
           (is "?lhs \<longleftrightarrow> ?rhs")
         proof(cases "proper_interval ao (Some x)")
           case True
           then obtain z where z: "z \<in> above ao" "z < x"
             by(clarsimp simp add: proper_interval_Some2)
           moreover with xxs have "\<forall>x'\<in>set xs. z < x'" by(auto)
           ultimately have "set (x # xs) \<sqsubset>' {z}"
             by(auto simp add: set_less_aux_def intro!: bexI[where x=z])
           moreover {
             from z yys \<open>x < y\<close> have "z < y" "\<forall>y'\<in>set ys. z < y'"
               by(auto)
             hence subset: "{z} \<subseteq> - set (y # ys) \<inter> above ao"
               using ys \<open>x < y\<close> z by auto
             moreover have "x \<in> \<dots>" using yys xxs \<open>x < y\<close> xxs_above by(auto)
             ultimately have "{z} \<subset> \<dots>" using \<open>z < x\<close> by fastforce
             hence "{z} \<sqsubset>' \<dots>"
               by(fastforce intro: psubset_finite_imp_set_less_aux) }
           moreover have "{z} \<subseteq> above ao" using z by simp
           ultimately have ?rhs by blast
           thus ?thesis using True by simp
         next
           case False
           hence above_eq: "above ao = insert x (above (Some x))" using xxs_above
             by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           moreover have "card (above (Some x)) < CARD('a)"
             by(rule psubset_card_mono)(auto)
           ultimately have card_eq: "card (UNIV - above ao) + 1 = card (UNIV - above (Some x))"
             by(simp add: card_Diff_subset)
           from xxs_above x_Min have xs_above: "set xs \<subseteq> above (Some x)" by(auto)
           from \<open>x < y\<close> y_Min have "set (y # ys) \<subseteq> above (Some x)" by(auto)
           with \<open>x < y\<close> card_eq xs xs_above yys
           have "proper_interval_set_Compl_aux (Some x) (card (UNIV - above ao) + 1) xs (y # ys) \<longleftrightarrow>
                (\<exists>A \<subseteq> above (Some x). set xs \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above (Some x))"
             by(subst card_eq)(rule 4)
           also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
           proof
             assume ?lhs'
             then obtain A where less_A: "set xs \<sqsubset>' A"
               and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above (Some x)"
               and subset: "A \<subseteq> above (Some x)" by blast
             let ?A = "insert x A"
 
             have Min_A': "Min ?A = x" using xxs_above False subset
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "Min (set (x # xs)) = x"
               using x_Min by(auto intro!: Min_eqI)
             moreover have Amx: "A - {x} = A"
               using False subset 
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             moreover have "set xs - {x} = set xs" using x_Min by auto
             ultimately have less_A': "set (x # xs) \<sqsubset>' ?A"
               using less_A xxs_above x_Min by(subst set_less_aux_rec) simp_all
             
             have "x \<in> - insert y (set ys) \<inter> above ao"
               using \<open>x < y\<close> xxs_above y_Min by auto
             hence "- insert y (set ys) \<inter> above ao \<noteq> {}" by auto
             moreover have "Min (- insert y (set ys) \<inter> above ao) = x"
               using yys y_Min xxs_above \<open>x < y\<close> False
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "- set (y # ys) \<inter> above ao - {x} = - set (y # ys) \<inter> above (Some x)"
               using yys_above False xxs_above
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             ultimately have A'_less: "?A \<sqsubset>' - set (y # ys) \<inter> above ao"
               using Min_A' A_less Amx xxs_above by(subst set_less_aux_rec) simp_all
             moreover have "?A \<subseteq> above ao" using subset xxs_above by(auto intro: above_upclosed)
             ultimately show ?rhs using less_A' by blast
           next
             assume ?rhs
             then obtain A where less_A: "set (x # xs) \<sqsubset>' A"
               and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao" 
               and subset: "A \<subseteq> above ao" by blast
             let ?A = "A - {x}"
 
             from less_A subset xxs_above have "set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
               by(simp add: Int_absorb2)
             with False xxs_above subset have "x \<in> A"
               by(auto simp add: set_less_aux_def proper_interval_Some2)
             hence "\<dots> \<noteq> {}" by auto
             moreover from \<open>x \<in> A\<close> False subset
             have Min_A: "Min A = x"
               by(auto intro!: Min_eqI simp add: proper_interval_Some2 not_less)
             moreover have "Min (set (x # xs)) = x"
               using x_Min by(auto intro!: Min_eqI)
             moreover have eq_A: "?A \<subseteq> above (Some x)"
               using xxs_above False subset 
               by(fastforce simp add: proper_interval_Some2 not_less intro: above_upclosed)
             moreover have "set xs - {x} = set xs"
               using x_Min by(auto)
             ultimately have less_A': "set xs \<sqsubset>' ?A"
               using xxs_above less_A by(subst (asm) set_less_aux_rec)(simp_all cong: conj_cong)
             
             have "x \<in> - insert y (set ys) \<inter> above ao"
               using \<open>x < y\<close> xxs_above y_Min by auto
             hence "- insert y (set ys) \<inter> above ao \<noteq> {}" by auto
             moreover have "Min (- set (y # ys) \<inter> above ao) = x"
               using yys y_Min xxs_above \<open>x < y\<close> False
               by(auto intro!: Min_eqI simp add: proper_interval_Some2)
             moreover have "- set (y # ys) \<inter> above (Some x) = - set (y # ys) \<inter> above ao - {x}"
               by(auto simp add: above_eq)
             ultimately have "?A \<sqsubset>' - set (y # ys) \<inter> above (Some x)"
               using A_less \<open>A \<noteq> {}\<close> eq_A Min_A
               by(subst (asm) set_less_aux_rec) simp_all
             
             with less_A' eq_A show ?lhs' by blast
           qed
           finally show ?thesis using False by simp
         qed
         thus ?thesis using True by simp
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           have "proper_interval ao (Some y) \<or> 
                 proper_interval_set_Compl_aux (Some y) (card (UNIV - above ao) + 1) (x # xs) ys \<longleftrightarrow>
                (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
             (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some y)")
             case True
             then obtain z where z: "z \<in> above ao" "z < y"
               by(clarsimp simp add: proper_interval_Some2)
             from xxs \<open>y < x\<close> have "\<forall>x'\<in>set (x # xs). y < x'" by(auto)
             hence less_A: "set (x # xs) \<sqsubset>' {y}" 
               by(auto simp add: set_less_aux_def intro!: bexI[where x=y])
 
             have "{y} \<sqsubset>' {z}"
               using z y_Min by(auto simp add: set_less_aux_def intro: bexI[where x=z])
             also have "\<dots> \<subseteq> - set (y # ys) \<inter> above ao" using z y_Min by auto
             hence "{z} \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
             finally have "{y} \<sqsubset>' \<dots>" .
             moreover have "{y} \<subseteq> above ao" using yys_above by auto
             ultimately have ?rhs using less_A by blast
             thus ?thesis using True by simp
           next
             case False
             hence above_eq: "above ao = insert y (above (Some y))" using yys_above
               by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             moreover have "card (above (Some y)) < CARD('a)"
               by(rule psubset_card_mono)(auto)
             ultimately have card_eq: "card (UNIV - above ao) + 1 = card (UNIV - above (Some y))"
               by(simp add: card_Diff_subset)
             from yys_above y_Min have ys_above: "set ys \<subseteq> above (Some y)" by(auto)
 
             have eq_ys: "- set ys \<inter> above (Some y) = - set (y # ys) \<inter> above ao"
               by(auto simp add: above_eq)
 
             from \<open>y < x\<close> x_Min have "set (x # xs) \<subseteq> above (Some y)" by(auto)
             with \<open>\<not> x < y\<close> \<open>y < x\<close> card_eq xxs ys ys_above
             have "proper_interval_set_Compl_aux (Some y) (card (UNIV - above ao) + 1) (x # xs) ys \<longleftrightarrow>
               (\<exists>A \<subseteq> above (Some y). set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set ys \<inter> above (Some y))"
               by(subst card_eq)(rule 4)
             also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof
               assume ?lhs'
               then obtain A where "set (x # xs) \<sqsubset>' A" and subset: "A \<subseteq> above (Some y)"
                 and "A \<sqsubset>' - set ys \<inter> above (Some y)" by blast
               moreover from subset have "A - {y} = A" by auto
               ultimately have "set (x # xs) \<sqsubset>' A - {y}"
                 and "A - {y} \<sqsubset>' - set (y # ys) \<inter> above ao"
                 using eq_ys by simp_all
               moreover from subset have "A - {y} \<subseteq> above ao"
                 using yys_above by(auto intro: above_upclosed)
               ultimately show ?rhs by blast
             next
               assume ?rhs
               then obtain A where "set (x # xs) \<sqsubset>' A" 
                 and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao" 
                 and subset: "A \<subseteq> above ao" by blast
               moreover
               from A_less False yys_above have "y \<notin> A"
                 by(auto simp add: set_less_aux_def proper_interval_Some2 not_less)
               ultimately have "set (x # xs) \<sqsubset>' A"
                 and "A \<sqsubset>' - set ys \<inter> above (Some y)"
                 using eq_ys by simp_all
               moreover from \<open>y \<notin> A\<close> subset above_eq have "A \<subseteq> above (Some y)" by auto
               ultimately show ?lhs' by blast
             qed
             finally show ?thesis using False by simp
           qed
           with False True show ?thesis by simp
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by simp
           have "proper_interval ao (Some x) \<and> 
                 (CARD('a) - (card (UNIV - above ao) + length ys) \<noteq> 2 \<or>
                  CARD('a) - (card (UNIV - above ao) + length xs) \<noteq> 2) \<longleftrightarrow>
                (\<exists>A \<subseteq> above ao. set (x # xs) \<sqsubset>' A \<and> A \<sqsubset>' - set (y # ys) \<inter> above ao)"
             (is "?below \<and> ?card \<longleftrightarrow> ?rhs")
           proof(cases "?below")
             case False
             hence "- set (y # ys) \<inter> above ao \<sqsubset>' set (x # xs)"
               using \<open>x = y\<close> yys_above xxs_above y_Min
               by(auto simp add: not_less set_less_aux_def proper_interval_Some2 intro!: bexI[where x=y])
             with False show ?thesis by(auto dest: set_less_aux_trans)
           next
             case True
             then obtain z where z: "z \<in> above ao" "z < x"
               by(clarsimp simp add: proper_interval_Some2)
 
             have "?card \<longleftrightarrow> ?rhs"
             proof
               assume ?rhs
               then obtain A where less_A: "set (x # xs)  \<sqsubset>' A"
                 and A_less: "A \<sqsubset>' - set (y # ys) \<inter> above ao"
                 and subset: "A \<subseteq> above ao" by blast
 
               { 
                 assume c_ys: "CARD('a) - (card (UNIV - above ao) + length ys) = 2"
                   and c_xs: "CARD('a) - (card (UNIV - above ao) + length xs) = 2"
                 from c_ys yys_above len_ys y_Min have "card (UNIV - (UNIV - above ao) - set (y # ys)) = 1"
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 then obtain z' where eq_y: "- set (y # ys) \<inter> above ao = {z'}"
                   unfolding card_eq_1_iff by auto
                 moreover from z have "z \<notin> set (y # ys)" using \<open>x = y\<close> y_Min by auto
                 ultimately have "z' = z" using z by fastforce
                 
                 from c_xs xxs_above len_xs x_Min have "card (UNIV - (UNIV - above ao) - set (x # xs)) = 1"
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 then obtain z'' where eq_x: "- set (x # xs) \<inter> above ao = {z''}"
                   unfolding card_eq_1_iff by auto
                 moreover from z have "z \<notin> set (x # xs)" using x_Min by auto
                 ultimately have "z'' = z" using z by fastforce
 
                 from less_A subset obtain q where "q \<in> A" "q \<in> above ao" "q \<notin> set (x # xs)"
                   by(auto simp add: set_less_aux_def)
                 hence "q \<in> {z''}" unfolding eq_x[symmetric] by simp
                 hence "q = z''" by simp
                 with \<open>q \<in> A\<close> \<open>z' = z\<close> \<open>z'' = z\<close> z 
                 have "- set (y # ys) \<inter> above ao \<subseteq> A"
                   unfolding eq_y by simp
                 hence "- set (y # ys) \<inter> above ao \<sqsubseteq>' A"
                   by(auto intro: subset_finite_imp_set_less_eq_aux)
                 with A_less have False by(auto dest: set_less_trans_set_less_eq) }
               thus ?card by auto
             next
               assume ?card (is "?card_ys \<or> ?card_xs")
               thus ?rhs
               proof
                 assume ?card_ys
                 let ?YS = "UNIV - (UNIV - above ao) - set (y # ys)"
                 from \<open>?card_ys\<close> yys_above len_ys y_Min have "card ?YS \<noteq> 1" 
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 moreover have "?YS \<noteq> {}" using True y_Min yys_above \<open>x = y\<close>
                   by(fastforce simp add: proper_interval_Some2)
                 hence "card ?YS \<noteq> 0" by simp
                 ultimately have "card ?YS > 1" by(cases "card ?YS") simp_all
                 from card_gt_1D[OF this] obtain x' y' 
                   where x': "x' \<in> above ao" "x' \<notin> set (y # ys)"
                   and y': "y' \<in> above ao" "y' \<notin> set (y # ys)"
                   and neq: "x' \<noteq> y'" by auto
                 let ?A = "{z}"
                 have "set (x # xs) \<sqsubset>' ?A" using z x_Min
                   by(auto simp add: set_less_aux_def intro!: rev_bexI)
                 moreover
                 { have "?A \<subseteq> - set (y # ys) \<inter> above ao"
                     using z \<open>x = y\<close> y_Min by(auto)
                   moreover have "x' \<notin> ?A \<or> y' \<notin> ?A" using neq by auto
                   with x' y' have "?A \<noteq> - set (y # ys) \<inter> above ao" by auto
                   ultimately have "?A \<subset> - set (y # ys) \<inter> above ao" by(rule psubsetI)
                   hence "?A \<sqsubset>' \<dots>" by(fastforce intro: psubset_finite_imp_set_less_aux) } 
                 ultimately show ?thesis using z by blast
               next
                 assume ?card_xs
                 let ?XS = "UNIV - (UNIV - above ao) - set (x # xs)"
                 from \<open>?card_xs\<close> xxs_above len_xs x_Min have "card ?XS \<noteq> 1" 
                   by(subst card_Diff_subset)(auto simp add: card_Diff_subset)
                 moreover have "?XS \<noteq> {}" using True x_Min xxs_above
                   by(fastforce simp add: proper_interval_Some2)
                 hence "card ?XS \<noteq> 0" by simp
                 ultimately have "card ?XS > 1" by(cases "card ?XS") simp_all
                 from card_gt_1D[OF this] obtain x' y' 
                   where x': "x' \<in> above ao" "x' \<notin> set (x # xs)"
                   and y': "y' \<in> above ao" "y' \<notin> set (x # xs)"
                   and neq: "x' \<noteq> y'" by auto
 
                 define A
                   where "A = (if x' = Min (above ao) then insert y' (set (x # xs)) else insert x' (set (x # xs)))"
                 hence "set (x # xs) \<subseteq> A" by auto
                 moreover have "set (x # xs) \<noteq> \<dots>"
                   using neq x' y' by(auto simp add: A_def)
                 ultimately have "set (x # xs) \<subset> A" ..
                 hence "set (x # xs) \<sqsubset>' \<dots>"
                   by(fastforce intro: psubset_finite_imp_set_less_aux)
                 moreover {
                   have nempty: "above ao \<noteq> {}" using z by auto
                   have "A \<sqsubset>' {Min (above ao)}" 
                     using z x' y' neq \<open>x = y\<close> x_Min xxs_above
                     by(auto 6 4 simp add: set_less_aux_def A_def nempty intro!: rev_bexI Min_eqI)
                   also have "Min (above ao) \<le> z" using z by(simp)
                   hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
                   with \<open>x = y\<close> y_Min have "Min (above ao) \<notin> set (y # ys)" by auto
                   hence "{Min (above ao)} \<subseteq> - set (y # ys) \<inter> above ao"
                     by(auto simp add: nempty)
                   hence "{Min (above ao)} \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
                   finally have "A \<sqsubset>' \<dots>" . }
                 moreover have "A \<subseteq> above ao" using xxs_above yys_above x' y' 
                   by(auto simp add: A_def)
                 ultimately show ?rhs by blast
               qed
             qed
             thus ?thesis using True by simp
           qed            
           thus ?thesis using \<open>x = y\<close> by simp
         qed
       qed
     qed }
   from this[of None]
   show ?thesis by(simp)
 qed
 
 lemma proper_interval_Compl_set_aux:
   assumes fin: "finite (UNIV :: 'a set)"
   and xs: "sorted xs" "distinct xs" 
   and ys: "sorted ys" "distinct ys" 
   shows "proper_interval_Compl_set_aux None xs ys \<longleftrightarrow> (\<exists>A. - set xs \<sqsubset>' A \<and> A \<sqsubset>' set ys)"
 proof -
   note [simp] = finite_subset[OF subset_UNIV fin]
 
   define above where "above = case_option UNIV (Collect \<circ> less)"
   have above_simps [simp]: "above None = UNIV" "\<And>x. above (Some x) = {y. x < y}"
     and above_upclosed: "\<And>x y ao. \<lbrakk> x \<in> above ao; x < y \<rbrakk> \<Longrightarrow> y \<in> above ao"
     and proper_interval_Some2: "\<And>x ao. proper_interval ao (Some x) \<longleftrightarrow> (\<exists>z\<in>above ao. z < x)"
     by(simp_all add: proper_interval_simps above_def split: option.splits)
 
   { fix ao n
     assume "set xs \<subseteq> above ao" "set ys \<subseteq> above ao"
     from xs \<open>set xs \<subseteq> above ao\<close> ys \<open>set ys \<subseteq> above ao\<close>
     have "proper_interval_Compl_set_aux ao xs ys \<longleftrightarrow>
           (\<exists>A. - set xs \<inter> above ao \<sqsubset>' A \<inter> above ao \<and> A \<inter> above ao \<sqsubset>' set ys \<inter> above ao)"
     proof(induction ao xs ys rule: proper_interval_Compl_set_aux.induct)
       case ("2_1" ao ys)
       { fix A
         assume "above ao \<sqsubset>' A \<inter> above ao"
         also have "\<dots> \<subseteq> above ao" by simp
         hence "A \<inter> above ao \<sqsubseteq>' above ao"
           by(auto intro: subset_finite_imp_set_less_eq_aux)
         finally have False by simp }
       thus ?case by auto
     next
       case ("2_2" ao xs) thus ?case by simp
     next
       case (1 ao x xs y ys)
       note xxs = \<open>sorted (x # xs)\<close> \<open>distinct (x # xs)\<close>
       hence xs: "sorted xs" "distinct xs" and x_Min: "\<forall>x' \<in> set xs. x < x'"
         by(auto simp add: less_le)
       note yys = \<open>sorted (y # ys)\<close> \<open>distinct (y # ys)\<close>
       hence ys: "sorted ys" "distinct ys" and y_Min: "\<forall>y'\<in>set ys. y < y'"
         by(auto simp add: less_le)
       note xxs_above = \<open>set (x # xs) \<subseteq> above ao\<close>
       note yys_above = \<open>set (y # ys) \<subseteq> above ao\<close>
 
       show ?case
       proof(cases "x < y")
         case True
         have "\<not> proper_interval ao (Some x) \<and> proper_interval_Compl_set_aux (Some x) xs (y # ys) \<longleftrightarrow>
               (\<exists>A. - set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao \<and> A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao)"
           (is "?lhs \<longleftrightarrow> ?rhs")
         proof(cases "proper_interval ao (Some x)")
           case True
           then obtain z where z: "z < x" "z \<in> above ao"
             by(auto simp add: proper_interval_Some2)
           hence nempty: "above ao \<noteq> {}" by auto
           with z have "Min (above ao) \<le> z" by auto
           hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
           hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
             using y_Min x_Min z \<open>x < y\<close>
             by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
           thus ?thesis using True by(auto dest: set_less_aux_trans set_less_aux_antisym)
         next
           case False
           hence above_eq: "above ao = insert x (above (Some x))"
             using xxs_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
           from x_Min have xs_above: "set xs \<subseteq> above (Some x)" by auto
           from \<open>x < y\<close> y_Min have ys_above: "set (y # ys) \<subseteq> above (Some x)" by auto
 
           have eq_xs: "- set xs \<inter> above (Some x) = - set (x # xs) \<inter> above ao"
             using above_eq by auto
           have eq_ys: "set (y # ys) \<inter> above (Some x) = set (y # ys) \<inter> above ao"
             using y_Min \<open>x < y\<close> xxs_above by(auto intro: above_upclosed)
           
           from \<open>x < y\<close> xs xs_above yys ys_above
           have "proper_interval_Compl_set_aux (Some x) xs (y # ys) \<longleftrightarrow>
                (\<exists>A. - set xs \<inter> above (Some x) \<sqsubset>' A \<inter> above (Some x) \<and>
                     A \<inter> above (Some x) \<sqsubset>' set (y # ys) \<inter> above (Some x))"
             by(rule "1.IH")
           also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs \<longleftrightarrow> _")
           proof
             assume ?lhs
             then obtain A where "- set xs \<inter> above (Some x) \<sqsubset>' A \<inter> above (Some x)"
               and "A \<inter> above (Some x) \<sqsubset>' set (y # ys) \<inter> above (Some x)" by blast
             moreover have "A \<inter> above (Some x) = (A - {x}) \<inter> above ao"
               using above_eq by auto
             ultimately have "- set (x # xs) \<inter> above ao \<sqsubset>' (A - {x}) \<inter> above ao"
               and "(A - {x}) \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao"
               using eq_xs eq_ys by simp_all
             thus ?rhs by blast
           next
             assume ?rhs
             then obtain A where "- set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
               and A_less: "A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao" by blast
             moreover have "x \<notin> A"
             proof
               assume "x \<in> A"
               hence "set (y # ys) \<inter> above ao \<sqsubset>' A \<inter> above ao"
                 using y_Min \<open>x < y\<close> by(auto simp add: above_eq set_less_aux_def intro!: bexI[where x=x])
               with A_less show False by(auto dest: set_less_aux_antisym)
             qed
             hence "A \<inter> above ao = A \<inter> above (Some x)" using above_eq by auto
             ultimately show ?lhs using eq_xs eq_ys by auto
           qed
           finally show ?thesis using False by simp
         qed
         thus ?thesis using True by simp
       next
         case False
         show ?thesis
         proof(cases "y < x")
           case True
           show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some y)")
             case True
             then obtain z where z: "z < y" "z \<in> above ao"
               by(auto simp add: proper_interval_Some2)
             hence nempty: "above ao \<noteq> {}" by auto
             with z have "Min (above ao) \<le> z" by auto
             hence "Min (above ao) < y" using \<open>z < y\<close> by(rule le_less_trans)
             hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
               using y_Min x_Min z \<open>y < x\<close>
               by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
             thus ?thesis using True \<open>y < x\<close> by(auto dest: set_less_aux_trans set_less_aux_antisym)
           next
             case False
             hence above_eq: "above ao = insert y (above (Some y))"
               using yys_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
             from y_Min have ys_above: "set ys \<subseteq> above (Some y)" by auto
             from \<open>y < x\<close> x_Min have xs_above: "set (x # xs) \<subseteq> above (Some y)" by auto
 
             have "y \<in> - set (x # xs) \<inter> above ao" using \<open>y < x\<close> x_Min yys_above by auto
             hence nempty: "- set (x # xs) \<inter> above ao \<noteq> {}" by auto
             have Min_x: "Min (- set (x # xs) \<inter> above ao) = y"
               using above_eq \<open>y < x\<close> x_Min by(auto intro!: Min_eqI)
             have Min_y: "Min (set (y # ys) \<inter> above ao) = y"
               using y_Min above_eq by(auto intro!: Min_eqI)
             have eq_xs: "- set (x # xs) \<inter> above ao - {y} = - set (x # xs) \<inter> above (Some y)"
                 by(auto simp add: above_eq)
             have eq_ys: "set ys \<inter> above ao - {y} = set ys \<inter> above (Some y)"
               using y_Min above_eq by auto
 
             from \<open>\<not> x < y\<close> \<open>y < x\<close> xxs xs_above ys ys_above
             have "proper_interval_Compl_set_aux (Some y) (x # xs) ys \<longleftrightarrow>
                  (\<exists>A. - set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y) \<and>
                       A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y))"
               by(rule "1.IH")
             also have "\<dots> \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof
               assume ?lhs'
               then obtain A where less_A: "- set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y)"
                 and A_less: "A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y)" by blast
               let ?A = "insert y A"
 
               have Min_A: "Min (?A \<inter> above ao) = y"
                 using above_eq by(auto intro!: Min_eqI)
               moreover have A_eq: "A \<inter> above ao - {y} = A \<inter> above (Some y)"
                 using above_eq by auto
               ultimately have less_A': "- set (x # xs) \<inter> above ao \<sqsubset>' ?A \<inter> above ao"
                 using nempty yys_above less_A Min_x eq_xs by(subst set_less_aux_rec) simp_all
 
               have A'_less: "?A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao"
                 using yys_above nempty Min_A A_eq A_less Min_y eq_ys
                 by(subst set_less_aux_rec) simp_all
               
               with less_A' show ?rhs by blast
             next
               assume ?rhs
               then obtain A where less_A: "- set (x # xs) \<inter> above ao \<sqsubset>' A \<inter> above ao"
                 and A_less: "A \<inter> above ao \<sqsubset>' set (y # ys) \<inter> above ao" by blast
 
               from less_A have nempty': "A \<inter> above ao \<noteq> {}" by auto
               moreover have A_eq: "A \<inter> above ao - {y} = A \<inter> above (Some y)"
                 using above_eq by auto
               moreover have y_in_xxs: "y \<in> - set (x # xs) \<inter> above ao"
                 using \<open>y < x\<close> x_Min yys_above by auto
               moreover have "y \<in> A"
               proof(rule ccontr)
                 assume "y \<notin> A"
                 hence "A \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
                   using \<open>y < x\<close> x_Min y_in_xxs
                   by(auto simp add: set_less_aux_def above_eq intro: bexI[where x=y])
                 with less_A show False by(rule set_less_aux_antisym)
               qed
               hence Min_A: "Min (A \<inter> above ao) = y" using above_eq y_Min by(auto intro!: Min_eqI)
               ultimately have less_A': "- set (x # xs) \<inter> above (Some y) \<sqsubset>' A \<inter> above (Some y)"
                 using nempty less_A Min_x eq_xs
                 by(subst (asm) set_less_aux_rec)(auto dest: bspec[where x=y])
               
               have A'_less: "A \<inter> above (Some y) \<sqsubset>' set ys \<inter> above (Some y)"
                 using A_less nempty' yys_above Min_A Min_y A_eq eq_ys
                 by(subst (asm) set_less_aux_rec) simp_all
               with less_A' show ?lhs' by blast
             qed
             finally show ?thesis using \<open>\<not> x < y\<close> \<open>y < x\<close> False by simp
           qed
         next
           case False
           with \<open>\<not> x < y\<close> have "x = y" by auto
           thus ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
           proof(cases "proper_interval ao (Some x)")
             case True
             then obtain z where z: "z < x" "z \<in> above ao"
               by(auto simp add: proper_interval_Some2)
             hence nempty: "above ao \<noteq> {}" by auto
             with z have "Min (above ao) \<le> z" by auto
             hence "Min (above ao) < x" using \<open>z < x\<close> by(rule le_less_trans)
             hence "set (y # ys) \<inter> above ao \<sqsubset>' - set (x # xs) \<inter> above ao"
               using y_Min x_Min z \<open>x = y\<close>
               by(fastforce simp add: set_less_aux_def nempty intro!: Min_eqI bexI[where x="Min (above ao)"])
             thus ?thesis using True \<open>x = y\<close> by(auto dest: set_less_aux_trans set_less_aux_antisym)
           next
             case False
             hence above_eq: "above ao = insert x (above (Some x))"
               using xxs_above by(auto simp add: proper_interval_Some2 intro: above_upclosed)
 
             have "(ys = [] \<longrightarrow> xs \<noteq> []) \<longleftrightarrow> ?rhs" (is "?lhs' \<longleftrightarrow> _")
             proof(intro iffI strip notI)
               assume ?lhs'
               show ?rhs
               proof(cases ys)
                 case Nil
                 with \<open>?lhs'\<close> obtain x' xs' where xs_eq: "xs = x' # xs'"
                   by(auto simp add: neq_Nil_conv)
                 with xs have x'_Min: "\<forall>x'' \<in> set xs'. x' < x''"
                   by(auto simp add: less_le)
                 let ?A = "- set (x # xs')"
                 have "- set (x # xs) \<inter> above ao \<subseteq> ?A \<inter> above ao"
                   using xs_eq by auto
                 moreover have "x' \<notin> - set (x # xs) \<inter> above ao" "x' \<in> ?A \<inter> above ao"
                   using xs_eq xxs_above x'_Min x_Min by auto
                 ultimately have "- set (x # xs) \<inter> above ao \<subset> ?A \<inter> above ao"
                   by blast
                 hence "- set (x # xs) \<inter> above ao \<sqsubset>' \<dots> "
                   by(fastforce intro: psubset_finite_imp_set_less_aux)
                 moreover have "\<dots> \<sqsubset>' set (y # ys) \<inter> above ao" 
                   using Nil \<open>x = y\<close> by(auto simp add: set_less_aux_def above_eq)
                 ultimately show ?thesis by blast
               next
                 case (Cons y' ys')
                 let ?A = "{y}"
                 have "- set (x # xs) \<inter> above ao \<sqsubset>' ?A \<inter> above ao"
                   using \<open>x = y\<close> x_Min by(auto simp add: set_less_aux_def above_eq)
                 moreover have "\<dots> \<subset> set (y # ys) \<inter> above ao"
                   using yys_above yys Cons by auto
                 hence "?A \<inter> above ao \<sqsubset>' \<dots>" by(fastforce intro: psubset_finite_imp_set_less_aux)
                 ultimately show ?thesis by blast
               qed
             next
               assume Nil: "ys = []" "xs = []" and ?rhs
               then obtain A where less_A: "- {x} \<inter> above ao \<sqsubset>' A \<inter> above ao" 
                 and A_less: "A \<inter> above ao \<sqsubset>' {x}" using \<open>x = y\<close> above_eq by auto
               have "x \<notin> A" using A_less by(auto simp add: set_less_aux_def above_eq)
               hence "A \<inter> above ao \<subseteq> - {x} \<inter> above ao" by auto
               hence "A \<inter> above ao \<sqsubseteq>' \<dots>" by(auto intro: subset_finite_imp_set_less_eq_aux)
               with less_A have "\<dots> \<sqsubset>' \<dots>" by(rule set_less_trans_set_less_eq)
               thus False by simp
             qed
             with \<open>x = y\<close> False show ?thesis by simp
           qed
         qed
       qed
     qed }
   from this[of None] show ?thesis by simp
 qed
 
 end
 
 subsection \<open>Proper intervals for HOL types\<close>
 
 instantiation unit :: proper_interval begin
 fun proper_interval_unit :: "unit proper_interval" where
   "proper_interval_unit None None = True"
 | "proper_interval_unit _ _ = False"
 instance by intro_classes auto
 end
 
 instantiation bool :: proper_interval begin
 fun proper_interval_bool :: "bool proper_interval" where
   "proper_interval_bool (Some x) (Some y) \<longleftrightarrow> False"
 | "proper_interval_bool (Some x) None \<longleftrightarrow> \<not> x"
 | "proper_interval_bool None (Some y) \<longleftrightarrow> y"
 | "proper_interval_bool None None = True"
 instance by intro_classes auto
 end
 
 instantiation nat :: proper_interval begin
 fun proper_interval_nat :: "nat proper_interval" where
   "proper_interval_nat no None = True"
 | "proper_interval_nat None (Some x) \<longleftrightarrow> x > 0"
 | "proper_interval_nat (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 instance by intro_classes auto
 end
 
 instantiation int :: proper_interval begin
 fun proper_interval_int :: "int proper_interval" where
   "proper_interval_int (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 | "proper_interval_int _ _ = True"
 instance by intro_classes (auto intro: less_add_one, metis less_add_one minus_less_iff)
 end
 
 instantiation integer :: proper_interval begin
 context includes integer.lifting begin
 lift_definition proper_interval_integer :: "integer proper_interval" is "proper_interval" .
 instance by(intro_classes)(transfer, simp only: proper_interval_simps)+
 end
 end
 lemma proper_interval_integer_simps [code]:
   includes integer.lifting fixes x y :: integer and xo yo :: "integer option" shows
   "proper_interval (Some x) (Some y) = (1 < y - x)"
   "proper_interval None yo = True"
   "proper_interval xo None = True"
 by(transfer, simp)+
 
 instantiation natural :: proper_interval begin
 context includes natural.lifting begin
 lift_definition proper_interval_natural :: "natural proper_interval" is "proper_interval" .
 instance by(intro_classes)(transfer, simp only: proper_interval_simps)+
 end
 end
 lemma proper_interval_natural_simps [code]:
   includes natural.lifting fixes x y :: natural and xo :: "natural option" shows
   "proper_interval xo None = True"
   "proper_interval None (Some y) \<longleftrightarrow> y > 0"
   "proper_interval (Some x) (Some y) \<longleftrightarrow> y - x > 1"
 by(transfer, simp)+
 
 lemma char_less_iff_nat_of_char: "x < y \<longleftrightarrow> of_char x < (of_char y :: nat)"
   by (fact less_char_def)
 
 lemma nat_of_char_inject [simp]: "of_char x = (of_char y :: nat) \<longleftrightarrow> x = y"
   by (fact of_char_eq_iff)
 
 lemma char_le_iff_nat_of_char: "x \<le> y \<longleftrightarrow> of_char x \<le> (of_char y :: nat)"
   by (fact less_eq_char_def)
 
 instantiation char :: proper_interval
 begin
 
 fun proper_interval_char :: "char proper_interval" where
   "proper_interval_char None None \<longleftrightarrow> True"
 | "proper_interval_char None (Some x) \<longleftrightarrow> x \<noteq> CHR 0x00"
 | "proper_interval_char (Some x) None \<longleftrightarrow> x \<noteq> CHR 0xFF"
 | "proper_interval_char (Some x) (Some y) \<longleftrightarrow> of_char y - of_char x > (1 :: nat)"
 
 instance proof
   fix y :: char
   { assume "y \<noteq> CHR 0x00"
     have "CHR 0x00 < y" 
     proof (rule ccontr)
       assume "\<not> CHR 0x00 < y"
       then have "of_char y = (of_char CHR 0x00 :: nat)"
         by (simp add: not_less char_le_iff_nat_of_char)
       then have "y = CHR 0x00"
         using nat_of_char_inject [of y "CHR 0x00"] by simp
       with \<open>y \<noteq> CHR 0x00\<close> show False
         by simp
     qed }
   moreover
   { fix z :: char
     assume "z < CHR 0x00"
     hence False
       by (simp add: char_less_iff_nat_of_char of_char_eq_iff [symmetric]) }
   ultimately show "proper_interval None (Some y) = (\<exists>z. z < y)"
     by auto
 
   fix x :: char
   { assume "x \<noteq> CHR 0xFF"
     then have "x < CHR 0xFF"
       by (auto simp add: neq_iff char_less_iff_nat_of_char)
         (insert nat_of_char_less_256 [of x], simp)
     hence "\<exists>z. x < z" .. }
   moreover
   { fix z :: char
     assume "CHR 0xFF < z"
     hence "False"
       by (simp add: char_less_iff_nat_of_char)
         (insert nat_of_char_less_256 [of z], simp) }
   ultimately show "proper_interval (Some x) None = (\<exists>z. x < z)" by auto
 
   { assume gt: "of_char y - of_char x > (1 :: nat)"
     let ?z = "char_of (of_char x + (1 :: nat))"
     from gt nat_of_char_less_256 [of y]
     have 255: "of_char x < (255 :: nat)" by arith
     with gt have "x < ?z" "?z < y"
       by (simp_all add: char_less_iff_nat_of_char)
     hence "\<exists>z. x < z \<and> z < y" by blast }
   moreover
   { fix z
     assume "x < z" "z < y"
     hence "(1 :: nat) < of_char y - of_char x"
       by (simp add: char_less_iff_nat_of_char) }
   ultimately show "proper_interval (Some x) (Some y) = (\<exists>z>x. z < y)"
     by auto
 qed simp
 
 end
 
 instantiation Enum.finite_1 :: proper_interval begin
 definition proper_interval_finite_1 :: "Enum.finite_1 proper_interval" 
 where "proper_interval_finite_1 x y \<longleftrightarrow> x = None \<and> y = None"
 instance by intro_classes (simp_all add: proper_interval_finite_1_def less_finite_1_def)
 end
 
 instantiation Enum.finite_2 :: proper_interval begin
 fun proper_interval_finite_2 :: "Enum.finite_2 proper_interval" where 
   "proper_interval_finite_2 None None \<longleftrightarrow> True"
 | "proper_interval_finite_2 None (Some x) \<longleftrightarrow> x = finite_2.a\<^sub>2"
 | "proper_interval_finite_2 (Some x) None \<longleftrightarrow> x = finite_2.a\<^sub>1"
 | "proper_interval_finite_2 (Some x) (Some y) \<longleftrightarrow> False"
 instance by intro_classes (auto simp add: less_finite_2_def)
 end
 
 instantiation Enum.finite_3 :: proper_interval begin
 fun proper_interval_finite_3 :: "Enum.finite_3 proper_interval" where
   "proper_interval_finite_3 None None \<longleftrightarrow> True"
 | "proper_interval_finite_3 None (Some x) \<longleftrightarrow> x \<noteq> finite_3.a\<^sub>1"
 | "proper_interval_finite_3 (Some x) None \<longleftrightarrow> x \<noteq> finite_3.a\<^sub>3"
 | "proper_interval_finite_3 (Some x) (Some y) \<longleftrightarrow> x = finite_3.a\<^sub>1 \<and> y = finite_3.a\<^sub>3"
 instance
 proof
   fix x y :: Enum.finite_3
   show "proper_interval None (Some y) = (\<exists>z. z < y)"
     by(cases y)(auto simp add: less_finite_3_def split: finite_3.split)
   show "proper_interval (Some x) None = (\<exists>z. x < z)"
     by(cases x)(auto simp add: less_finite_3_def)
   show "proper_interval (Some x) (Some y) = (\<exists>z>x. z < y)"
     by(auto simp add: less_finite_3_def split: finite_3.split_asm)
 qed simp
 end
 
 subsection \<open>List fusion for the order and proper intervals on @{typ "'a set"}\<close>
 
 definition length_last_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> nat \<times> 'a"
 where "length_last_fusion g s = length_last (list.unfoldr g s)"
 
 lemma length_last_fusion_code [code]:
   "length_last_fusion g s =
   (if list.has_next g s then
      let (x, s') = list.next g s
      in fold_fusion g (\<lambda>x (n, _). (n + 1, x)) s' (1, x)
    else (0, undefined))"
 unfolding length_last_fusion_def
 by(subst list.unfoldr.simps)(simp add: length_last_Nil length_last_Cons_code fold_fusion_def split_beta)
 
 declare length_last_fusion_def [symmetric, code_unfold]
 
 context proper_intrvl begin
 
 definition set_less_eq_aux_Compl_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "set_less_eq_aux_Compl_fusion g1 g2 ao s1 s2 = 
    set_less_eq_aux_Compl ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition Compl_set_less_eq_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "Compl_set_less_eq_aux_fusion g1 g2 ao s1 s2 = 
    Compl_set_less_eq_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition set_less_aux_Compl_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "set_less_aux_Compl_fusion g1 g2 ao s1 s2 =
    set_less_aux_Compl ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition Compl_set_less_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "Compl_set_less_aux_fusion g1 g2 ao s1 s2 =
    Compl_set_less_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition exhaustive_above_fusion :: "('a, 's) generator \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> bool"
 where "exhaustive_above_fusion g a s = exhaustive_above a (list.unfoldr g s)"
 
 definition exhaustive_fusion :: "('a, 's) generator \<Rightarrow> 's \<Rightarrow> bool"
 where "exhaustive_fusion g s = exhaustive (list.unfoldr g s)"
 
 definition proper_interval_set_aux_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_set_aux_fusion g1 g2 s1 s2 =
    proper_interval_set_aux (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition proper_interval_set_Compl_aux_fusion :: 
   "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> nat \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_set_Compl_aux_fusion g1 g2 ao n s1 s2 =
    proper_interval_set_Compl_aux ao n (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 definition proper_interval_Compl_set_aux_fusion ::
   "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 'a option \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
 where
   "proper_interval_Compl_set_aux_fusion g1 g2 ao s1 s2 =
    proper_interval_Compl_set_aux ao (list.unfoldr g1 s1) (list.unfoldr g2 s2)"
 
 lemma set_less_eq_aux_Compl_fusion_code:
   "set_less_eq_aux_Compl_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    (list.has_next g1 s1 \<longrightarrow> list.has_next g2 s2 \<longrightarrow>
     (let (x, s1') = list.next g1 s1;
          (y, s2') = list.next g2 s2
      in if x < y then proper_interval ao (Some x) \<or> set_less_eq_aux_Compl_fusion g1 g2 (Some x) s1' s2
         else if y < x then proper_interval ao (Some y) \<or> set_less_eq_aux_Compl_fusion g1 g2 (Some y) s1 s2'
         else proper_interval ao (Some y)))"
 unfolding set_less_eq_aux_Compl_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(simp add: split_beta)
 
 lemma Compl_set_less_eq_aux_fusion_code:
   "Compl_set_less_eq_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some x) s1' s2
              else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some y) s1 s2'
              else \<not> proper_interval ao (Some y)
         else \<not> proper_interval ao (Some x) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some x) s1' s2
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2
      in \<not> proper_interval ao (Some y) \<and> Compl_set_less_eq_aux_fusion g1 g2 (Some y) s1 s2'
    else \<not> proper_interval ao None)"
 unfolding Compl_set_less_eq_aux_fusion_def
 by(subst (1 2 4 5 8 9) list.unfoldr.simps)(simp add: split_beta)
 
 lemma set_less_aux_Compl_fusion_code:
   "set_less_aux_Compl_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then proper_interval ao (Some x) \<or> set_less_aux_Compl_fusion g1 g2 (Some x) s1' s2
              else if y < x then proper_interval ao (Some y) \<or> set_less_aux_Compl_fusion g1 g2 (Some y) s1 s2'
              else proper_interval ao (Some y)
         else proper_interval ao (Some x) \<or> set_less_aux_Compl_fusion g1 g2 (Some x) s1' s2
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2
      in proper_interval ao (Some y) \<or> set_less_aux_Compl_fusion g1 g2 (Some y) s1 s2'
    else proper_interval ao None)"
 unfolding set_less_aux_Compl_fusion_def
 by(subst (1 2 4 5 8 9) list.unfoldr.simps)(simp add: split_beta)
 
 lemma Compl_set_less_aux_fusion_code:
   "Compl_set_less_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    list.has_next g1 s1 \<and> list.has_next g2 s2 \<and>
   (let (x, s1') = list.next g1 s1;
        (y, s2') = list.next g2 s2
    in if x < y then \<not> proper_interval ao (Some x) \<and> Compl_set_less_aux_fusion g1 g2 (Some x) s1' s2
       else if y < x then \<not> proper_interval ao (Some y) \<and> Compl_set_less_aux_fusion g1 g2 (Some y) s1 s2'
       else \<not> proper_interval ao (Some y))"
 unfolding Compl_set_less_aux_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(simp add: split_beta)
 
 lemma exhaustive_above_fusion_code:
   "exhaustive_above_fusion g y s \<longleftrightarrow>
   (if list.has_next g s then
      let (x, s') = list.next g s
      in \<not> proper_interval (Some y) (Some x) \<and> exhaustive_above_fusion g x s'
    else \<not> proper_interval (Some y) None)"
 unfolding exhaustive_above_fusion_def
 by(subst list.unfoldr.simps)(simp add: split_beta)
 
 lemma exhaustive_fusion_code:
   "exhaustive_fusion g s =
   (list.has_next g s \<and> 
    (let (x, s') = list.next g s
     in \<not> proper_interval None (Some x) \<and> exhaustive_above_fusion g x s'))"
 unfolding exhaustive_fusion_def exhaustive_above_fusion_def
 by(subst (1) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_set_aux_fusion_code:
   "proper_interval_set_aux_fusion g1 g2 s1 s2 \<longleftrightarrow>
    list.has_next g2 s2 \<and>
   (let (y, s2') = list.next g2 s2
    in if list.has_next g1 s1 then
         let (x, s1') = list.next g1 s1
         in if x < y then False
            else if y < x then proper_interval (Some y) (Some x) \<or> list.has_next g2 s2' \<or> \<not> exhaustive_above_fusion g1 x s1'
            else proper_interval_set_aux_fusion g1 g2 s1' s2'
       else list.has_next g2 s2' \<or> proper_interval (Some y) None)"
 unfolding proper_interval_set_aux_fusion_def exhaustive_above_fusion_def
 by(subst (1 2) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_set_Compl_aux_fusion_code:
   "proper_interval_set_Compl_aux_fusion g1 g2 ao n s1 s2 \<longleftrightarrow>
   (if list.has_next g1 s1 then
      let (x, s1') = list.next g1 s1
      in if list.has_next g2 s2 then
           let (y, s2') = list.next g2 s2
           in if x < y then 
                proper_interval ao (Some x) \<or> 
                proper_interval_set_Compl_aux_fusion g1 g2 (Some x) (n + 1) s1' s2
              else if y < x then 
                proper_interval ao (Some y) \<or> 
                proper_interval_set_Compl_aux_fusion g1 g2 (Some y) (n + 1) s1 s2'
              else
                proper_interval ao (Some x) \<and>
                (let m = CARD('a) - n 
                 in m - length_fusion g2 s2' \<noteq> 2 \<or> m - length_fusion g1 s1' \<noteq> 2)
         else 
           let m = CARD('a) - n; (len_x, x') = length_last_fusion g1 s1
           in m \<noteq> len_x \<and> (m = len_x + 1 \<longrightarrow> \<not> proper_interval (Some x') None)
 
    else if list.has_next g2 s2 then
      let (y, s2') = list.next g2 s2;
          m = CARD('a) - n;
          (len_y, y') = length_last_fusion g2 s2
      in m \<noteq> len_y \<and> (m = len_y + 1 \<longrightarrow> \<not> proper_interval (Some y') None)
    else CARD('a) > n + 1)"
 unfolding proper_interval_set_Compl_aux_fusion_def length_last_fusion_def length_fusion_def
 by(subst (1 2 4 5 9 10) list.unfoldr.simps)(simp add: split_beta)
 
 lemma proper_interval_Compl_set_aux_fusion_code:
   "proper_interval_Compl_set_aux_fusion g1 g2 ao s1 s2 \<longleftrightarrow>
    list.has_next g1 s1 \<and> list.has_next g2 s2 \<and>
    (let (x, s1') = list.next g1 s1;
         (y, s2') = list.next g2 s2
     in if x < y then
          \<not> proper_interval ao (Some x) \<and> proper_interval_Compl_set_aux_fusion g1 g2 (Some x) s1' s2
        else if y < x then
          \<not> proper_interval ao (Some y) \<and> proper_interval_Compl_set_aux_fusion g1 g2 (Some y) s1 s2'
        else \<not> proper_interval ao (Some x) \<and> (list.has_next g2 s2' \<or> list.has_next g1 s1'))"
 unfolding proper_interval_Compl_set_aux_fusion_def
 by(subst (1 2 4 5) list.unfoldr.simps)(auto simp add: split_beta)
 
 end
 
 lemmas [code] =
   set_less_eq_aux_Compl_fusion_code proper_intrvl.set_less_eq_aux_Compl_fusion_code
   Compl_set_less_eq_aux_fusion_code proper_intrvl.Compl_set_less_eq_aux_fusion_code
   set_less_aux_Compl_fusion_code proper_intrvl.set_less_aux_Compl_fusion_code
   Compl_set_less_aux_fusion_code proper_intrvl.Compl_set_less_aux_fusion_code
   exhaustive_above_fusion_code proper_intrvl.exhaustive_above_fusion_code
   exhaustive_fusion_code proper_intrvl.exhaustive_fusion_code
   proper_interval_set_aux_fusion_code proper_intrvl.proper_interval_set_aux_fusion_code
   proper_interval_set_Compl_aux_fusion_code proper_intrvl.proper_interval_set_Compl_aux_fusion_code
   proper_interval_Compl_set_aux_fusion_code proper_intrvl.proper_interval_Compl_set_aux_fusion_code
 
 lemmas [symmetric, code_unfold] =
   set_less_eq_aux_Compl_fusion_def proper_intrvl.set_less_eq_aux_Compl_fusion_def
   Compl_set_less_eq_aux_fusion_def proper_intrvl.Compl_set_less_eq_aux_fusion_def
   set_less_aux_Compl_fusion_def proper_intrvl.set_less_aux_Compl_fusion_def
   Compl_set_less_aux_fusion_def proper_intrvl.Compl_set_less_aux_fusion_def
   exhaustive_above_fusion_def proper_intrvl.exhaustive_above_fusion_def
   exhaustive_fusion_def proper_intrvl.exhaustive_fusion_def
   proper_interval_set_aux_fusion_def proper_intrvl.proper_interval_set_aux_fusion_def
   proper_interval_set_Compl_aux_fusion_def proper_intrvl.proper_interval_set_Compl_aux_fusion_def
   proper_interval_Compl_set_aux_fusion_def proper_intrvl.proper_interval_Compl_set_aux_fusion_def
 
 subsection \<open>Drop notation\<close>
 
 context ord begin
 
 no_notation set_less_aux (infix "\<sqsubset>''" 50)
   and set_less_eq_aux (infix "\<sqsubseteq>''" 50)
   and set_less_eq_aux' (infix "\<sqsubseteq>''''" 50)
   and set_less_eq_aux'' (infix "\<sqsubseteq>''''''" 50)
   and set_less_eq (infix "\<sqsubseteq>" 50)
   and set_less (infix "\<sqsubset>" 50)
 
 end
 
 end
diff --git a/thys/Jinja/DFA/Kildall.thy b/thys/Jinja/DFA/Kildall.thy
--- a/thys/Jinja/DFA/Kildall.thy
+++ b/thys/Jinja/DFA/Kildall.thy
@@ -1,513 +1,517 @@
 (*  Title:      HOL/MicroJava/BV/Kildall.thy
     Author:     Tobias Nipkow, Gerwin Klein
     Copyright   2000 TUM
 
 Kildall's algorithm.
 *)
 
 section \<open>Kildall's Algorithm \label{sec:Kildall}\<close>
 
 theory Kildall
 imports SemilatAlg
 begin
 
 
 
 primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat set \<Rightarrow> 's list * nat set"
 where
   "propa f []      \<tau>s w = (\<tau>s,w)"
 | "propa f (q'#qs) \<tau>s w = (let (q,\<tau>) = q';
                              u = \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!q;
                              w' = (if u = \<tau>s!q then w else insert q w)
                          in propa f qs (\<tau>s[q := u]) w')"
 
 definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow>
           's list \<Rightarrow> nat set \<Rightarrow> 's list \<times> nat set"
 where
   "iter f step \<tau>s w =
    while (\<lambda>(\<tau>s,w). w \<noteq> {})
          (\<lambda>(\<tau>s,w). let p = SOME p. p \<in> w
                    in propa f (step p (\<tau>s!p)) \<tau>s (w-{p}))
          (\<tau>s,w)"
 
 definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat set"
 where
   "unstables r step \<tau>s = {p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p}"
 
 definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
 where
   "kildall r f step \<tau>s = fst(iter f step \<tau>s (unstables r step \<tau>s))"
 
 primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
 where
   "merges f []      \<tau>s = \<tau>s"
 | "merges f (p'#ps) \<tau>s = (let (p,\<tau>) = p' in merges f ps (\<tau>s[p := \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!p]))"
 
 
 lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]
 
 
 lemma (in Semilat) nth_merges:
  "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
   (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] \<Squnion>\<^bsub>f\<^esub> ss!p"
   (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
 (*<*)
 proof (induct ps)
   show "\<And>ss. ?P ss []" by simp
 
   fix ss p' ps'
   assume ss: "ss \<in> list n A"
   assume l:  "p < length ss"
   assume "?steptype (p'#ps')"
   then obtain a b where
     p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
     by (cases p') auto
   assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
   hence IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" using ps' by iprover
 
   from ss ab
   have "ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a] \<in> list n A" by (simp add: closedD)
   moreover
   with l have "p < length (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a])" by simp
   ultimately
   have "?P (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a]) ps'" by (rule IH)
   with p' l
   show "?P ss (p'#ps')" by simp
 qed
 (*>*)
 
 
 (** merges **)
 
 lemma length_merges [simp]:
   "\<And>ss. size(merges f ps ss) = size ss"
 (*<*) by (induct ps, auto) (*>*)
 
 lemma (in Semilat) merges_preserves_type_lemma:
 shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
          \<longrightarrow> merges f ps xs \<in> list n A"
 (*<*)
 apply (insert closedI)
 apply (unfold closed_def)
 apply (induct ps)
  apply simp
 apply clarsimp
 done
 (*>*)
 
 lemma (in Semilat) merges_preserves_type [simp]:
  "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
   \<Longrightarrow> merges f ps xs \<in> list n A"
 by (simp add: merges_preserves_type_lemma)
 
 lemma (in Semilat) merges_incr_lemma:
  "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
 (*<*)
 apply (induct ps)
  apply simp
 apply simp
 apply clarify
 apply (rule order_trans)
   apply simp
  apply (erule list_update_incr)
   apply simp
  apply simp
 apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
 done
 (*>*)
 
 lemma (in Semilat) merges_incr:
  "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk> 
   \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
   by (simp add: merges_incr_lemma)
 
 
 lemma (in Semilat) merges_same_conv [rule_format]:
  "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow> 
      (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x \<sqsubseteq>\<^bsub>r\<^esub> xs!p))"
 (*<*)
   apply (induct_tac ps)
    apply simp
   apply clarsimp
   apply (rename_tac p x ps xs)
   apply (rule iffI)
    apply (rule context_conjI)
     apply (subgoal_tac "xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] xs")
      apply (force dest!: le_listD simp add: nth_list_update)
     apply (erule subst, rule merges_incr)
        apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
       apply clarify
       apply (rule conjI)
        apply simp
        apply (blast dest: boundedD)
       apply blast
    apply clarify
    apply (erule allE)
    apply (erule impE)
     apply assumption
    apply (drule bspec)
     apply assumption
    apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
    apply blast
   apply clarify 
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   done
 (*>*)
 
 
 lemma (in Semilat) list_update_le_listI [rule_format]:
   "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<longrightarrow> p < size xs \<longrightarrow>  
    x \<sqsubseteq>\<^bsub>r\<^esub> ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] ys"
 (*<*)
   apply (insert semilat)
   apply (simp only: Listn.le_def lesub_def semilat_def)
   apply (simp add: list_all2_conv_all_nth nth_list_update)
   done
 (*>*)
 
 lemma (in Semilat) merges_pres_le_ub:
   assumes "set ts \<subseteq> A"  "set ss \<subseteq> A"
     "\<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p < size ts"  "ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
   shows "merges f ps ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
 (*<*)
 proof -
   { fix t ts ps
     have
     "\<And>qs. \<lbrakk>set ts \<subseteq> A; \<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
     set qs \<subseteq> set ps  \<longrightarrow> 
     (\<forall>ss. set ss \<subseteq> A \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<longrightarrow> merges f qs ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts)"
     apply (induct_tac qs)
      apply simp
     apply (simp (no_asm_simp))
     apply clarify
     apply simp
     apply (erule allE, erule impE, erule_tac [2] mp)
      apply (drule bspec, assumption)
      apply (simp add: closedD)
     apply (drule bspec, assumption)
     apply (simp add: list_update_le_listI)
     done 
   } note this [dest]  
   from assms show ?thesis by blast
 qed
 (*>*)
 
 
 (** propa **)
 
 lemma decomp_propa:
   "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow> 
    propa f qs ss w = 
    (merges f qs ss, {q. \<exists>t.(q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> w)"
 (*<*)
   apply (induct qs)
    apply simp   
   apply (simp (no_asm))
   apply clarify  
   apply simp
   apply (rule conjI) 
    apply blast
   apply (simp add: nth_list_update)
   apply blast
   done 
 (*>*)
 
 (** iter **)
 
 lemma (in Semilat) stable_pres_lemma:
 shows "\<lbrakk>pres_type step n A; bounded step n; 
      ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n; 
      \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n; 
      \<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss!q = ss!q; 
      q \<notin> w \<or> q = p \<rbrakk> 
   \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
 (*<*)
   apply (unfold stable_def)
   apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
    prefer 2
    apply clarify
    apply (erule pres_typeD)
     prefer 3 apply assumption
     apply (rule listE_nth_in)
      apply assumption
     apply simp
    apply simp
   apply simp
   apply clarify
   apply (subst nth_merges)
        apply simp
        apply (blast dest: boundedD)
       apply assumption
      apply clarify
      apply (rule conjI)
       apply (blast dest: boundedD)
      apply (erule pres_typeD)
        prefer 3 apply assumption
       apply simp
      apply simp
 apply(subgoal_tac "q < length ss")
 prefer 2 apply simp
   apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
 apply assumption
   apply clarify
   apply (rule conjI)
    apply (blast dest: boundedD)
   apply (erule pres_typeD)
      prefer 3 apply assumption
     apply simp
    apply simp
   apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
    apply assumption
 
  apply (simp add: plusplus_empty)
  apply (cases "q \<in> w")
   apply simp
   apply (rule ub1')
      apply (rule Semilat.intro)
      apply (rule semilat)
     apply clarify
     apply (rule pres_typeD)
        apply assumption
       prefer 3 apply assumption
      apply (blast intro: listE_nth_in dest: boundedD)
     apply (blast intro: pres_typeD dest: boundedD)
    apply (blast intro: listE_nth_in dest: boundedD)
   apply assumption
 
  apply simp
  apply (erule allE, erule impE, assumption, erule impE, assumption)
  apply (rule order_trans)
    apply simp
   defer
  apply (rule pp_ub2)(*
     apply assumption*)
    apply simp
    apply clarify
    apply simp
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply blast
  done
 (*>*)
 
 
 lemma (in Semilat) merges_bounded_lemma:
  "\<lbrakk> mono r step n A; bounded step n; 
     \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n; 
     ss [\<sqsubseteq>\<^sub>r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk> 
   \<Longrightarrow> merges f (step p (ss!p)) ss [\<sqsubseteq>\<^sub>r] ts" 
 (*<*)
   apply (unfold stable_def)
   apply (rule merges_pres_le_ub)
      apply simp
     apply simp
    prefer 2 apply assumption
 
   apply clarsimp
   apply (drule boundedD, assumption+)
   apply (erule allE, erule impE, assumption)
   apply (drule bspec, assumption)
   apply simp
 
   apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
      apply assumption
     apply simp
    apply (simp add: le_listD)
   
   apply (drule lesub_step_typeD, assumption) 
   apply clarify
   apply (drule bspec, assumption)
   apply simp
   apply (blast intro: order_trans)
   done
 (*>*)
 
 lemma termination_lemma: assumes "Semilat A r f"
 shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow> 
       ss [\<sqsubset>\<^sub>r] merges f qs ss \<or> 
   merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> (w-{p}) \<subset> w"
 (*<*) (is "PROP ?P")
 proof -
   interpret Semilat A r f by fact
   show "PROP ?P"
   apply(insert semilat)
     apply (unfold lesssub_def)
     apply (simp (no_asm_simp) add: merges_incr)
     apply (rule impI)
     apply (rule merges_same_conv [THEN iffD1, elim_format]) 
     apply assumption+
       defer
       apply (rule sym, assumption)
      defer apply simp
      apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss ! q \<noteq> ss ! q)")
      apply (blast intro!: psubsetI elim: equalityE)
      apply clarsimp
      apply (drule bspec, assumption) 
      apply (drule bspec, assumption)
      apply clarsimp
     done 
 qed
 (*>*)
 
+(*for lex*)
+lemma ne_lesssub_iff [simp]: "y\<noteq>x \<and> x [\<sqsubset>\<^sub>r] y \<longleftrightarrow> x [\<sqsubset>\<^sub>r] y"
+  by (meson lesssub_def)
+
 lemma iter_properties[rule_format]: assumes "Semilat A r f"
 shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
      bounded step n; \<forall>p\<in>w0. p < n; ss0 \<in> list n A;
      \<forall>p<n. p \<notin> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
    iter f step ss0 w0 = (ss',w')
    \<longrightarrow>
    ss' \<in> list n A \<and> stables r step ss' \<and> ss0 [\<sqsubseteq>\<^sub>r] ss' \<and>
    (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss' [\<sqsubseteq>\<^sub>r] ts)"
 (*<*) (is "PROP ?P")
 proof -
   interpret Semilat A r f by fact
   show "PROP ?P"
   apply(insert semilat)
   apply (unfold iter_def stables_def)
   apply (rule_tac P = "\<lambda>(ss,w).
    ss \<in> list n A \<and> (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and> ss0 [\<sqsubseteq>\<^sub>r] ss \<and>
    (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss [\<sqsubseteq>\<^sub>r] ts) \<and>
    (\<forall>p\<in>w. p < n)" and
    r = "{(ss',ss) . ss [\<sqsubset>\<^sub>r] ss'} <*lex*> finite_psubset"
          in while_rule)
 
   \<comment> \<open>Invariant holds initially:\<close>
   apply (simp add:stables_def)
 
   \<comment> \<open>Invariant is preserved:\<close>
   apply(simp add: stables_def split_paired_all)
   apply(rename_tac ss w)
   apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
    prefer 2 apply (fast intro: someI)
   apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
    prefer 2
    apply clarify
    apply (rule conjI)
     apply(clarsimp, blast dest!: boundedD)
    apply (erule pres_typeD)
     prefer 3
     apply assumption
     apply (erule listE_nth_in)
     apply blast
    apply blast
   apply (subst decomp_propa)
    apply blast
   apply simp
   apply (rule conjI)
    apply (rule merges_preserves_type)
    apply blast
    apply clarify
    apply (rule conjI)
     apply(clarsimp, blast dest!: boundedD)
    apply (erule pres_typeD)
     prefer 3
     apply assumption
     apply (erule listE_nth_in)
     apply blast
    apply blast
   apply (rule conjI)
    apply clarify
    apply (blast intro!: stable_pres_lemma)
   apply (rule conjI)
    apply (blast intro!: merges_incr intro: le_list_trans)
   apply (rule conjI)
    apply clarsimp
    apply (blast intro!: merges_bounded_lemma)
   apply (blast dest!: boundedD)
 
 
   \<comment> \<open>Postcondition holds upon termination:\<close>
   apply(clarsimp simp add: stables_def split_paired_all)
 
   \<comment> \<open>Well-foundedness of the termination relation:\<close>
   apply (rule wf_lex_prod)
    apply (insert orderI [THEN acc_le_listI])
    apply (simp only: acc_def lesssub_def)
   apply (rule wf_finite_psubset) 
 
   \<comment> \<open>Loop decreases along termination relation:\<close>
   apply(simp add: stables_def split_paired_all)
   apply(rename_tac ss w)
   apply(subgoal_tac "(SOME p. p \<in> w) \<in> w")
    prefer 2 apply (fast intro: someI)
   apply(subgoal_tac "\<forall>(q,t) \<in> set (step (SOME p. p \<in> w) (ss ! (SOME p. p \<in> w))). q < length ss \<and> t \<in> A")
    prefer 2
    apply clarify
    apply (rule conjI)
     apply(clarsimp, blast dest!: boundedD)
    apply (erule pres_typeD)
     prefer 3
     apply assumption
     apply (erule listE_nth_in)
     apply blast
    apply blast
   apply (subst decomp_propa)
    apply blast
   apply clarify
   apply (simp del: listE_length
       add: lex_prod_def finite_psubset_def 
            bounded_nat_set_is_finite)
   apply (rule termination_lemma)
   apply (rule assms)
   apply assumption+
   defer
   apply assumption
   apply clarsimp
   done
 qed
 (*>*)
 
 
 lemma kildall_properties: assumes "Semilat A r f"
 shows "\<lbrakk> acc r; pres_type step n A; mono r step n A;
      bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
   kildall r f step ss0 \<in> list n A \<and>
   stables r step (kildall r f step ss0) \<and>
   ss0 [\<sqsubseteq>\<^sub>r] kildall r f step ss0 \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow>
                  kildall r f step ss0 [\<sqsubseteq>\<^sub>r] ts)"
 (*<*) (is "PROP ?P")
 proof -
   interpret Semilat A r f by fact
   show "PROP ?P"
   apply (unfold kildall_def)
   apply(case_tac "iter f step ss0 (unstables r step ss0)")
   apply(simp)
   apply (rule iter_properties)
   apply (simp_all add: unstables_def stable_def)
   apply (rule Semilat.intro)
   apply (rule semilat)
   done
 qed
 
 
 lemma is_bcv_kildall: assumes "Semilat A r f"
 shows "\<lbrakk> acc r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
   \<Longrightarrow> is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
 proof -
   interpret Semilat A r f by fact
   show "PROP ?P"
   apply(unfold is_bcv_def wt_step_def)
   apply(insert \<open>Semilat A r f\<close> semilat kildall_properties[of A])
   apply(simp add:stables_def)
   apply clarify
   apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0 \<in> list n A")
    prefer 2 apply (simp(no_asm_simp))
   apply (rule iffI)
    apply (rule_tac x = "kildall r f step \<tau>s\<^sub>0" in bexI) 
     apply (rule conjI)
      apply (blast)
     apply (simp  (no_asm_simp))
    apply(assumption)
   apply clarify
   apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0!p <=_r \<tau>s!p")
    apply simp
   apply (blast intro!: le_listD less_lengthI)
   done
 qed
 (*>*)
 
 end