diff --git a/thys/Algebraic_VCs/Domain_Quantale.thy b/thys/Algebraic_VCs/Domain_Quantale.thy
--- a/thys/Algebraic_VCs/Domain_Quantale.thy
+++ b/thys/Algebraic_VCs/Domain_Quantale.thy
@@ -1,524 +1,511 @@
 (* Title: Domain Quantales
    Author: Victor Gomes, Georg Struth
    Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
                Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Component for Recursive Programs\<close>
 
 theory Domain_Quantale
   imports KAD.Modal_Kleene_Algebra
 
 begin
 
 text \<open>This component supports the verification and step-wise refinement of recursive programs
 in a partial correctness setting.\<close>
 
 notation
   times (infixl "\<cdot>" 70) and
   bot ("\<bottom>") and
   top ("\<top>") and
   inf (infixl "\<sqinter>" 65) and
   sup (infixl "\<squnion>" 65)
-(*
-  Inf ("\<Sqinter>_" [900] 900) and
-  Sup ("\<Squnion>_" [900] 900)
-*)
-
-(*
-syntax
-  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
-  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
-  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
-  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
-
-*)
 
 subsection \<open>Lattice-Ordered Monoids with Domain\<close>
 
 class bd_lattice_ordered_monoid = bounded_lattice + distrib_lattice + monoid_mult +
   assumes left_distrib: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   and right_distrib: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   and bot_annil [simp]: "\<bottom> \<cdot> x = \<bottom>"
   and bot_annir [simp]: "x \<cdot> \<bottom> = \<bottom>"
 
 begin
 
 sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "bot" 
   by (standard, auto simp: sup.assoc sup.commute sup_left_commute left_distrib right_distrib sup_absorb1)   
 
 sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" bot "(\<le>)" "(<)"
   by (standard, simp add: le_iff_sup, auto)
 
 end
 
 no_notation ads_d ("d")
   and ars_r ("r")
   and antirange_op ("ar _" [999] 1000)
 
 class domain_bdlo_monoid = bd_lattice_ordered_monoid +
   assumes rdv: "(z \<sqinter> x \<cdot> top) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> top"  
 
 begin 
 
 definition "d x = 1 \<sqinter> x \<cdot> \<top>"
 
 sublocale ds: domain_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "d" "(\<le>)" "(<)"
 proof standard
   fix x y
   show "x \<squnion> d x \<cdot> x = d x \<cdot> x"
     by (metis d_def inf_sup_absorb left_distrib mult_1_left mult_1_right rdv sup.absorb_iff1 sup.idem sup.left_commute top_greatest)
   show "d (x \<cdot> d y) = d (x \<cdot> y)"
     by (simp add: d_def inf_absorb2 rdv  mult_assoc)
   show "d x \<squnion> 1 = 1"
     by (simp add: d_def sup.commute)
   show "d bot = bot"
     by (simp add: d_def inf.absorb1 inf.commute)
   show "d (x \<squnion> y) = d x \<squnion> d y"
     by (simp add: d_def inf_sup_distrib1)
 qed
 
 end
 
 subsection\<open>Boolean Monoids with Domain\<close>
 
 class boolean_monoid = boolean_algebra + monoid_mult +  
   assumes left_distrib': "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   and right_distrib': "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   and bot_annil' [simp]: "\<bottom> \<cdot> x = \<bottom>"
   and bot_annir' [simp]: "x \<cdot> \<bottom> = \<bottom>"
 
 begin
 
 subclass bd_lattice_ordered_monoid
   by (standard, simp_all add: left_distrib' right_distrib')
 
 lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
   by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)
 
 end
 
 class domain_boolean_monoid = boolean_monoid + 
   assumes rdv': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"     
 
 begin
 
 sublocale dblo: domain_bdlo_monoid "1" "(\<cdot>)" "(\<sqinter>)" "(\<le>)" "(<)" "(\<squnion>)" "\<bottom>" "\<top>"
   by (standard, simp add: rdv')
 
 definition "a x = 1 \<sqinter> -(dblo.d x)"
                                 
 lemma a_d_iff: "a x = 1 \<sqinter> -(x \<cdot> \<top>)"
   by (clarsimp simp: a_def dblo.d_def inf_sup_distrib1) 
 
 lemma topr: "-(x \<cdot> \<top>) \<cdot> \<top> = -(x \<cdot> \<top>)" 
 proof (rule order.antisym)
   show "-(x \<cdot> \<top>) \<le> -(x \<cdot> \<top>) \<cdot> \<top>"
     by (metis mult_isol_var mult_oner order_refl top_greatest)
   have "-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>) = \<bottom>"
     by simp
   hence "(-(x \<cdot> \<top>) \<sqinter> (x \<cdot> \<top>)) \<cdot> \<top>  = \<bottom>"
     by simp 
   hence "-(x \<cdot> \<top>) \<cdot> \<top> \<sqinter> (x \<cdot> \<top>)  = \<bottom>"
     by (metis rdv') 
   thus "-(x \<cdot> \<top>) \<cdot> \<top> \<le> -(x \<cdot> \<top>)"
     by (simp add: inf_bot_iff_le)
 qed
 
 lemma dd_a: "dblo.d x = a (a x)"
   by (metis a_d_iff dblo.d_def double_compl inf_top.left_neutral mult_1_left rdv' topr)
 
 lemma ad_a [simp]: "a (dblo.d x) = a x"
   by (simp add: a_def)
 
 lemma da_a [simp]: "dblo.d (a x) = a x"
   using ad_a dd_a by auto
 
 lemma a1 [simp]: "a x \<cdot> x = \<bottom>"
 proof -
   have "a x \<cdot> x \<cdot> \<top> = \<bottom>"
     by (metis a_d_iff inf_compl_bot mult_1_left rdv' topr)
   then show ?thesis
     by (metis (no_types) dblo.d_def dblo.ds.domain_very_strict inf_bot_right)
 qed
 
 lemma a2 [simp]: "a (x \<cdot> y) \<squnion> a (x \<cdot> a (a y)) = a (x \<cdot> a (a y))"
   by (metis a_def dblo.ds.dsr2 dd_a sup.idem)
 
 lemma a3 [simp]: "a (a x) \<squnion> a x = 1"
   by (metis a_def da_a inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)
 
 subclass domain_bdlo_monoid ..
 
 text \<open>The next statement shows that every boolean monoid with domain is an antidomain semiring. 
 In this setting the domain operation has been defined explicitly.\<close>
 
 sublocale ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
   rewrites ad_eq: "ad.ads_d x = d x"
 proof -
   show "class.antidomain_semiring a (\<squnion>) (\<cdot>) 1 \<bottom> (\<le>) (<)"
     by (standard, simp_all)
   then interpret ad: antidomain_semiring a "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" .
   show "ad.ads_d x = d x"
     by (simp add: ad.ads_d_def dd_a)
 qed
 
 end 
 
 subsection\<open>Boolean Monoids with Range\<close>
 
 class range_boolean_monoid = boolean_monoid + 
   assumes ldv': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"
 
 begin
 
 definition "r x = 1 \<sqinter> \<top> \<cdot> x"
 
 definition "ar x = 1 \<sqinter> -(r x)"
                                 
 lemma ar_r_iff: "ar x = 1 \<sqinter> -(\<top> \<cdot> x)"
   by (simp add: ar_def inf_sup_distrib1 r_def)
 
 lemma topl: "\<top>\<cdot>(-(\<top> \<cdot> x)) = -(\<top> \<cdot> x)" 
 proof (rule order.antisym)
   show "\<top> \<cdot> - (\<top> \<cdot> x) \<le> - (\<top> \<cdot> x)"
     by (metis bot_annir' compl_inf_bot inf_bot_iff_le ldv')
   show "- (\<top> \<cdot> x) \<le> \<top> \<cdot> - (\<top> \<cdot> x)"
     by (metis inf_le2 inf_top.right_neutral mult_1_left mult_isor)
 qed
 
 lemma r_ar: "r x = ar (ar x)"
   by (metis ar_r_iff double_compl inf.commute inf_top.right_neutral ldv' mult_1_right r_def topl)
 
 lemma ar_ar [simp]: "ar (r x) = ar x"
   by (simp add: ar_def ldv' r_def)
 
 lemma rar_ar [simp]: "r (ar x) = ar x"
   using r_ar ar_ar by force
 
 lemma ar1 [simp]: "x \<cdot> ar x = \<bottom>"
 proof -
   have "\<top> \<cdot> x \<cdot> ar x = \<bottom>"
     by (metis ar_r_iff inf_compl_bot ldv' mult_oner topl)
   then show ?thesis
     by (metis inf_bot_iff_le inf_le2 inf_top.right_neutral mult_1_left mult_isor mult_oner topl)
 qed
 
 lemma ars: "r (r x \<cdot> y) = r (x \<cdot> y)"
   by (metis inf.commute inf_top.right_neutral ldv' mult_oner mult_assoc r_def)
 
 lemma ar2 [simp]: "ar (x \<cdot> y) \<squnion> ar (ar (ar x) \<cdot> y) = ar (ar (ar x) \<cdot> y)"
   by (metis ar_def ars r_ar sup.idem)
                          
 lemma ar3 [simp]: "ar (ar x) \<squnion> ar x = 1 "
   by (metis ar_def rar_ar inf.commute sup.commute sup_compl_top sup_inf_absorb sup_inf_distrib1)
 
 sublocale ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)"
   rewrites ar_eq: "ar.ars_r x = r x"
 proof -
   show "class.antirange_semiring (\<squnion>) (\<cdot>) 1 \<bottom> ar (\<le>) (<)"
     by (standard, simp_all)
   then interpret ar: antirange_semiring "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" ar "(\<le>)" "(<)" .
   show "ar.ars_r x = r x"
     by (simp add: ar.ars_r_def r_ar)
 qed
 
 end
 
 subsection \<open>Quantales\<close>
 
 text \<open>This part will eventually move into an AFP quantale entry.\<close> 
 
 class quantale = complete_lattice + monoid_mult +
   assumes Sup_distr: "Sup X \<cdot> y = Sup {z. \<exists>x \<in> X. z = x \<cdot> y}"
   and Sup_distl: "x \<cdot> Sup Y = Sup {z. \<exists>y \<in> Y. z = x \<cdot> y}"       
 
 begin
 
 lemma bot_annil'' [simp]: "\<bottom> \<cdot> x = \<bottom>"
   using Sup_distr[where X="{}"] by auto
 
 lemma bot_annirr'' [simp]: "x \<cdot> \<bottom> = \<bottom>"
   using Sup_distl[where Y="{}"] by auto
 
 lemma sup_distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   using Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)
 
 lemma sup_distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   using Sup_distr[where X="{x, y}"] by (fastforce intro!: Sup_eqI)
 
 sublocale semiring_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" 
   by (standard, auto simp: sup.assoc sup.commute sup_left_commute sup_distl sup_distr)     
 
 sublocale dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
   by (standard, simp add: le_iff_sup, auto)
 
 lemma Sup_sup_pred: "x \<squnion> Sup{y. P y} = Sup{y. y = x \<or> P y}"
   apply (rule order.antisym)
   apply (simp add: Collect_mono Sup_subset_mono Sup_upper) 
   using Sup_least Sup_upper le_supI2 by fastforce
 
 definition star :: "'a \<Rightarrow> 'a" where
   "star x = (SUP i. x ^ i)"
 
 lemma star_def_var1: "star x = Sup{y. \<exists>i. y = x ^ i}"
   by (simp add: star_def full_SetCompr_eq)
 
 lemma star_def_var2: "star x = Sup{x ^ i |i. True}"
   by (simp add: star_def full_SetCompr_eq)
 
 lemma star_unfoldl' [simp]: "1 \<squnion> x \<cdot> (star x) = star x"
 proof -
   have "1 \<squnion> x \<cdot> (star x) = x ^ 0 \<squnion> x \<cdot> Sup{y. \<exists>i. y = x ^ i}"
     by (simp add: star_def_var1)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
     by (simp add: Sup_distl, metis)
   also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
     using Sup_sup_pred by simp
   also have "... = Sup{y. \<exists>i. y = x ^ i}"
     by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
   finally show ?thesis
     by (simp add: star_def_var1)
 qed
 
 lemma star_unfoldr' [simp]: "1 \<squnion> (star x) \<cdot> x = star x"
 proof -
   have "1 \<squnion> (star x) \<cdot> x = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i} \<cdot> x"
     by (simp add: star_def_var1)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ i \<cdot> x}"
     by (simp add: Sup_distr, metis)
   also have "... = x ^ 0 \<squnion> Sup{y. \<exists>i. y = x ^ (i + 1)}"
     using power_Suc2 by simp 
    also have "... = Sup{y. y = x ^ 0 \<or> (\<exists>i. y = x ^ (i + 1))}"
     using Sup_sup_pred by simp
   also have "... = Sup{y. \<exists>i. y = x ^ i}"
     by (metis Suc_eq_plus1 power.power.power_Suc power.power_eq_if)
   finally show ?thesis
     by (simp add: star_def_var1)
 qed
 
 lemma (in dioid_one_zero) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
 proof (induct n)
   case 0 show ?case
     using "0.prems" by simp
   case Suc thus ?case
     by (simp, metis mult.assoc mult_isol order_trans)
 qed
 
 lemma (in dioid_one_zero) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
 proof (induct n)
   case 0 show ?case
     using "0.prems" by auto
   case Suc
   {
     fix n
     assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
       and "z + y \<cdot> x \<le> y"
     hence "z \<cdot> x ^ n \<le> y"
       by simp
     also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
       by (metis mult.assoc power_Suc)
     moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
       by (metis mult.assoc power_commutes)
     moreover have "... \<le> y \<cdot> x"
       by (metis calculation(1) mult_isor)
     moreover have "... \<le> y"
       using \<open>z + y \<cdot> x \<le> y\<close> by simp
     ultimately have "z \<cdot> x ^ Suc n \<le> y" by simp
   }
   thus ?case
     by (metis Suc)
 qed
 
 lemma star_inductl': "z \<squnion> x \<cdot> y \<le> y \<Longrightarrow> (star x) \<cdot> z \<le> y" 
 proof -
   assume "z \<squnion> x \<cdot> y \<le> y"
   hence "\<forall>i. x ^ i \<cdot> z \<le> y"
     by (simp add: power_inductl)
   hence "Sup{w. \<exists>i. w = x ^ i \<cdot> z} \<le> y"
     by (intro Sup_least, fast)
   hence "Sup{w. \<exists>i. w = x ^ i} \<cdot> z \<le> y"
     using Sup_distr Sup_le_iff by auto
   thus "(star x) \<cdot> z \<le> y"
     by (simp add: star_def_var1)
 qed
 
 lemma star_inductr': "z \<squnion> y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (star x) \<le> y" 
 proof -
   assume "z \<squnion> y \<cdot> x \<le> y"
   hence "\<forall>i. z \<cdot> x ^ i  \<le> y"
     by (simp add: power_inductr)
   hence "Sup{w. \<exists>i. w = z \<cdot> x ^ i} \<le> y"
     by (intro Sup_least, fast)
   hence "z \<cdot> Sup{w. \<exists>i. w = x ^ i} \<le> y"
     using Sup_distl Sup_le_iff by auto
   thus "z \<cdot> (star x) \<le> y"
     by (simp add: star_def_var1)
 qed
 
 sublocale ka: kleene_algebra "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)" star
   by standard (simp_all add: star_inductl' star_inductr')
 
 end
 
 text \<open>Distributive quantales are often assumed to satisfy infinite distributivity laws between
 joins and meets, but finite ones suffice for our purposes.\<close>
 
 class distributive_quantale = quantale + distrib_lattice 
 
 begin
 
 subclass bd_lattice_ordered_monoid
   by (standard, simp_all add: distrib_left)
 
 lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
 (* nitpick [expect=genuine]*)
 oops
 
 end 
 
 subsection \<open>Domain Quantales\<close>
 
 class domain_quantale = distributive_quantale +
   assumes rdv'': "(z \<sqinter> x \<cdot> \<top>) \<cdot> y = z \<cdot> y \<sqinter> x \<cdot> \<top>"  
 
 begin
 
 subclass domain_bdlo_monoid 
   by (standard, simp add: rdv'')
 
 end
 
 class range_quantale = distributive_quantale +
   assumes ldv'': "y \<cdot> (z \<sqinter> \<top> \<cdot> x) = y \<cdot> z \<sqinter> \<top> \<cdot> x"
 
 class boolean_quantale = quantale + complete_boolean_algebra
 
 begin
 
 subclass boolean_monoid
   by (standard, simp_all add: sup_distl)
 
 lemma "(1 \<sqinter> x \<cdot> \<top>) \<cdot> x = x"
 (*nitpick[expect=genuine]*)
 oops
 
 lemma "(1 \<sqinter> -(x \<cdot> \<top>)) \<cdot> x = \<bottom>"
 (*nitpick[expect=genuine]*)
 oops
 
 end
 
 subsection\<open>Boolean Domain Quantales\<close> 
 
 class domain_boolean_quantale = domain_quantale + boolean_quantale
 
 begin
 
 subclass domain_boolean_monoid
   by (standard, simp add: rdv'')
 
 lemma fbox_eq: "ad.fbox x q = Sup{d p |p. d p \<cdot> x \<le> x \<cdot> d q}"
   apply (rule Sup_eqI[symmetric])
   apply clarsimp
   using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
   apply clarsimp
   by (metis ad.fbox_def ad.fbox_demodalisation3 ad.fbox_simp da_a eq_refl)
 
 lemma fdia_eq: "ad.fdia x p = Inf{d q |q. x \<cdot> d p \<le> d q \<cdot> x}"
   apply (rule Inf_eqI[symmetric])
   apply clarsimp
   using ds.fdemodalisation2 apply auto[1]
   apply clarsimp
   by (metis ad.fd_eq_fdia ad.fdia_def da_a double_compl ds.fdemodalisation2 inf_bot_iff_le inf_compl_bot)
 
 text \<open>The specification statement can be defined explicitly.\<close>
 
 definition R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "R p q \<equiv> Sup{x. (d p) \<cdot> x \<le> x \<cdot> d q}"
 
 lemma "x \<le> R p q \<Longrightarrow> d p \<le> ad.fbox x (d q)"
 proof (simp add: R_def ad.kat_1_equiv ad.kat_2_equiv)
   assume "x \<le> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>}"
   hence "d p \<cdot> x \<cdot> a q \<le> d p \<cdot> Sup{x. d p \<cdot> x \<cdot> a q = \<bottom>} \<cdot> a q "
     using mult_double_iso by blast
   also have "... = Sup{d p \<cdot> x \<cdot> a q |x. d p \<cdot> x \<cdot> a q = \<bottom>}"
     apply (subst Sup_distl)
     apply (subst Sup_distr)
     apply clarsimp
     by metis
   also have "... = \<bottom>"
     by (auto simp: Sup_eqI)
   finally show ?thesis
     using ad.fbox_demodalisation3 ad.kat_3 ad.kat_4 le_bot by blast
 qed
 
 lemma "d p \<le> ad.fbox x (d q) \<Longrightarrow> x \<le> R p q"
   apply (simp add: R_def)
   apply (rule Sup_upper)
   apply simp
   using ad.fbox_demodalisation3 ad.fbox_simp apply auto[1]
 done
 
 end
 
 subsection\<open>Relational Model of Boolean Domain Quantales\<close>
 
 interpretation rel_dbq: domain_boolean_quantale
   \<open>(-)\<close> uminus \<open>(\<inter>)\<close> \<open>(\<subseteq>)\<close> \<open>(\<subset>)\<close> \<open>(\<union>)\<close> \<open>{}\<close> UNIV \<open>\<Inter>\<close> \<open>\<Union>\<close> Id \<open>(O)\<close>
   by standard auto
 
 
 subsection\<open>Modal Boolean Quantales\<close>
 
 class range_boolean_quantale = range_quantale + boolean_quantale
 
 begin
 
 subclass range_boolean_monoid
   by (standard, simp add: ldv'')
 
 lemma fbox_eq: "ar.bbox x (r q) = Sup{r p |p. x \<cdot> r p \<le> (r q) \<cdot> x}"
   apply (rule Sup_eqI[symmetric])
   apply clarsimp
   using ar.ardual.fbox_demodalisation3 ar.ardual.fbox_simp apply auto[1]
   apply clarsimp
   by (metis ar.ardual.fbox_def ar.ardual.fbox_demodalisation3 eq_refl rar_ar)
 
 lemma fdia_eq: "ar.bdia x (r p) = Inf{r q |q. (r p) \<cdot> x \<le> x \<cdot> r q}"
   apply (rule Inf_eqI[symmetric])
   apply clarsimp
   using ar.ars_r_def ar.ardual.fdemodalisation22 ar.ardual.kat_3_equiv_opp ar.ardual.kat_4_equiv_opp apply auto[1]
   apply clarsimp
   using ar.bdia_def ar.ardual.ds.fdemodalisation2 r_ar by fastforce
 
 end
 
 class modal_boolean_quantale = domain_boolean_quantale + range_boolean_quantale +
   assumes domrange' [simp]: "d (r x) = r x"
   and rangedom' [simp]: "r (d x) = d x"
 
 begin
 
 sublocale mka: modal_kleene_algebra "(\<squnion>)" "(\<cdot>)" 1 \<bottom> "(\<le>)" "(<)" star a ar
   by standard (simp_all add: ar_eq ad_eq)
 
 end
 
 no_notation fbox ("( |_] _)" [61,81] 82)
   and antidomain_semiringl_class.fbox ("( |_] _)" [61,81] 82)
 
 notation ad.fbox ("( |_] _)" [61,81] 82)
 
 subsection \<open>Recursion Rule\<close>
 
 lemma recursion: "mono (f :: 'a \<Rightarrow> 'a :: domain_boolean_quantale) \<Longrightarrow> 
   (\<And>x. d p \<le> |x] d q \<Longrightarrow> d p \<le> |f x] d q) \<Longrightarrow>  d p \<le> |lfp f] d q"
   apply (erule lfp_ordinal_induct [where f=f], simp)
   by (auto simp: ad.addual.ardual.fbox_demodalisation3 Sup_distr Sup_distl intro: Sup_mono)
 
 text \<open>We have already tested this rule in the context of test quantales~\cite{ArmstrongGS15}, which is based
 on a formalisation of quantales that is currently not in the AFP. The two theories will be merged as
 soon as the quantale is available in the AFP.\<close>
 
 end
diff --git a/thys/Automatic_Refinement/Lib/Misc.thy b/thys/Automatic_Refinement/Lib/Misc.thy
--- a/thys/Automatic_Refinement/Lib/Misc.thy
+++ b/thys/Automatic_Refinement/Lib/Misc.thy
@@ -1,4523 +1,4507 @@
 (*  Title:       Miscellaneous Definitions and Lemmas
     Author:      Peter Lammich <peter.lammich@uni-muenster.de>
     Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
                  Thomas Tuerk <tuerk@in.tum.de>
 *)
 
 (*
   CHANGELOG:
     2010-05-09: Removed AC, AI locales, they are superseeded by concepts
                   from OrderedGroups
     2010-09-22: Merges with ext/Aux
     2017-06-12: Added a bunch of lemmas from various other projects
 
 *)
 
 section \<open>Miscellaneous Definitions and Lemmas\<close>
 
 theory Misc
 imports Main
   "HOL-Library.Multiset"
   "HOL-ex.Quicksort"
   "HOL-Library.Option_ord"
   "HOL-Library.Infinite_Set"
   "HOL-Eisbach.Eisbach"
 begin
 text_raw \<open>\label{thy:Misc}\<close>
 
   
 subsection \<open>Isabelle Distribution Move Proposals\<close>  
 
 subsubsection \<open>Pure\<close>  
 lemma TERMI: "TERM x" unfolding Pure.term_def .
   
   
 subsubsection \<open>HOL\<close>  
 (* Stronger disjunction elimination rules. *)
 lemma disjE1: "\<lbrakk> P \<or> Q; P \<Longrightarrow> R; \<lbrakk>\<not>P;Q\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by metis
 lemma disjE2: "\<lbrakk> P \<or> Q; \<lbrakk>P; \<not>Q\<rbrakk> \<Longrightarrow> R; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
   by blast
 
 lemma imp_mp_iff[simp]: 
   "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b" 
   "(a \<longrightarrow> b) \<and> a \<longleftrightarrow> a \<and> b" (* is Inductive.imp_conj_iff, but not in simpset by default *)
   by blast+
     
 lemma atomize_Trueprop_eq[atomize]: "(Trueprop x \<equiv> Trueprop y) \<equiv> Trueprop (x=y)"
   apply rule
   apply (rule)
   apply (erule equal_elim_rule1)
   apply assumption
   apply (erule equal_elim_rule2)
   apply assumption
   apply simp
   done
   
 subsubsection \<open>Set\<close>    
 lemma inter_compl_diff_conv[simp]: "A \<inter> -B = A - B" by auto
 lemma pair_set_inverse[simp]: "{(a,b). P a b}\<inverse> = {(b,a). P a b}"
   by auto
 
 lemma card_doubleton_eq_2_iff[simp]: "card {a,b} = 2 \<longleftrightarrow> a\<noteq>b" by auto
 
     
 subsubsection \<open>List\<close>  
 (* TODO: Move, analogous to List.length_greater_0_conv *) 
 thm List.length_greater_0_conv  
 lemma length_ge_1_conv[iff]: "Suc 0 \<le> length l \<longleftrightarrow> l\<noteq>[]"
   by (cases l) auto
   
 \<comment> \<open>Obtains a list from the pointwise characterization of its elements\<close>
 lemma obtain_list_from_elements:
   assumes A: "\<forall>i<n. (\<exists>li. P li i)"
   obtains l where
     "length l = n"
     "\<forall>i<n. P (l!i) i"
 proof -
   from A have "\<exists>l. length l=n \<and> (\<forall>i<n. P (l!i) i)"
   proof (induct n)
     case 0 thus ?case by simp
   next
     case (Suc n)
     then obtain l where IH: "length l = n" "(\<forall>i<n. P(l!i) i)" by auto
     moreover from Suc.prems obtain ln where "P ln n" by auto
     ultimately have "length (l@[ln]) = Suc n" "(\<forall>i<Suc n. P((l@[ln])!i) i)"
       by (auto simp add: nth_append dest: less_antisym)
     thus ?case by blast
   qed
   thus ?thesis using that by (blast)
 qed
   
 lemma distinct_sorted_mono:
   assumes S: "sorted l"
   assumes D: "distinct l"
   assumes B: "i<j" "j<length l"
   shows "l!i < l!j"
 proof -
   from S B have "l!i \<le> l!j"
     by (simp add: sorted_iff_nth_mono)
   also from nth_eq_iff_index_eq[OF D] B have "l!i \<noteq> l!j"
     by auto
   finally show ?thesis .
 qed
 
 lemma distinct_sorted_strict_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i<l!j \<longleftrightarrow> i<j"
   using assms
   by (metis distinct_sorted_mono leI less_le_not_le
     order.strict_iff_order)
 
 lemma distinct_sorted_mono_iff:
   assumes "distinct l" "sorted l"
   assumes "i<length l" "j<length l"
   shows "l!i\<le>l!j \<longleftrightarrow> i\<le>j"
   by (metis assms distinct_sorted_strict_mono_iff leD le_less_linear)
   
     
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] 
 
   We could, analogously, declare rules for "map _ _ = _@_" as dest!,
   or use elim!, or declare the _conv-rule as simp
 *)  
    
 lemma map_eq_appendE: 
   assumes "map f ls = fl@fl'"
   obtains l l' where "ls=l@l'" and "map f l=fl" and  "map f l' = fl'"
   using assms  
 proof (induction fl arbitrary: ls thesis)
   case (Cons x xs)
     then obtain l ls' where [simp]: "ls = l#ls'" "f l = x" by force
     with Cons.prems(2) have "map f ls' = xs @ fl'" by simp
     from Cons.IH[OF _ this] guess ll ll' .
     with Cons.prems(1)[of "l#ll" ll'] show thesis by simp
 qed simp
 
 lemma map_eq_append_conv: "map f ls = fl@fl' \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: map_eq_appendE)
   
 lemmas append_eq_mapE = map_eq_appendE[OF sym]
   
 lemma append_eq_map_conv: "fl@fl' = map f ls \<longleftrightarrow> (\<exists>l l'. ls = l@l' \<and> map f l = fl \<and> map f l' = fl')"
   by (auto elim!: append_eq_mapE)
   
   
 lemma distinct_mapI: "distinct (map f l) \<Longrightarrow> distinct l"
   by (induct l) auto
     
 lemma map_distinct_upd_conv: 
   "\<lbrakk>i<length l; distinct l\<rbrakk> \<Longrightarrow> (map f l)[i := x] = map (f(l!i := x)) l"
   \<comment> \<open>Updating a mapped distinct list is equal to updating the 
     mapping function\<close>
   by (auto simp: nth_eq_iff_index_eq intro: nth_equalityI)
 
     
 lemma zip_inj: "\<lbrakk>length a = length b; length a' = length b'; zip a b = zip a' b'\<rbrakk> \<Longrightarrow> a=a' \<and> b=b'"
 proof (induct a b arbitrary: a' b' rule: list_induct2)
   case Nil
   then show ?case by (cases a'; cases b'; auto)
 next
   case (Cons x xs y ys)
   then show ?case by (cases a'; cases b'; auto)
 qed
 
 lemma zip_eq_zip_same_len[simp]:
   "\<lbrakk> length a = length b; length a' = length b' \<rbrakk> \<Longrightarrow>
   zip a b = zip a' b' \<longleftrightarrow> a=a' \<and> b=b'"
   by (auto dest: zip_inj)
     
     
 lemma upt_merge[simp]: "i\<le>j \<and> j\<le>k \<Longrightarrow> [i..<j]@[j..<k] = [i..<k]"
   by (metis le_Suc_ex upt_add_eq_append)
   
 (* Maybe this should go into List.thy, next to snoc_eq_iff_butlast *)
 lemma snoc_eq_iff_butlast':
   "(ys = xs @ [x]) \<longleftrightarrow> (ys \<noteq> [] \<and> butlast ys = xs \<and> last ys = x)"
   by auto
 
 (* Case distinction how two elements of a list can be related to each other *)
 lemma list_match_lel_lel:
   assumes "c1 @ qs # c2 = c1' @ qs' # c2'"
   obtains
     (left) c21' where "c1 = c1' @ qs' # c21'" "c2' = c21' @ qs # c2"
   | (center) "c1' = c1" "qs' = qs" "c2' = c2"
   | (right) c21 where "c1' = c1 @ qs # c21" "c2 = c21 @ qs' # c2'"
   using assms  
   apply (clarsimp simp: append_eq_append_conv2)  
   subgoal for us by (cases us) auto
   done    
     
 lemma xy_in_set_cases[consumes 2, case_names EQ XY YX]:
   assumes A: "x\<in>set l" "y\<in>set l"
   and C:
   "!!l1 l2. \<lbrakk> x=y; l=l1@y#l2 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@x#l2@y#l3 \<rbrakk> \<Longrightarrow> P"
   "!!l1 l2 l3. \<lbrakk> x\<noteq>y; l=l1@y#l2@x#l3 \<rbrakk> \<Longrightarrow> P"
   shows P
 proof (cases "x=y")
   case True with A(1) obtain l1 l2 where "l=l1@y#l2" by (blast dest: split_list)
   with C(1) True show ?thesis by blast
 next
   case False
   from A(1) obtain l1 l2 where S1: "l=l1@x#l2" by (blast dest: split_list)
   from A(2) obtain l1' l2' where S2: "l=l1'@y#l2'" by (blast dest: split_list)
   from S1 S2 have M: "l1@x#l2 = l1'@y#l2'" by simp
   thus P proof (cases rule: list_match_lel_lel[consumes 1, case_names 1 2 3])
     case (1 c) with S1 have "l=l1'@y#c@x#l2" by simp
     with C(3) False show ?thesis by blast
   next
     case 2 with False have False by blast
     thus ?thesis ..
   next
     case (3 c) with S1 have "l=l1@x#c@y#l2'" by simp
     with C(2) False show ?thesis by blast
   qed
 qed
     
     
 lemma list_e_eq_lel[simp]:
   "[e] = l1@e'#l2 \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   "l1@e'#l2 = [e] \<longleftrightarrow> l1=[] \<and> e'=e \<and> l2=[]"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 lemma list_ee_eq_leel[simp]:
   "([e1,e2] = l1@e1'#e2'#l2) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   "(l1@e1'#e2'#l2 = [e1,e2]) \<longleftrightarrow> (l1=[] \<and> e1=e1' \<and> e2=e2' \<and> l2=[])"
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 subsubsection \<open>Transitive Closure\<close>
 
 text \<open>A point-free induction rule for elements reachable from an initial set\<close>
 lemma rtrancl_reachable_induct[consumes 0, case_names base step]:
   assumes I0: "I \<subseteq> INV"
   assumes IS: "E``INV \<subseteq> INV"
   shows "E\<^sup>*``I \<subseteq> INV"
   by (metis I0 IS Image_closed_trancl Image_mono subset_refl)
   
 
 lemma acyclic_empty[simp, intro!]: "acyclic {}" by (unfold acyclic_def) auto
 
 lemma acyclic_union:
   "acyclic (A\<union>B) \<Longrightarrow> acyclic A"
   "acyclic (A\<union>B) \<Longrightarrow> acyclic B"
   by (metis Un_upper1 Un_upper2 acyclic_subset)+
     
-    
-    
-subsubsection \<open>Lattice Syntax\<close>    
-(* Providing the syntax in a locale makes it more usable, without polluting the global namespace*)    
-locale Lattice_Syntax begin
-  notation
-    bot ("\<bottom>") and
-    top ("\<top>") and
-    inf  (infixl "\<sqinter>" 70) and
-    sup  (infixl "\<squnion>" 65) and
-    Inf  ("\<Sqinter>_" [900] 900) and
-    Sup  ("\<Squnion>_" [900] 900)
-
-end
-    
-    
-    
+   
 text \<open>Here we provide a collection of miscellaneous definitions and helper lemmas\<close>
 
 subsection "Miscellaneous (1)"
 
 text \<open>This stuff is used in this theory itself, and thus occurs in first place or is simply not sorted into any other section of this theory.\<close>
 
 lemma IdD: "(a,b)\<in>Id \<Longrightarrow> a=b" by simp
 
 text \<open>Conversion Tag\<close>    
 definition [simp]: "CNV x y \<equiv> x=y"
 lemma CNV_I: "CNV x x" by simp
 lemma CNV_eqD: "CNV x y \<Longrightarrow> x=y" by simp
 lemma CNV_meqD: "CNV x y \<Longrightarrow> x\<equiv>y" by simp
    
 (* TODO: Move. Shouldn't this be detected by simproc? *)
 lemma ex_b_b_and_simp[simp]: "(\<exists>b. b \<and> Q b) \<longleftrightarrow> Q True" by auto
 lemma ex_b_not_b_and_simp[simp]: "(\<exists>b. \<not>b \<and> Q b) \<longleftrightarrow> Q False" by auto
     
 method repeat_all_new methods m = m;(repeat_all_new \<open>m\<close>)?
     
     
 subsubsection "AC-operators"
 
 text \<open>Locale to declare AC-laws as simplification rules\<close>
 locale Assoc =
   fixes f
   assumes assoc[simp]: "f (f x y) z = f x (f y z)"
 
 locale AC = Assoc +
   assumes commute[simp]: "f x y = f y x"
 
 lemma (in AC) left_commute[simp]: "f x (f y z) = f y (f x z)"
   by (simp only: assoc[symmetric]) simp
 
 lemmas (in AC) AC_simps = commute assoc left_commute
 
 text \<open>Locale to define functions from surjective, unique relations\<close>
 locale su_rel_fun =
   fixes F and f
   assumes unique: "\<lbrakk>(A,B)\<in>F; (A,B')\<in>F\<rbrakk> \<Longrightarrow> B=B'"
   assumes surjective: "\<lbrakk>!!B. (A,B)\<in>F \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   assumes f_def: "f A == THE B. (A,B)\<in>F"
 
 lemma (in su_rel_fun) repr1: "(A,f A)\<in>F" proof (unfold f_def)
   obtain B where "(A,B)\<in>F" by (rule surjective)
   with theI[where P="\<lambda>B. (A,B)\<in>F", OF this] show "(A, THE x. (A, x) \<in> F) \<in> F" by (blast intro: unique)
 qed
 
 lemma (in su_rel_fun) repr2: "(A,B)\<in>F \<Longrightarrow> B=f A" using repr1
   by (blast intro: unique)
 
 lemma (in su_rel_fun) repr: "(f A = B) = ((A,B)\<in>F)" using repr1 repr2
   by (blast)
 
     \<comment> \<open>Contract quantification over two variables to pair\<close>
 lemma Ex_prod_contract: "(\<exists>a b. P a b) \<longleftrightarrow> (\<exists>z. P (fst z) (snd z))"
   by auto
 
 lemma All_prod_contract: "(\<forall>a b. P a b) \<longleftrightarrow> (\<forall>z. P (fst z) (snd z))"
   by auto
 
 
 lemma nat_geq_1_eq_neqz: "x\<ge>1 \<longleftrightarrow> x\<noteq>(0::nat)"
   by auto
 
 lemma nat_in_between_eq:
   "(a<b \<and> b\<le>Suc a) \<longleftrightarrow> b = Suc a"
   "(a\<le>b \<and> b<Suc a) \<longleftrightarrow> b = a"
   by auto
 
 lemma Suc_n_minus_m_eq: "\<lbrakk> n\<ge>m; m>1 \<rbrakk> \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma Suc_to_right: "Suc n = m \<Longrightarrow> n = m - Suc 0" by simp
 lemma Suc_diff[simp]: "\<And>n m. n\<ge>m \<Longrightarrow> m\<ge>1 \<Longrightarrow> Suc (n - m) = n - (m - 1)"
   by simp
 
 lemma if_not_swap[simp]: "(if \<not>c then a else b) = (if c then b else a)" by auto
 lemma all_to_meta: "Trueprop (\<forall>a. P a) \<equiv> (\<And>a. P a)"
   apply rule
   by auto
 
 lemma imp_to_meta: "Trueprop (P\<longrightarrow>Q) \<equiv> (P\<Longrightarrow>Q)"
   apply rule
   by auto
 
 
 (* for some reason, there is no such rule in HOL *)
 lemma iffI2: "\<lbrakk>P \<Longrightarrow> Q; \<not> P \<Longrightarrow> \<not> Q\<rbrakk> \<Longrightarrow> P \<longleftrightarrow> Q"
 by metis
 
 lemma iffExI:
   "\<lbrakk> \<And>x. P x \<Longrightarrow> Q x; \<And>x. Q x \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> (\<exists>x. P x) \<longleftrightarrow> (\<exists>x. Q x)"
 by metis
 
 lemma bex2I[intro?]: "\<lbrakk> (a,b)\<in>S; (a,b)\<in>S \<Longrightarrow> P a b \<rbrakk> \<Longrightarrow> \<exists>a b. (a,b)\<in>S \<and> P a b"
   by blast
 
     
 (* TODO: Move lemma to HOL! *)  
 lemma cnv_conj_to_meta: "(P \<and> Q \<Longrightarrow> PROP X) \<equiv> (\<lbrakk>P;Q\<rbrakk> \<Longrightarrow> PROP X)"
   by (rule BNF_Fixpoint_Base.conj_imp_eq_imp_imp)
     
     
 
 subsection \<open>Sets\<close>
   lemma remove_subset: "x\<in>S \<Longrightarrow> S-{x} \<subset> S" by auto
 
   lemma subset_minus_empty: "A\<subseteq>B \<Longrightarrow> A-B = {}" by auto
 
   lemma insert_minus_eq: "x\<noteq>y \<Longrightarrow> insert x A - {y} = insert x (A - {y})" by auto
       
   lemma set_notEmptyE: "\<lbrakk>S\<noteq>{}; !!x. x\<in>S \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (metis equals0I)
 
   lemma subset_Collect_conv: "S \<subseteq> Collect P \<longleftrightarrow> (\<forall>x\<in>S. P x)"
     by auto
 
   lemma memb_imp_not_empty: "x\<in>S \<Longrightarrow> S\<noteq>{}"
     by auto
 
   lemma disjoint_mono: "\<lbrakk> a\<subseteq>a'; b\<subseteq>b'; a'\<inter>b'={} \<rbrakk> \<Longrightarrow> a\<inter>b={}" by auto
 
   lemma disjoint_alt_simp1: "A-B = A \<longleftrightarrow> A\<inter>B = {}" by auto
   lemma disjoint_alt_simp2: "A-B \<noteq> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
   lemma disjoint_alt_simp3: "A-B \<subset> A \<longleftrightarrow> A\<inter>B \<noteq> {}" by auto
 
   lemma disjointI[intro?]: "\<lbrakk> \<And>x. \<lbrakk>x\<in>a; x\<in>b\<rbrakk> \<Longrightarrow> False \<rbrakk> \<Longrightarrow> a\<inter>b={}"
     by auto
 
 
   lemmas set_simps = subset_minus_empty disjoint_alt_simp1 disjoint_alt_simp2 disjoint_alt_simp3 Un_absorb1 Un_absorb2
 
   lemma set_minus_singleton_eq: "x\<notin>X \<Longrightarrow> X-{x} = X"
     by auto
 
   lemma set_diff_diff_left: "A-B-C = A-(B\<union>C)"
     by auto
 
 
   lemma image_update[simp]: "x\<notin>A \<Longrightarrow> f(x:=n)`A = f`A"
     by auto
 
   lemma eq_or_mem_image_simp[simp]: "{f l |l. l = a \<or> l\<in>B} = insert (f a) {f l|l. l\<in>B}" by blast
       
   lemma set_union_code [code_unfold]:
     "set xs \<union> set ys = set (xs @ ys)"
     by auto
 
   lemma in_fst_imageE:
     assumes "x \<in> fst`S"
     obtains y where "(x,y)\<in>S"
     using assms by auto
 
   lemma in_snd_imageE:
     assumes "y \<in> snd`S"
     obtains x where "(x,y)\<in>S"
     using assms by auto
 
   lemma fst_image_mp: "\<lbrakk>fst`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> x\<in>B"
     by (metis Domain.DomainI fst_eq_Domain in_mono)
 
   lemma snd_image_mp: "\<lbrakk>snd`A \<subseteq> B; (x,y)\<in>A \<rbrakk> \<Longrightarrow> y\<in>B"
     by (metis Range.intros rev_subsetD snd_eq_Range)
 
   lemma inter_eq_subsetI: "\<lbrakk> S\<subseteq>S'; A\<inter>S' = B\<inter>S' \<rbrakk> \<Longrightarrow> A\<inter>S = B\<inter>S"
     by auto
 
 text \<open>
   Decompose general union over sum types.
 \<close>
 lemma Union_plus:
   "(\<Union> x \<in> A <+> B. f x) = (\<Union> a \<in> A. f (Inl a)) \<union> (\<Union>b \<in> B. f (Inr b))"
 by auto
 
 lemma Union_sum:
   "(\<Union>x. f (x::'a+'b)) = (\<Union>l. f (Inl l)) \<union> (\<Union>r. f (Inr r))"
   (is "?lhs = ?rhs")
 proof -
   have "?lhs = (\<Union>x \<in> UNIV <+> UNIV. f x)"
     by simp
   thus ?thesis
     by (simp only: Union_plus)
 qed
 
   
 
 
   subsubsection \<open>Finite Sets\<close>
 
   lemma card_1_singletonI: "\<lbrakk>finite S; card S = 1; x\<in>S\<rbrakk> \<Longrightarrow> S={x}"
   proof (safe, rule ccontr, goal_cases)
     case prems: (1 x')
     hence "finite (S-{x})" "S-{x} \<noteq> {}" by auto
     hence "card (S-{x}) \<noteq> 0" by auto
     moreover from prems(1-3) have "card (S-{x}) = 0" by auto
     ultimately have False by simp
     thus ?case ..
   qed
 
   lemma card_insert_disjoint': "\<lbrakk>finite A; x \<notin> A\<rbrakk> \<Longrightarrow> card (insert x A) - Suc 0 = card A"
     by (drule (1) card_insert_disjoint) auto
 
   lemma card_eq_UNIV[simp]: "card (S::'a::finite set) = card (UNIV::'a set) \<longleftrightarrow> S=UNIV"
   proof (auto)
     fix x
     assume A: "card S = card (UNIV::'a set)"
     show "x\<in>S" proof (rule ccontr)
       assume "x\<notin>S" hence "S\<subset>UNIV" by auto
       with psubset_card_mono[of UNIV S] have "card S < card (UNIV::'a set)" by auto
       with A show False by simp
     qed
   qed
 
   lemma card_eq_UNIV2[simp]: "card (UNIV::'a set) = card (S::'a::finite set) \<longleftrightarrow> S=UNIV"
     using card_eq_UNIV[of S] by metis
 
   lemma card_ge_UNIV[simp]: "card (UNIV::'a::finite set) \<le> card (S::'a set) \<longleftrightarrow> S=UNIV"
     using card_mono[of "UNIV::'a::finite set" S, simplified]
     by auto
 
   lemmas length_remdups_card = length_remdups_concat[of "[l]", simplified] for l
 
   lemma fs_contract: "fst ` { p | p. f (fst p) (snd p) \<in> S } = { a . \<exists>b. f a b \<in> S }"
     by (simp add: image_Collect)
 
 lemma finite_Collect: "finite S \<Longrightarrow> inj f \<Longrightarrow> finite {a. f a : S}"
 by(simp add: finite_vimageI vimage_def[symmetric])
 
   \<comment> \<open>Finite sets have an injective mapping to an initial segments of the
       natural numbers\<close>
   (* This lemma is also in the standard library (from Isabelle2009-1 on)
       as @{thm [source] Finite_Set.finite_imp_inj_to_nat_seg}. However, it is formulated with HOL's
       \<exists> there rather then with the meta-logic obtain *)
   lemma finite_imp_inj_to_nat_seg':
     fixes A :: "'a set"
     assumes A: "finite A"
     obtains f::"'a \<Rightarrow> nat" and n::"nat" where
       "f`A = {i. i<n}"
       "inj_on f A"
     by (metis A finite_imp_inj_to_nat_seg)
 
   lemma lists_of_len_fin1: "finite P \<Longrightarrow> finite (lists P \<inter> { l. length l = n })"
   proof (induct n)
     case 0 thus ?case by auto
   next
     case (Suc n)
     have "lists P \<inter> { l. length l = Suc n }
           = (\<lambda>(a,l). a#l) ` (P \<times> (lists P \<inter> {l. length l = n}))"
       apply auto
       apply (case_tac x)
       apply auto
       done
     moreover from Suc have "finite \<dots>" by auto
     ultimately show ?case by simp
   qed
 
   lemma lists_of_len_fin2: "finite P \<Longrightarrow> finite (lists P \<inter> { l. n = length l })"
   proof -
     assume A: "finite P"
     have S: "{ l. n = length l } = { l. length l = n }" by auto
     have "finite (lists P \<inter> { l. n = length l })
       \<longleftrightarrow> finite (lists P \<inter> { l. length l = n })"
       by (subst S) simp
 
     thus ?thesis using lists_of_len_fin1[OF A] by auto
   qed
 
   lemmas lists_of_len_fin = lists_of_len_fin1 lists_of_len_fin2
 
 
   (* Try (simp only: cset_fin_simps, fastforce intro: cset_fin_intros) when reasoning about finiteness of collected sets *)
   lemmas cset_fin_simps = Ex_prod_contract fs_contract[symmetric] image_Collect[symmetric]
   lemmas cset_fin_intros = finite_imageI finite_Collect inj_onI
 
 
 lemma Un_interval:
   fixes b1 :: "'a::linorder"
   assumes "b1\<le>b2" and "b2\<le>b3"
   shows "{ f i | i. b1\<le>i \<and> i<b2 } \<union> { f i | i. b2\<le>i \<and> i<b3 }
     = {f i | i. b1\<le>i \<and> i<b3}"
   using assms
   apply -
   apply rule
   apply safe []
   apply (rule_tac x=i in exI, auto) []
   apply (rule_tac x=i in exI, auto) []
   apply rule
   apply simp
   apply (elim exE, simp)
   apply (case_tac "i<b2")
   apply (rule disjI1)
   apply (rule_tac x=i in exI, auto) []
   apply (rule disjI2)
   apply (rule_tac x=i in exI, auto) []
   done
 
 text \<open>
   The standard library proves that a generalized union is finite
   if the index set is finite and if for every index the component
   set is itself finite. Conversely, we show that every component
   set must be finite when the union is finite.
 \<close>
 lemma finite_UNION_then_finite:
   "finite (\<Union>(B ` A)) \<Longrightarrow> a \<in> A \<Longrightarrow> finite (B a)"
 by (metis Set.set_insert UN_insert Un_infinite)
 
 lemma finite_if_eq_beyond_finite: "finite S \<Longrightarrow> finite {s. s - S = s' - S}"
 proof (rule finite_subset[where B="(\<lambda>s. s \<union> (s' - S)) ` Pow S"], clarsimp)
   fix s
   have "s = (s \<inter> S) \<union> (s - S)"
     by auto
   also assume "s - S = s' - S"
   finally show "s \<in> (\<lambda>s. s \<union> (s' - S)) ` Pow S" by blast
 qed blast
 
 lemma distinct_finite_subset:
   assumes "finite x"
   shows "finite {ys. set ys \<subseteq> x \<and> distinct ys}" (is "finite ?S")
 proof (rule finite_subset)
   from assms show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
     by clarsimp (metis distinct_card card_mono)
   from assms show "finite ..." by (rule finite_lists_length_le)
 qed
 
 lemma distinct_finite_set:
   shows "finite {ys. set ys = x \<and> distinct ys}" (is "finite ?S")
 proof (cases "finite x")
   case False hence "{ys. set ys = x} = {}" by auto
   thus ?thesis by simp
 next
   case True show ?thesis
   proof (rule finite_subset)
     show "?S \<subseteq> {ys. set ys \<subseteq> x \<and> length ys \<le> card x}"
       using distinct_card by force
     from True show "finite ..." by (rule finite_lists_length_le)
   qed
 qed
 
 lemma finite_set_image:
   assumes f: "finite (set ` A)"
   and dist: "\<And>xs. xs \<in> A \<Longrightarrow> distinct xs"
   shows "finite A"
 proof (rule finite_subset)
   from f show "finite (set -` (set ` A) \<inter> {xs. distinct xs})"
   proof (induct rule: finite_induct)
     case (insert x F)
     have "finite (set -` {x} \<inter> {xs. distinct xs})"
       apply (simp add: vimage_def)
       by (metis Collect_conj_eq distinct_finite_set)
     with insert show ?case
       apply (subst vimage_insert)
       apply (subst Int_Un_distrib2)
       apply (rule finite_UnI)
         apply simp_all
       done
   qed simp
   moreover from dist show "A \<subseteq> ..."
     by (auto simp add: vimage_image_eq)
 qed
 
 
 subsubsection \<open>Infinite Set\<close>
 lemma INFM_nat_inductI:
   assumes P0: "P (0::nat)"
   assumes PS: "\<And>i. P i \<Longrightarrow> \<exists>j>i. P j \<and> Q j"
   shows "\<exists>\<^sub>\<infinity>i. Q i"
 proof -
   have "\<forall>i. \<exists>j>i. P j \<and> Q j" proof
     fix i
     show "\<exists>j>i. P j \<and> Q j"
       apply (induction i)
       using PS[OF P0] apply auto []
       by (metis PS Suc_lessI)
   qed
   thus ?thesis unfolding INFM_nat by blast
 qed
 
 subsection \<open>Functions\<close>
 
 lemma fun_neq_ext_iff: "m\<noteq>m' \<longleftrightarrow> (\<exists>x. m x \<noteq> m' x)" by auto  
 
 definition "inv_on f A x == SOME y. y\<in>A \<and> f y = x"
 
 lemma inv_on_f_f[simp]: "\<lbrakk>inj_on f A; x\<in>A\<rbrakk> \<Longrightarrow> inv_on f A (f x) = x"
   by (auto simp add: inv_on_def inj_on_def)
 
 lemma f_inv_on_f: "\<lbrakk> y\<in>f`A \<rbrakk> \<Longrightarrow> f (inv_on f A y) = y"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inv_on_f_range: "\<lbrakk> y \<in> f`A \<rbrakk> \<Longrightarrow> inv_on f A y \<in> A"
   by (auto simp add: inv_on_def intro: someI2)
 
 lemma inj_on_map_inv_f [simp]: "\<lbrakk>set l \<subseteq> A; inj_on f A\<rbrakk> \<Longrightarrow> map (inv_on f A) (map f l) = l"
   apply (simp)
   apply (induct l)
   apply auto
   done
 
 lemma comp_cong_right: "x = y \<Longrightarrow> f o x = f o y" by (simp)
 lemma comp_cong_left: "x = y \<Longrightarrow> x o f = y o f" by (simp)
 
 lemma fun_comp_eq_conv: "f o g = fg \<longleftrightarrow> (\<forall>x. f (g x) = fg x)"
   by auto
 
 abbreviation comp2 (infixl "oo" 55) where "f oo g \<equiv> \<lambda>x. f o (g x)"
 abbreviation comp3 (infixl "ooo" 55) where "f ooo g \<equiv> \<lambda>x. f oo (g x)"
 
 notation
   comp2  (infixl "\<circ>\<circ>" 55) and
   comp3  (infixl "\<circ>\<circ>\<circ>" 55)
 
 definition [code_unfold, simp]: "swap_args2 f x y \<equiv> f y x"
   
 
 subsection \<open>Multisets\<close>
 
 (*
   The following is a syntax extension for multisets. Unfortunately, it depends on a change in the Library/Multiset.thy, so it is commented out here, until it will be incorporated
   into Library/Multiset.thy by its maintainers.
 
   The required change in Library/Multiset.thy is removing the syntax for single:
      - single :: "'a => 'a multiset"    ("{#_#}")
      + single :: "'a => 'a multiset"
 
   And adding the following translations instead:
 
      + syntax
      + "_multiset" :: "args \<Rightarrow> 'a multiset" ("{#(_)#}")
 
      + translations
      +   "{#x, xs#}" == "{#x#} + {#xs#}"
      +   "{# x #}" == "single x"
 
   This translates "{# \<dots> #}" into a sum of singletons, that is parenthesized to the right. ?? Can we also achieve left-parenthesizing ??
 
 *)
 
 
   (* Let's try what happens if declaring AC-rules for multiset union as simp-rules *)
 (*declare union_ac[simp] -- don't do it !*)
 
 
 lemma count_mset_set_finite_iff:
   "finite S \<Longrightarrow> count (mset_set S) a = (if a \<in> S then 1 else 0)"
   by simp
 
 lemma ex_Melem_conv: "(\<exists>x. x \<in># A) = (A \<noteq> {#})"
   by (simp add: ex_in_conv)
 
 subsubsection \<open>Count\<close>
         lemma count_ne_remove: "\<lbrakk> x ~= t\<rbrakk> \<Longrightarrow> count S x = count (S-{#t#}) x"
           by (auto)
   lemma mset_empty_count[simp]: "(\<forall>p. count M p = 0) = (M={#})"
     by (auto simp add: multiset_eq_iff)
 
 subsubsection \<open>Union, difference and intersection\<close>
 
   lemma size_diff_se: "t \<in># S \<Longrightarrow> size S = size (S - {#t#}) + 1" proof (unfold size_multiset_overloaded_eq)
                 let ?SIZE = "sum (count S) (set_mset S)"
                 assume A: "t \<in># S"
                 from A have SPLITPRE: "finite (set_mset S) & {t}\<subseteq>(set_mset S)" by auto
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + sum (count S) {t}" by (blast dest: sum.subset_diff)
                 hence "?SIZE = sum (count S) (set_mset S - {t}) + count (S) t" by auto
                 moreover with A have "count S t = count (S-{#t#}) t + 1" by auto
                 ultimately have D: "?SIZE = sum (count S) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (arith)
                 moreover have "sum (count S) (set_mset S - {t}) = sum (count (S-{#t#})) (set_mset S - {t})" proof -
                         have "\<forall>x\<in>(set_mset S - {t}). count S x = count (S-{#t#}) x" by (auto iff add: count_ne_remove)
                         thus ?thesis by simp
                 qed
                 ultimately have D: "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + count (S-{#t#}) t + 1" by (simp)
                 moreover
                 { assume CASE: "t \<notin># S - {#t#}"
                         from CASE have "set_mset S - {t} = set_mset (S - {#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         with CASE D have "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1"
                           by (simp add: not_in_iff)
                 }
                 moreover
                 { assume CASE: "t \<in># S - {#t#}"
                         from CASE have "t \<in># S" by (rule in_diffD)
                         with CASE have 1: "set_mset S = set_mset (S-{#t#})"
                           by (auto simp add: in_diff_count split: if_splits)
                         moreover from D have "?SIZE = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t} + 1" by simp
                         moreover from SPLITPRE sum.subset_diff have "sum (count (S-{#t#})) (set_mset S) = sum (count (S-{#t#})) (set_mset S - {t}) + sum (count (S-{#t#})) {t}" by (blast)
                         ultimately have "?SIZE = sum (count (S-{#t#})) (set_mset (S-{#t#})) + 1" by simp
                 }
                 ultimately show "?SIZE = sum (count (S-{#t#})) (set_mset (S - {#t#})) + 1" by blast
         qed
 
   (* TODO: Check whether this proof can be done simpler *)
   lemma mset_union_diff_comm: "t \<in># S \<Longrightarrow> T + (S - {#t#}) = (T + S) - {#t#}" proof -
     assume "t \<in># S"
     then obtain S' where S: "S = add_mset t S'"
       by (metis insert_DiffM)
     then show ?thesis
       by auto
   qed
 
 (*  lemma mset_diff_diff_left: "A-B-C = A-((B::'a multiset)+C)" proof -
     have "\<forall>e . count (A-B-C) e = count (A-(B+C)) e" by auto
     thus ?thesis by (simp add: multiset_eq_conv_count_eq)
   qed
 
   lemma mset_diff_commute: "A-B-C = A-C-(B::'a multiset)" proof -
     have "A-B-C = A-(B+C)" by (simp add: mset_diff_diff_left)
     also have "\<dots> = A-(C+B)" by (simp add: union_commute)
     thus ?thesis by (simp add: mset_diff_diff_left)
   qed
 
   lemma mset_diff_same_empty[simp]: "(S::'a multiset) - S = {#}"
   proof -
     have "\<forall>e . count (S-S) e = 0" by auto
     hence "\<forall>e . ~ (e : set_mset (S-S))" by auto
     hence "set_mset (S-S) = {}" by blast
     thus ?thesis by (auto)
   qed
 *)
     
   lemma mset_right_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># B)\<rbrakk> \<Longrightarrow> a\<in>#A"
     by (simp)
   lemma mset_left_cancel_union: "\<lbrakk>a \<in># A+B; ~(a \<in># A)\<rbrakk> \<Longrightarrow> a\<in>#B"
     by (simp)
 
   lemmas mset_cancel_union = mset_right_cancel_union mset_left_cancel_union
 
   lemma mset_right_cancel_elem: "\<lbrakk>a \<in># A+{#b#}; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemma mset_left_cancel_elem: "\<lbrakk>a \<in># {#b#}+A; a~=b\<rbrakk> \<Longrightarrow> a\<in>#A"
     by simp
 
   lemmas mset_cancel_elem = mset_right_cancel_elem mset_left_cancel_elem
 
   lemma mset_diff_cancel1elem[simp]: "~(a \<in># B) \<Longrightarrow> {#a#}-B = {#a#}"
     by (auto simp add: not_in_iff intro!: multiset_eqI)
 
 (*  lemma diff_union_inverse[simp]: "A + B - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 
   lemma diff_union_inverse2[simp]: "B + A - B = (A::'a multiset)"
     by (auto iff add: multiset_eq_conv_count_eq)
 *)
   (*lemma union_diff_assoc_se2: "t \<in># A \<Longrightarrow> (A+B)-{#t#} = (A-{#t#}) + B"
     by (auto iff add: multiset_eq_conv_count_eq)
   lemmas union_diff_assoc_se = union_diff_assoc_se1 union_diff_assoc_se2*)
 
         lemma union_diff_assoc: "C-B={#} \<Longrightarrow> (A+B)-C = A + (B-C)"
           by (simp add: multiset_eq_iff)
 
   lemmas mset_neutral_cancel1 = union_left_cancel[where N="{#}", simplified] union_right_cancel[where N="{#}", simplified]
   declare mset_neutral_cancel1[simp]
 
   lemma mset_union_2_elem: "{#a, b#} = add_mset c M \<Longrightarrow> {#a#}=M & b=c | a=c & {#b#}=M"
     by (auto simp: add_eq_conv_diff)
 
   lemma mset_un_cases[cases set, case_names left right]:
     "\<lbrakk>a \<in># A + B; a \<in># A \<Longrightarrow> P; a \<in># B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (auto)
 
   lemma mset_unplusm_dist_cases[cases set, case_names left right]:
     assumes A: "{#s#}+A = B+C"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
   proof -
     from A[symmetric] have "s \<in># B+C" by simp
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence 1: "B={#s#}+(B-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+((B-{#s#})+C)" by (simp add: union_ac)
       hence 2: "A = (B-{#s#})+C" by (simp)
       from L[OF 1 2] show ?thesis .
     next
       case right hence 1: "C={#s#}+(C-{#s#})" by simp
       with A have "{#s#}+A = {#s#}+(B+(C-{#s#}))" by (simp add: union_ac)
       hence 2: "A = B+(C-{#s#})" by (simp)
       from R[OF 1 2] show ?thesis .
     qed
   qed
 
   lemma mset_unplusm_dist_cases2[cases set, case_names left right]:
     assumes A: "B+C = {#s#}+A"
     assumes L: "\<lbrakk>B={#s#}+(B-{#s#}); A=(B-{#s#})+C\<rbrakk> \<Longrightarrow> P"
     assumes R: "\<lbrakk>C={#s#}+(C-{#s#}); A=B+(C-{#s#})\<rbrakk> \<Longrightarrow> P"
     shows P
     using mset_unplusm_dist_cases[OF A[symmetric]] L R by blast
 
   lemma mset_single_cases[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'={#s#}+(c'-{#s#}); c={#r'#}+(c-{#r'#}); c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume CASE: "s=r'"
       with A have "c=c'" by simp
       with CASE CASES have ?thesis by auto
     } moreover {
       assume CASE: "s\<noteq>r'"
       have "s \<in># {#s#}+c" by simp
       with A have "s \<in># {#r'#}+c'" by simp
       with CASE have "s \<in># c'" by simp
       hence 1: "c' = {#s#} + (c' - {#s#})" by simp
       with A have "{#s#}+c = {#s#}+({#r'#}+(c' - {#s#}))" by (auto simp add: union_ac)
       hence 2: "c={#r'#}+(c' - {#s#})" by (auto)
       hence 3: "c-{#r'#} = (c' - {#s#})" by auto
       from 1 2 3 CASES have ?thesis by auto
     } ultimately show ?thesis by blast
   qed
 
   lemma mset_single_cases'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'={#s#}+cc; c={#r'#}+cc; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases)
 
   lemma mset_single_cases2[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "\<lbrakk>c'=(c'-{#s#})+{#s#}; c=(c-{#r'#})+{#r'#}; c-{#r'#} = c'-{#s#} \<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     from A have "add_mset s c = add_mset r' c'" by (simp add: union_ac)
     thus ?thesis using CASES by (cases rule: mset_single_cases) simp_all
   qed
 
   lemma mset_single_cases2'[cases set, case_names loc env]:
     assumes A: "add_mset s c = add_mset r' c'"
     assumes CASES: "\<lbrakk>s=r'; c=c'\<rbrakk> \<Longrightarrow> P" "!!cc. \<lbrakk>c'=cc+{#s#}; c=cc+{#r'#}; c'-{#s#}=cc; c-{#r'#}=cc\<rbrakk> \<Longrightarrow> P"
     shows "P"
     using A  CASES by (auto elim!: mset_single_cases2)
 
   lemma mset_un_single_un_cases [consumes 1, case_names left right]:
     assumes A: "add_mset a A = B + C"
       and CASES: "a \<in># B \<Longrightarrow> A = (B - {#a#}) + C \<Longrightarrow> P"
         "a \<in># C \<Longrightarrow> A = B + (C - {#a#}) \<Longrightarrow> P" shows "P"
   proof -
     have "a \<in># A+{#a#}" by simp
     with A have "a \<in># B+C" by auto
     thus ?thesis proof (cases rule: mset_un_cases)
       case left hence "B=B-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = (B-{#a#})+C+{#a#}" by (auto simp add: union_ac)
       hence "A=(B-{#a#})+C" by simp
       with CASES(1)[OF left] show ?thesis by blast
     next
       case right hence "C=C-{#a#}+{#a#}" by auto
       with A have "A+{#a#} = B+(C-{#a#})+{#a#}" by (auto simp add: union_ac)
       hence "A=B+(C-{#a#})" by simp
       with CASES(2)[OF right] show ?thesis by blast
     qed
   qed
 
       (* TODO: Can this proof be done more automatically ? *)
   lemma mset_distrib[consumes 1, case_names dist]: assumes A: "(A::'a multiset)+B = M+N" "!!Am An Bm Bn. \<lbrakk>A=Am+An; B=Bm+Bn; M=Am+Bm; N=An+Bn\<rbrakk> \<Longrightarrow> P" shows "P"
   proof -
     have BN_MA: "B - N = M - A"
       by (metis (no_types) add_diff_cancel_right assms(1) union_commute)
     have H: "A = A\<inter># C + (A - C) \<inter># D" if "A + B = C + D" for A B C D :: "'a multiset"
       by (metis add.commute diff_intersect_left_idem mset_subset_eq_add_left subset_eq_diff_conv
           subset_mset.add_diff_inverse subset_mset.inf_absorb1 subset_mset.inf_le1 that)
     have A': "A = A\<inter># M + (A - M) \<inter># N"
       using A(1) H by blast
     moreover have B': "B = (B - N) \<inter># M + B\<inter># N"
       using A(1) H[of B A N M] by (auto simp: ac_simps)
     moreover have "M = A \<inter># M + (B - N) \<inter># M"
       using H[of M N A B] BN_MA[symmetric] A(1) by (metis (no_types) diff_intersect_left_idem
           diff_union_cancelR multiset_inter_commute subset_mset.diff_add subset_mset.inf.cobounded1
           union_commute)
     moreover have "N = (A - M) \<inter># N + B \<inter># N"
       by (metis A' assms(1) diff_union_cancelL inter_union_distrib_left inter_union_distrib_right
           mset_subset_eq_multiset_union_diff_commute subset_mset.inf.cobounded1 subset_mset.inf.commute)
     ultimately show P
       using A(2) by blast
   qed
 
 
 subsubsection \<open>Singleton multisets\<close>
 
 lemma mset_size_le1_cases[case_names empty singleton,consumes 1]: "\<lbrakk> size M \<le> Suc 0; M={#} \<Longrightarrow> P; !!m. M={#m#} \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by (cases M) auto
 
 lemma diff_union_single_conv2: "a \<in># J \<Longrightarrow> J + I - {#a#} = (J - {#a#}) + I"
   by simp
 
 lemmas diff_union_single_convs = diff_union_single_conv diff_union_single_conv2
 
 lemma mset_contains_eq: "(m \<in># M) = ({#m#}+(M-{#m#})=M)"
   using diff_single_trivial by fastforce
 
 
 subsubsection \<open>Pointwise ordering\<close>
 
 
   (*declare mset_le_trans[trans] Seems to be in there now. Why is this not done in Multiset.thy or order-class ? *)
 
   lemma mset_le_incr_right1: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b+c" using mset_subset_eq_mono_add[of a b "{#}" c, simplified] .
   lemma mset_le_incr_right2: "a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#c+b" using mset_le_incr_right1
     by (auto simp add: union_commute)
   lemmas mset_le_incr_right = mset_le_incr_right1 mset_le_incr_right2
 
   lemma mset_le_decr_left1: "a+c\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_incr_right1 mset_subset_eq_mono_add_right_cancel
     by blast
   lemma mset_le_decr_left2: "c+a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b" using mset_le_decr_left1
     by (auto simp add: union_ac)
   lemma mset_le_add_mset_decr_left1: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> a\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
   lemma mset_le_add_mset_decr_left2: "add_mset c a\<subseteq>#(b::'a multiset) \<Longrightarrow> {#c#}\<subseteq>#b"
     by (simp add: mset_subset_eq_insertD subset_mset.dual_order.strict_implies_order)
 
   lemmas mset_le_decr_left = mset_le_decr_left1 mset_le_decr_left2 mset_le_add_mset_decr_left1
     mset_le_add_mset_decr_left2
 
   lemma mset_le_subtract: "A\<subseteq>#B \<Longrightarrow> A-C \<subseteq># B-(C::'a multiset)"
     apply (unfold subseteq_mset_def count_diff)
     apply clarify
     apply (subgoal_tac "count A a \<le> count B a")
     apply arith
     apply simp
     done
 
   lemma mset_union_subset: "A+B \<subseteq># C \<Longrightarrow> A\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_add_mset: "add_mset x B \<subseteq># C \<Longrightarrow> {#x#}\<subseteq>#C \<and> B\<subseteq>#(C::'a multiset)"
     by (auto dest: mset_le_decr_left)
 
   lemma mset_le_subtract_left: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-A \<and> A\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "A"] mset_union_subset)
   lemma mset_le_subtract_right: "A+B \<subseteq># (X::'a multiset) \<Longrightarrow> A \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "A+B" "X" "B"] mset_union_subset)
 
   lemma mset_le_subtract_add_mset_left: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> B \<subseteq># X-{#x#} \<and> {#x#}\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "{#x#}"] mset_le_add_mset)
 
   lemma mset_le_subtract_add_mset_right: "add_mset x B \<subseteq># (X::'a multiset) \<Longrightarrow> {#x#} \<subseteq># X-B \<and> B\<subseteq>#X"
     by (auto dest: mset_le_subtract[of "add_mset x B" "X" "B"] mset_le_add_mset)
 
   lemma mset_le_addE: "\<lbrakk> xs \<subseteq># (ys::'a multiset); !!zs. ys=xs+zs \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" using mset_subset_eq_exists_conv
     by blast
 
   declare subset_mset.diff_add[simp, intro]
 
   lemma mset_2dist2_cases:
     assumes A: "{#a#}+{#b#} \<subseteq># A+B"
     assumes CASES: "{#a#}+{#b#} \<subseteq># A \<Longrightarrow> P" "{#a#}+{#b#} \<subseteq># B \<Longrightarrow> P" "\<lbrakk>a \<in># A; b \<in># B\<rbrakk> \<Longrightarrow> P" "\<lbrakk>a \<in># B; b \<in># A\<rbrakk> \<Longrightarrow> P"
     shows "P"
   proof -
     { assume C: "a \<in># A" "b \<in># A-{#a#}"
       with mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "A-{#a#}"] have "{#a#}+{#b#} \<subseteq># A" by auto
     } moreover {
       assume C: "a \<in># A" "\<not> (b \<in># A-{#a#})"
       with A have "b \<in># B"
         by (metis diff_union_single_conv2 mset_le_subtract_left mset_subset_eq_insertD mset_un_cases)
     } moreover {
       assume C: "\<not> (a \<in># A)" "b \<in># B-{#a#}"
       with A have "a \<in># B"
         by (auto dest: mset_subset_eqD)
        with C mset_subset_eq_mono_add[of "{#a#}" "{#a#}" "{#b#}" "B-{#a#}"] have "{#a#}+{#b#} \<subseteq># B" by auto
     } moreover {
       assume C: "\<not> (a \<in># A)" "\<not> (b \<in># B-{#a#})"
       with A have "a \<in># B \<and> b \<in># A"
         apply (intro conjI)
          apply (auto dest!: mset_subset_eq_insertD simp: insert_union_subset_iff; fail)[]
         by (metis mset_diff_cancel1elem mset_le_subtract_left multiset_diff_union_assoc
             single_subset_iff subset_eq_diff_conv)
     } ultimately show P using CASES by blast
   qed
 
 
   lemma mset_union_subset_s: "{#a#}+B \<subseteq># C \<Longrightarrow> a \<in># C \<and> B \<subseteq># C"
     by (drule mset_union_subset) simp
 
   (* TODO: Check which of these lemmas are already introduced by order-classes ! *)
 
 
   lemma mset_le_single_cases[consumes 1, case_names empty singleton]: "\<lbrakk>M\<subseteq>#{#a#}; M={#} \<Longrightarrow> P; M={#a#} \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (induct M) auto
 
   lemma mset_le_distrib[consumes 1, case_names dist]: "\<lbrakk>(X::'a multiset)\<subseteq>#A+B; !!Xa Xb. \<lbrakk>X=Xa+Xb; Xa\<subseteq>#A; Xb\<subseteq>#B\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto elim!: mset_le_addE mset_distrib)
 
 lemma mset_le_mono_add_single: "\<lbrakk>a \<in># ys; b \<in># ws\<rbrakk> \<Longrightarrow> {#a#} + {#b#} \<subseteq># ys + ws"
   by (meson mset_subset_eq_mono_add single_subset_iff)
 
   lemma mset_size1elem: "\<lbrakk>size P \<le> 1; q \<in># P\<rbrakk> \<Longrightarrow> P={#q#}"
     by (auto elim: mset_size_le1_cases)
   lemma mset_size2elem: "\<lbrakk>size P \<le> 2; {#q#}+{#q'#} \<subseteq># P\<rbrakk> \<Longrightarrow> P={#q#}+{#q'#}"
     by (auto elim: mset_le_addE)
 
 
 subsubsection \<open>Image under function\<close>
 
 notation image_mset (infixr "`#" 90)
 
 lemma mset_map_split_orig: "!!M1 M2. \<lbrakk>f `# P = M1+M2; !!P1 P2. \<lbrakk>P=P1+P2; f `# P1 = M1; f `# P2 = M2\<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
   by (induct P) (force elim!: mset_un_single_un_cases)+
 
 lemma mset_map_id: "\<lbrakk>!!x. f (g x) = x\<rbrakk> \<Longrightarrow> f `# g `# X = X"
   by (induct X) auto
 
 text \<open>The following is a very specialized lemma. Intuitively, it splits the original multiset
   by a splitting of some pointwise supermultiset of its image.
 
   Application:
   This lemma came in handy when proving the correctness of a constraint system that collects at most k sized submultisets of the sets of spawned threads.
 \<close>
 lemma mset_map_split_orig_le: assumes A: "f `# P \<subseteq># M1+M2" and EX: "!!P1 P2. \<lbrakk>P=P1+P2; f `# P1 \<subseteq># M1; f `# P2 \<subseteq># M2\<rbrakk> \<Longrightarrow> Q" shows "Q"
   using A EX by (auto elim: mset_le_distrib mset_map_split_orig)
 
 
 subsection \<open>Lists\<close>
 
 
 lemma len_greater_imp_nonempty[simp]: "length l > x \<Longrightarrow> l\<noteq>[]"
   by auto
 
 lemma list_take_induct_tl2:
   "\<lbrakk>length xs = length ys; \<forall>n<length xs. P (ys ! n) (xs ! n)\<rbrakk>
     \<Longrightarrow> \<forall>n < length (tl xs). P ((tl ys) ! n) ((tl xs) ! n)"
 by (induct xs ys rule: list_induct2) auto
 
 lemma not_distinct_split_distinct:
   assumes "\<not> distinct xs"
   obtains y ys zs where "distinct ys" "y \<in> set ys" "xs = ys@[y]@zs"
 using assms
 proof (induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs) thus ?case by (cases "distinct xs") auto
 qed
 
 lemma distinct_length_le:
   assumes d: "distinct ys"
   and eq: "set ys = set xs"
   shows "length ys \<le> length xs"
 proof -
   from d have "length ys = card (set ys)" by (simp add: distinct_card)
   also from eq List.card_set have "card (set ys) = length (remdups xs)" by simp
   also have "... \<le> length xs" by simp
   finally show ?thesis .
 qed
 
 lemma find_SomeD:
   "List.find P xs = Some x \<Longrightarrow> P x"
   "List.find P xs = Some x \<Longrightarrow> x\<in>set xs"
   by (auto simp add: find_Some_iff)
 
 lemma in_hd_or_tl_conv[simp]: "l\<noteq>[] \<Longrightarrow> x=hd l \<or> x\<in>set (tl l) \<longleftrightarrow> x\<in>set l"
   by (cases l) auto
 
 lemma length_dropWhile_takeWhile:
   assumes "x < length (dropWhile P xs)"
   shows "x + length (takeWhile P xs) < length xs"
   using assms
   by (induct xs) auto
 
 text \<open>Elim-version of @{thm neq_Nil_conv}.\<close>  
 lemma neq_NilE: 
   assumes "l\<noteq>[]"
   obtains x xs where "l=x#xs" 
   using assms by (metis list.exhaust)
 
     
 lemma length_Suc_rev_conv: "length xs = Suc n \<longleftrightarrow> (\<exists>ys y. xs=ys@[y] \<and> length ys = n)"
   by (cases xs rule: rev_cases) auto
 
     
 subsubsection \<open>List Destructors\<close>
 lemma not_hd_in_tl:
   "x \<noteq> hd xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set (tl xs)"
 by (induct xs) simp_all
 
 lemma distinct_hd_tl:
   "distinct xs \<Longrightarrow> x = hd xs \<Longrightarrow> x \<notin> set (tl (xs))"
 by (induct xs) simp_all
 
 lemma in_set_tlD: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
 by (induct xs) simp_all
 
 lemma nth_tl: "xs \<noteq> [] \<Longrightarrow> tl xs ! n = xs ! Suc n"
 by (induct xs) simp_all
 
 lemma tl_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (tl xs) \<subseteq> A"
 by (metis in_set_tlD rev_subsetD subsetI)
 
 lemma tl_last:
   "tl xs \<noteq> [] \<Longrightarrow> last xs = last (tl xs)"
 by (induct xs) simp_all
 
 lemma tl_obtain_elem:
   assumes "xs \<noteq> []" "tl xs = []"
   obtains e where "xs = [e]"
 using assms
 by (induct xs rule: list_nonempty_induct) simp_all
 
 lemma butlast_subset:
   "xs \<noteq> [] \<Longrightarrow> set xs \<subseteq> A \<Longrightarrow> set (butlast xs) \<subseteq> A"
 by (metis in_set_butlastD rev_subsetD subsetI)
 
 lemma butlast_rev_tl:
   "xs \<noteq> [] \<Longrightarrow> butlast (rev xs) = rev (tl xs)"
 by (induct xs rule: rev_induct) simp_all
 
 lemma hd_butlast:
   "length xs > 1 \<Longrightarrow> hd (butlast xs) = hd xs"
 by (induct xs) simp_all
 
 lemma butlast_upd_last_eq[simp]: "length l \<ge> 2 \<Longrightarrow>
   (butlast l) [ length l - 2 := x ] = take (length l - 2) l @ [x]"
   apply (case_tac l rule: rev_cases)
   apply simp
   apply simp
   apply (case_tac ys rule: rev_cases)
   apply simp
   apply simp
   done
 
 lemma distinct_butlast_swap[simp]: 
   "distinct pq \<Longrightarrow> distinct (butlast (pq[i := last pq]))"
   apply (cases pq rule: rev_cases)
   apply (auto simp: list_update_append distinct_list_update split: nat.split)
   done
 
 subsubsection \<open>Splitting list according to structure of other list\<close>
 context begin
 private definition "SPLIT_ACCORDING m l \<equiv> length l = length m"
 
 private lemma SPLIT_ACCORDINGE: 
   assumes "length m = length l"
   obtains "SPLIT_ACCORDING m l"
   unfolding SPLIT_ACCORDING_def using assms by auto
 
 private lemma SPLIT_ACCORDING_simp:
   "SPLIT_ACCORDING m (l1@l2) \<longleftrightarrow> (\<exists>m1 m2. m=m1@m2 \<and> SPLIT_ACCORDING m1 l1 \<and> SPLIT_ACCORDING m2 l2)"
   "SPLIT_ACCORDING m (x#l') \<longleftrightarrow> (\<exists>y m'. m=y#m' \<and> SPLIT_ACCORDING m' l')"
   apply (fastforce simp: SPLIT_ACCORDING_def intro: exI[where x = "take (length l1) m"] exI[where x = "drop (length l1) m"])
   apply (cases m;auto simp: SPLIT_ACCORDING_def)
   done
 
 text \<open>Split structure of list @{term m} according to structure of list @{term l}.\<close>
 method split_list_according for m :: "'a list" and l :: "'b list" =
   (rule SPLIT_ACCORDINGE[of m l],
     (simp; fail),
     ( simp only: SPLIT_ACCORDING_simp,
       elim exE conjE, 
       simp only: SPLIT_ACCORDING_def
     )
   ) 
 end
   
     
     
 subsubsection \<open>\<open>list_all2\<close>\<close>
 lemma list_all2_induct[consumes 1, case_names Nil Cons]:
   assumes "list_all2 P l l'"
   assumes "Q [] []"
   assumes "\<And>x x' ls ls'. \<lbrakk> P x x'; list_all2 P ls ls'; Q ls ls' \<rbrakk>
     \<Longrightarrow> Q (x#ls) (x'#ls')"
   shows "Q l l'"
   using list_all2_lengthD[OF assms(1)] assms
   apply (induct rule: list_induct2)
   apply auto
   done
 
 
 subsubsection \<open>Indexing\<close>    
 
 lemma ran_nth_set_encoding_conv[simp]: 
   "ran (\<lambda>i. if i<length l then Some (l!i) else None) = set l"
   apply safe
   apply (auto simp: ran_def split: if_split_asm) []
   apply (auto simp: in_set_conv_nth intro: ranI) []
   done
 
 lemma nth_image_indices[simp]: "(!) l ` {0..<length l} = set l"
   by (auto simp: in_set_conv_nth)
 
 lemma nth_update_invalid[simp]:"\<not>i<length l \<Longrightarrow> l[j:=x]!i = l!i"  
   apply (induction l arbitrary: i j)
   apply (auto split: nat.splits)
   done
 
 lemma nth_list_update': "l[i:=x]!j = (if i=j \<and> i<length l then x else l!j)"  
   by auto
 
 lemma last_take_nth_conv: "n \<le> length l \<Longrightarrow> n\<noteq>0 \<Longrightarrow> last (take n l) = l!(n - 1)"
   apply (induction l arbitrary: n)
   apply (auto simp: take_Cons split: nat.split)
   done
 
 lemma nth_append_first[simp]: "i<length l \<Longrightarrow> (l@l')!i = l!i"
   by (simp add: nth_append) 
     
 lemma in_set_image_conv_nth: "f x \<in> f`set l \<longleftrightarrow> (\<exists>i<length l. f (l!i) = f x)"
   by (auto simp: in_set_conv_nth) (metis image_eqI nth_mem)
 
 lemma set_image_eq_pointwiseI: 
   assumes "length l = length l'"
   assumes "\<And>i. i<length l \<Longrightarrow> f (l!i) = f (l'!i)"  
   shows "f`set l = f`set l'"
   using assms
   by (fastforce simp: in_set_conv_nth in_set_image_conv_nth)
   
 lemma insert_swap_set_eq: "i<length l \<Longrightarrow> insert (l!i) (set (l[i:=x])) = insert x (set l)"
   by (auto simp: in_set_conv_nth nth_list_update split: if_split_asm)
     
     
 subsubsection \<open>Reverse lists\<close>
   lemma neq_Nil_revE: 
     assumes "l\<noteq>[]" 
     obtains ll e  where "l = ll@[e]"
     using assms by (cases l rule: rev_cases) auto
       
   lemma neq_Nil_rev_conv: "l\<noteq>[] \<longleftrightarrow> (\<exists>xs x. l = xs@[x])"
     by (cases l rule: rev_cases) auto
 
   text \<open>Caution: Same order of case variables in snoc-case as @{thm [source] rev_exhaust}, the other way round than @{thm [source] rev_induct} !\<close>
   lemma length_compl_rev_induct[case_names Nil snoc]: "\<lbrakk>P []; !! l e . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (l@[e])\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs" rule: rev_cases)
     apply(auto)
   done
 
   lemma list_append_eq_Cons_cases[consumes 1]: "\<lbrakk>ys@zs = x#xs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: append_eq_Cons_conv)
   lemma list_Cons_eq_append_cases[consumes 1]: "\<lbrakk>x#xs = ys@zs; \<lbrakk>ys=[]; zs=x#xs\<rbrakk> \<Longrightarrow> P; !!ys'. \<lbrakk> ys=x#ys'; ys'@zs=xs \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (auto iff add: Cons_eq_append_conv)
 
 lemma map_of_rev_distinct[simp]:
   "distinct (map fst m) \<Longrightarrow> map_of (rev m) = map_of m"
   apply (induct m)
     apply simp
 
     apply simp
     apply (subst map_add_comm)
       apply force
       apply simp
   done
 
 
 \<comment> \<open>Tail-recursive, generalized @{const rev}. May also be used for
       tail-recursively getting a list with all elements of the two
       operands, if the order does not matter, e.g. when implementing
       sets by lists.\<close>
 fun revg where
   "revg [] b = b" |
   "revg (a#as) b = revg as (a#b)"
 
 lemma revg_fun[simp]: "revg a b = rev a @ b"
   by (induct a arbitrary: b)
       auto
 
 lemma rev_split_conv[simp]:
   "l \<noteq> [] \<Longrightarrow> rev (tl l) @ [hd l] = rev l"
 by (induct l) simp_all
 
 lemma rev_butlast_is_tl_rev: "rev (butlast l) = tl (rev l)"
   by (induct l) auto
 
 lemma hd_last_singletonI:
   "\<lbrakk>xs \<noteq> []; hd xs = last xs; distinct xs\<rbrakk> \<Longrightarrow> xs = [hd xs]"
   by (induct xs rule: list_nonempty_induct) auto
 
 lemma last_filter:
   "\<lbrakk>xs \<noteq> []; P (last xs)\<rbrakk> \<Longrightarrow> last (filter P xs) = last xs"
   by (induct xs rule: rev_nonempty_induct) simp_all
 
 (* As the following two rules are similar in nature to list_induct2',
    they are named accordingly. *)
 lemma rev_induct2' [case_names empty snocl snocr snoclr]:
   assumes empty: "P [] []"
   and snocl: "\<And>x xs. P (xs@[x]) []"
   and snocr: "\<And>y ys. P [] (ys@[y])"
   and snoclr: "\<And>x xs y ys.  P xs ys  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
 proof (induct xs arbitrary: ys rule: rev_induct)
   case Nil thus ?case using empty snocr
     by (cases ys rule: rev_exhaust) simp_all
 next
   case snoc thus ?case using snocl snoclr
     by (cases ys rule: rev_exhaust) simp_all
 qed
 
 lemma rev_nonempty_induct2' [case_names single snocl snocr snoclr, consumes 2]:
   assumes "xs \<noteq> []" "ys \<noteq> []"
   assumes single': "\<And>x y. P [x] [y]"
   and snocl: "\<And>x xs y. xs \<noteq> [] \<Longrightarrow> P (xs@[x]) [y]"
   and snocr: "\<And>x y ys. ys \<noteq> [] \<Longrightarrow> P [x] (ys@[y])"
   and snoclr: "\<And>x xs y ys. \<lbrakk>P xs ys; xs \<noteq> []; ys\<noteq>[]\<rbrakk>  \<Longrightarrow> P (xs@[x]) (ys@[y])"
   shows "P xs ys"
   using assms(1,2)
 proof (induct xs arbitrary: ys rule: rev_nonempty_induct)
   case single then obtain z zs where "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using single' snocr
     by (cases "zs = []") simp_all
 next
   case (snoc x xs) then obtain z zs where zs: "ys = zs@[z]" by (metis rev_exhaust)
   thus ?case using snocl snoclr snoc
     by (cases "zs = []") simp_all
 qed
 
 
 subsubsection "Folding"
 
 text "Ugly lemma about foldl over associative operator with left and right neutral element"
 lemma foldl_A1_eq: "!!i. \<lbrakk> !! e. f n e = e; !! e. f e n = e; !!a b c. f a (f b c) = f (f a b) c \<rbrakk> \<Longrightarrow> foldl f i ww = f i (foldl f n ww)"
 proof (induct ww)
   case Nil thus ?case by simp
 next
   case (Cons a ww i) note IHP[simplified]=this
   have "foldl f i (a # ww) = foldl f (f i a) ww" by simp
   also from IHP have "\<dots> = f (f i a) (foldl f n ww)" by blast
   also from IHP(4) have "\<dots> = f i (f a (foldl f n ww))" by simp
   also from IHP(1)[OF IHP(2,3,4), where i=a] have "\<dots> = f i (foldl f a ww)" by simp
   also from IHP(2)[of a] have "\<dots> = f i (foldl f (f n a) ww)" by simp
   also have "\<dots> = f i (foldl f n (a#ww))" by simp
   finally show ?case .
 qed
 
 
 lemmas foldl_conc_empty_eq = foldl_A1_eq[of "(@)" "[]", simplified]
 lemmas foldl_un_empty_eq = foldl_A1_eq[of "(\<union>)" "{}", simplified, OF Un_assoc[symmetric]]
 
 lemma foldl_set: "foldl (\<union>) {} l = \<Union>{x. x\<in>set l}"
   apply (induct l)
   apply simp_all
   apply (subst foldl_un_empty_eq)
   apply auto
   done
 
 lemma (in monoid_mult) foldl_absorb1: "x*foldl (*) 1 zs = foldl (*) x zs"
   apply (rule sym)
   apply (rule foldl_A1_eq)
   apply (auto simp add: mult.assoc)
 done
 
 text \<open>Towards an invariant rule for foldl\<close>
 lemma foldl_rule_aux:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   shows "I (foldl f \<sigma>0 l0) []"
   using initial step
   apply (induct l0 arbitrary: \<sigma>0)
   apply auto
   done
 
 lemma foldl_rule_aux_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) l2"
   assumes final: "!!\<sigma>. I \<sigma> [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
 using foldl_rule_aux[of I \<sigma>0 l0, OF initial, OF step] final
 by simp
 
 
 lemma foldl_rule:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   assumes initial: "I \<sigma>0 [] l0"
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   shows "I (foldl f \<sigma>0 l0) l0 []"
   using initial step
   apply (rule_tac I="\<lambda>\<sigma> lr. \<exists>ll. l0=ll@lr \<and> I \<sigma> ll lr" in foldl_rule_aux_P)
   apply auto
   done
 
 text \<open>
   Invariant rule for foldl. The invariant is parameterized with
   the state, the list of items that have already been processed and
   the list of items that still have to be processed.
 \<close>
 lemma foldl_rule_P:
   fixes I :: "'\<sigma> \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
   \<comment> \<open>The invariant holds for the initial state, no items processed yet and all items to be processed:\<close>
   assumes initial: "I \<sigma>0 [] l0"
   \<comment> \<open>The invariant remains valid if one item from the list is processed\<close>
   assumes step: "!!l1 l2 x \<sigma>. \<lbrakk> l0=l1@x#l2; I \<sigma> l1 (x#l2) \<rbrakk> \<Longrightarrow> I (f \<sigma> x) (l1@[x]) l2"
   \<comment> \<open>The proposition follows from the invariant in the final state, i.e. all items processed and nothing to be processed\<close>
   assumes final: "!!\<sigma>. I \<sigma> l0 [] \<Longrightarrow> P \<sigma>"
   shows "P (foldl f \<sigma>0 l0)"
   using foldl_rule[of I, OF initial step] by (simp add: final)
 
 
 text \<open>Invariant reasoning over @{const foldl} for distinct lists. Invariant rule makes no
   assumptions about ordering.\<close>
 lemma distinct_foldl_invar:
   "\<lbrakk> distinct S; I (set S) \<sigma>0;
      \<And>x it \<sigma>. \<lbrakk>x \<in> it; it \<subseteq> set S; I it \<sigma>\<rbrakk> \<Longrightarrow> I (it - {x}) (f \<sigma> x)
    \<rbrakk> \<Longrightarrow> I {} (foldl f \<sigma>0 S)"
 proof (induct S arbitrary: \<sigma>0)
   case Nil thus ?case by auto
 next
   case (Cons x S)
 
   note [simp] = Cons.prems(1)[simplified]
 
   show ?case
     apply simp
     apply (rule Cons.hyps)
   proof -
     from Cons.prems(1) show "distinct S" by simp
     from Cons.prems(3)[of x "set (x#S)", simplified,
                        OF Cons.prems(2)[simplified]]
     show "I (set S) (f \<sigma>0 x)" .
     fix xx it \<sigma>
     assume A: "xx\<in>it" "it \<subseteq> set S" "I it \<sigma>"
     show "I (it - {xx}) (f \<sigma> xx)" using A(2)
       apply (rule_tac Cons.prems(3))
       apply (simp_all add: A(1,3))
       apply blast
       done
   qed
 qed
 
 lemma foldl_length_aux: "foldl (\<lambda>i x. Suc i) a l = a + length l"
   by (induct l arbitrary: a) auto
 
 lemmas foldl_length[simp] = foldl_length_aux[where a=0, simplified]
 
 lemma foldr_length_aux: "foldr (\<lambda>x i. Suc i) l a = a + length l"
   by (induct l arbitrary: a rule: rev_induct) auto
 
 lemmas foldr_length[simp] = foldr_length_aux[where a=0, simplified]
 
 context comp_fun_commute begin
 
 lemma foldl_f_commute: "f a (foldl (\<lambda>a b. f b a) b xs) = foldl (\<lambda>a b. f b a) (f a b) xs"
 by(induct xs arbitrary: b)(simp_all add: fun_left_comm)
 
 lemma foldr_conv_foldl: "foldr f xs a = foldl (\<lambda>a b. f b a) a xs"
 by(induct xs arbitrary: a)(simp_all add: foldl_f_commute)
 
 end
 
 lemma filter_conv_foldr:
   "filter P xs = foldr (\<lambda>x xs. if P x then x # xs else xs) xs []"
 by(induct xs) simp_all
 
 lemma foldr_Cons: "foldr Cons xs [] = xs"
 by(induct xs) simp_all
 
 lemma foldr_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldr (\<lambda>(x, y). f y) (zip xs ys) b = foldr f ys b"
 proof(induct ys arbitrary: xs)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma foldl_snd_zip:
   "length xs \<ge> length ys \<Longrightarrow> foldl (\<lambda>b (x, y). f b y) b (zip xs ys) = foldl f b ys"
 proof(induct ys arbitrary: xs b)
   case (Cons y ys) thus ?case by(cases xs) simp_all
 qed simp
 
 lemma fst_foldl: "fst (foldl (\<lambda>(a, b) x. (f a x, g a b x)) (a, b) xs) = foldl f a xs"
 by(induct xs arbitrary: a b) simp_all
 
 lemma foldl_foldl_conv_concat: "foldl (foldl f) a xs = foldl f a (concat xs)"
 by(induct xs arbitrary: a) simp_all
 
 lemma foldl_list_update:
   "n < length xs \<Longrightarrow> foldl f a (xs[n := x]) = foldl f (f (foldl f a (take n xs)) x) (drop (Suc n) xs)"
 by(simp add: upd_conv_take_nth_drop)
 
 lemma map_by_foldl:
   fixes l :: "'a list" and f :: "'a \<Rightarrow> 'b"
   shows "foldl (\<lambda>l x. l@[f x]) [] l = map f l"
 proof -
   {
     fix l'
     have "foldl (\<lambda>l x. l@[f x]) l' l = l'@map f l"
       by (induct l arbitrary: l') auto
   } thus ?thesis by simp
 qed
 
 
 subsubsection \<open>Sorting\<close>
 
 lemma sorted_in_between:
   assumes A: "0\<le>i" "i<j" "j<length l"
   assumes S: "sorted l"
   assumes E: "l!i \<le> x" "x<l!j"
   obtains k where "i\<le>k" and "k<j" and "l!k\<le>x" and "x<l!(k+1)"
 proof -
   from A E have "\<exists>k. i\<le>k \<and> k<j \<and> l!k\<le>x \<and> x<l!(k+1)"
   proof (induct "j-i" arbitrary: i j)
     case (Suc d)
     show ?case proof (cases "l!(i+1) \<le> x")
       case True
       from True Suc.hyps have "d = j - (i + 1)" by simp
       moreover from True have "i+1 < j"
         by (metis Suc.prems Suc_eq_plus1 Suc_lessI not_less)
       moreover from True have "0\<le>i+1" by simp
       ultimately obtain k where
         "i+1\<le>k" "k<j" "l!k \<le> x" "x<l!(k+1)"
         using Suc.hyps(1)[of j "i+1"] Suc.prems True
         by auto
       thus ?thesis by (auto dest: Suc_leD)
     next
       case False
       show ?thesis proof (cases "x<(l!(j - 1))")
         case True
         from True Suc.hyps have "d = j - (i + 1)" by simp
         moreover from True Suc.prems have "i < j - 1"
           by (metis Suc_eq_plus1 Suc_lessI diff_Suc_1 less_diff_conv not_le)
         moreover from True Suc.prems have "j - 1 < length l" by simp
         ultimately obtain k where
           "i\<le>k" "k<j - 1" "l!k \<le> x" "x<l!(k+1)"
           using Suc.hyps(1)[of "j - 1" i] Suc.prems True
           by auto
         thus ?thesis by (auto dest: Suc_leD)
       next
         case False thus ?thesis using Suc
           apply clarsimp
           by (metis Suc_leI add_0_iff add_diff_inverse diff_Suc_1 le_add2 lessI
               not0_implies_Suc not_less)
       qed
     qed
   qed simp
   thus ?thesis by (blast intro: that)
 qed
 
 lemma sorted_hd_last:
   "\<lbrakk>sorted l; l\<noteq>[]\<rbrakk> \<Longrightarrow> hd l \<le> last l"
 by (metis eq_iff hd_Cons_tl last_in_set not_hd_in_tl sorted_wrt.simps(2))
 
 lemma (in linorder) sorted_hd_min:
   "\<lbrakk>xs \<noteq> []; sorted xs\<rbrakk> \<Longrightarrow> \<forall>x \<in> set xs. hd xs \<le> x"
 by (induct xs, auto)
 
 lemma sorted_append_bigger:
   "\<lbrakk>sorted xs; \<forall>x \<in> set xs. x \<le> y\<rbrakk> \<Longrightarrow> sorted (xs @ [y])"
 proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have s: "sorted xs" by (cases xs) simp_all
   from Cons have a: "\<forall>x\<in>set xs. x \<le> y" by simp
   from Cons(1)[OF s a] Cons(2-) show ?case by (cases xs) simp_all
 qed
 
 lemma sorted_filter':
   "sorted l \<Longrightarrow> sorted (filter P l)"
   using sorted_filter[where f=id, simplified] .
 
 subsubsection \<open>Map\<close>
 (* List.thy has:
  declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!] *)  
 lemma map_eq_consE: "\<lbrakk>map f ls = fa#fl; !!a l. \<lbrakk> ls=a#l; f a=fa; map f l = fl \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by auto
 
 lemma map_fst_mk_snd[simp]: "map fst (map (\<lambda>x. (x,k)) l) = l" by (induct l) auto
 lemma map_snd_mk_fst[simp]: "map snd (map (\<lambda>x. (k,x)) l) = l" by (induct l) auto
 lemma map_fst_mk_fst[simp]: "map fst (map (\<lambda>x. (k,x)) l) = replicate (length l) k" by (induct l) auto
 lemma map_snd_mk_snd[simp]: "map snd (map (\<lambda>x. (x,k)) l) = replicate (length l) k" by (induct l) auto
 
 lemma map_zip1: "map (\<lambda>x. (x,k)) l = zip l (replicate (length l) k)" by (induct l) auto
 lemma map_zip2: "map (\<lambda>x. (k,x)) l = zip (replicate (length l) k) l" by (induct l) auto
 lemmas map_zip=map_zip1 map_zip2
 
 (* TODO/FIXME: hope nobody changes nth to be underdefined! *)
 lemma map_eq_nth_eq:
   assumes A: "map f l = map f l'"
   shows "f (l!i) = f (l'!i)"
 proof -
   from A have "length l = length l'"
     by (metis length_map)
   thus ?thesis using A
     apply (induct arbitrary: i rule: list_induct2)
     apply simp
     apply (simp add: nth_def split: nat.split)
     done
 qed
 
 lemma map_upd_eq:
   "\<lbrakk>i<length l \<Longrightarrow> f (l!i) = f x\<rbrakk> \<Longrightarrow> map f (l[i:=x]) = map f l"
   by (metis list_update_beyond list_update_id map_update not_le_imp_less)
 
 
 
 
 lemma inj_map_inv_f [simp]: "inj f \<Longrightarrow> map (inv f) (map f l) = l"
   by (simp)
 
 lemma inj_on_map_the: "\<lbrakk>D \<subseteq> dom m; inj_on m D\<rbrakk> \<Longrightarrow> inj_on (the\<circ>m) D"
   apply (rule inj_onI)
   apply simp
   apply (case_tac "m x")
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply (auto intro: inj_onD) [1]
   apply (case_tac "m y")
   apply (auto intro: inj_onD) [1]
   apply simp
   apply (rule inj_onD)
   apply assumption
   apply auto
   done
 
     
 
 lemma map_consI:
   "w=map f ww \<Longrightarrow> f a#w = map f (a#ww)"
   "w@l=map f ww@l \<Longrightarrow> f a#w@l = map f (a#ww)@l"
   by auto
 
 
 lemma restrict_map_subset_eq:
   fixes R
   shows "\<lbrakk>m |` R = m'; R'\<subseteq>R\<rbrakk> \<Longrightarrow> m|` R' = m' |` R'"
   by (auto simp add: Int_absorb1)
 
 lemma restrict_map_self[simp]: "m |` dom m = m"
   apply (rule ext)
   apply (case_tac "m x")
   apply (auto simp add: restrict_map_def)
   done
 
 lemma restrict_map_UNIV[simp]: "f |` UNIV = f"
   by (auto simp add: restrict_map_def)
 
 lemma restrict_map_inv[simp]: "f |` (- dom f) = Map.empty"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma restrict_map_upd: "(f |` S)(k \<mapsto> v) = f(k\<mapsto>v) |` (insert k S)"
   by (auto simp add: restrict_map_def intro: ext)
 
 lemma map_upd_eq_restrict: "m (x:=None) = m |` (-{x})"
   by (auto intro: ext)
 
 declare Map.finite_dom_map_of [simp, intro!]
 
 lemma dom_const'[simp]: "dom (\<lambda>x. Some (f x)) = UNIV"
   by auto
 
 lemma restrict_map_eq :
   "((m |` A) k = None) \<longleftrightarrow> (k \<notin> dom m \<inter> A)"
   "((m |` A) k = Some v) \<longleftrightarrow> (m k = Some v \<and> k \<in> A)"
 unfolding restrict_map_def
 by (simp_all add: dom_def)
 
 
 definition "rel_of m P == {(k,v). m k = Some v \<and> P (k, v)}"
 lemma rel_of_empty[simp]: "rel_of Map.empty P = {}"
     by (auto simp add: rel_of_def)
 
 lemma remove1_tl: "xs \<noteq> [] \<Longrightarrow> remove1 (hd xs) xs = tl xs"
   by (cases xs) auto
 
 lemma set_oo_map_alt: "(set \<circ>\<circ> map) f = (\<lambda>l. f ` set l)" by auto
     
 subsubsection "Filter and Revert"
 primrec filter_rev_aux where
   "filter_rev_aux a P [] = a"
 | "filter_rev_aux a P (x#xs) = (
      if P x then filter_rev_aux (x#a) P xs else filter_rev_aux a P xs)"
 
 lemma filter_rev_aux_alt: "filter_rev_aux a P l = filter P (rev l) @ a"
   by (induct l arbitrary: a) auto
 
 definition "filter_rev == filter_rev_aux []"
 lemma filter_rev_alt: "filter_rev P l = filter P (rev l)"
   unfolding filter_rev_def by (simp add: filter_rev_aux_alt)
 
 definition "remove_rev x == filter_rev (Not o (=) x)"
 lemma remove_rev_alt_def :
   "remove_rev x xs = (filter (\<lambda>y. y \<noteq> x) (rev xs))"
   unfolding remove_rev_def
   apply (simp add: filter_rev_alt comp_def)
   by metis
 
 subsubsection "zip"
 
 declare zip_map_fst_snd[simp]  
 
 lemma pair_list_split: "\<lbrakk> !!l1 l2. \<lbrakk> l = zip l1 l2; length l1=length l2; length l=length l2 \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
 proof (induct l arbitrary: P)
   case Nil thus ?case by auto
 next
   case (Cons a l) from Cons.hyps obtain l1 l2 where IHAPP: "l=zip l1 l2" "length l1 = length l2" "length l=length l2" .
   obtain a1 a2 where [simp]: "a=(a1,a2)" by (cases a) auto
   from IHAPP have "a#l = zip (a1#l1) (a2#l2)" "length (a1#l1) = length (a2#l2)" "length (a#l) = length (a2#l2)"
     by (simp_all only:) (simp_all (no_asm_use))
   with Cons.prems show ?case by blast
 qed
 
 lemma set_zip_cart: "x\<in>set (zip l l') \<Longrightarrow> x\<in>set l \<times> set l'"
   by (auto simp add: set_zip)
 
 
 lemma map_prod_fun_zip: "map (\<lambda>(x, y). (f x, g y)) (zip xs ys) = zip (map f xs) (map g ys)"
 proof(induct xs arbitrary: ys)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by(cases ys) simp_all
 qed
 
 
 subsubsection \<open>Generalized Zip\<close>
 text \<open>Zip two lists element-wise, where the combination of two elements is specified by a function. Note that this function is underdefined for lists of different length.\<close>
 fun zipf :: "('a\<Rightarrow>'b\<Rightarrow>'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
   "zipf f [] [] = []" |
   "zipf f (a#as) (b#bs) = f a b # zipf f as bs"
 
 
 lemma zipf_zip: "\<lbrakk>length l1 = length l2\<rbrakk> \<Longrightarrow> zipf Pair l1 l2 = zip l1 l2"
   apply (induct l1 arbitrary: l2)
   apply auto
   apply (case_tac l2)
   apply auto
   done
 
   \<comment> \<open>All quantification over zipped lists\<close>
 fun list_all_zip where
   "list_all_zip P [] [] \<longleftrightarrow> True" |
   "list_all_zip P (a#as) (b#bs) \<longleftrightarrow> P a b \<and> list_all_zip P as bs" |
   "list_all_zip P _ _ \<longleftrightarrow> False"
 
 lemma list_all_zip_alt: "list_all_zip P as bs \<longleftrightarrow> length as = length bs \<and> (\<forall>i<length as. P (as!i) (bs!i))"
   apply (induct P\<equiv>P as bs rule: list_all_zip.induct)
   apply auto
   apply (case_tac i)
   apply auto
   done
 
 lemma list_all_zip_map1: "list_all_zip P (List.map f as) bs \<longleftrightarrow> list_all_zip (\<lambda>a b. P (f a) b) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 lemma list_all_zip_map2: "list_all_zip P as (List.map f bs) \<longleftrightarrow> list_all_zip (\<lambda>a b. P a (f b)) as bs"
   apply (induct as arbitrary: bs)
   apply (case_tac bs)
   apply auto [2]
   apply (case_tac bs)
   apply auto [2]
   done
 
 declare list_all_zip_alt[mono]
 
 lemma lazI[intro?]: "\<lbrakk> length a = length b; !!i. i<length b \<Longrightarrow> P (a!i) (b!i) \<rbrakk>
   \<Longrightarrow> list_all_zip P a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_conj[simp]: "list_all_zip (\<lambda>x y. P x y \<and> Q x y) a b
                        \<longleftrightarrow> list_all_zip P a b \<and> list_all_zip Q a b"
   by (auto simp add: list_all_zip_alt)
 
 lemma laz_len: "list_all_zip P a b \<Longrightarrow> length a = length b"
   by (simp add: list_all_zip_alt)
 
 lemma laz_eq: "list_all_zip (=) a b \<longleftrightarrow> a=b"
   apply (induct a arbitrary: b)
   apply (case_tac b)
   apply simp
   apply simp
   apply (case_tac b)
   apply simp
   apply simp
   done
 
 
 lemma laz_swap_ex:
   assumes A: "list_all_zip (\<lambda>a b. \<exists>c. P a b c) A B"
   obtains C where
     "list_all_zip (\<lambda>a c. \<exists>b. P a b c) A C"
     "list_all_zip (\<lambda>b c. \<exists>a. P a b c) B C"
 proof -
   from A have
     [simp]: "length A = length B" and
     IC: "\<forall>i<length B. \<exists>ci. P (A!i) (B!i) ci"
     by (auto simp add: list_all_zip_alt)
   from obtain_list_from_elements[OF IC] obtain C where
     "length C = length B"
     "\<forall>i<length B. P (A!i) (B!i) (C!i)" .
   thus ?thesis
     by (rule_tac that) (auto simp add: list_all_zip_alt)
 qed
 
 lemma laz_weak_Pa[simp]:
   "list_all_zip (\<lambda>a b. P a) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>a\<in>set A. P a)"
   by (auto simp add: list_all_zip_alt set_conv_nth)
 
 lemma laz_weak_Pb[simp]:
   "list_all_zip (\<lambda>a b. P b) A B \<longleftrightarrow> (length A = length B) \<and> (\<forall>b\<in>set B. P b)"
   by (force simp add: list_all_zip_alt set_conv_nth)
 
 
 
 subsubsection "Collecting Sets over Lists"
 
 definition "list_collect_set f l == \<Union>{ f a | a. a\<in>set l }"
 lemma list_collect_set_simps[simp]:
   "list_collect_set f [] = {}"
   "list_collect_set f [a] = f a"
   "list_collect_set f (a#l) = f a \<union> list_collect_set f l"
   "list_collect_set f (l@l') = list_collect_set f l \<union> list_collect_set f l'"
 by (unfold list_collect_set_def) auto
 
 lemma list_collect_set_map_simps[simp]:
   "list_collect_set f (map x []) = {}"
   "list_collect_set f (map x [a]) = f (x a)"
   "list_collect_set f (map x (a#l)) = f (x a) \<union> list_collect_set f (map x l)"
   "list_collect_set f (map x (l@l')) = list_collect_set f (map x l) \<union> list_collect_set f (map x l')"
 by simp_all
 
 lemma list_collect_set_alt: "list_collect_set f l = \<Union>{ f (l!i) | i. i<length l }"
   apply (induct l)
   apply simp
   apply safe
   apply auto
   apply (rule_tac x="f (l!i)" in exI)
   apply simp
   apply (rule_tac x="Suc i" in exI)
   apply simp
   apply (case_tac i)
   apply auto
   done
 
 lemma list_collect_set_as_map: "list_collect_set f l = \<Union>(set (map f l))"
   by (unfold list_collect_set_def) auto
 
 subsubsection \<open>Sorted List with arbitrary Relations\<close>
 
 lemma (in linorder) sorted_wrt_rev_linord [simp] :
   "sorted_wrt (\<ge>) l \<longleftrightarrow> sorted (rev l)"
 by (simp add: sorted_wrt_rev)
 
 lemma (in linorder) sorted_wrt_map_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<le> fst y) l
   \<longleftrightarrow> sorted (map fst l)"
 by (simp add: sorted_wrt_map)
 
 lemma (in linorder) sorted_wrt_map_rev_linord [simp] :
   "sorted_wrt (\<lambda>(x::'a \<times> 'b) y. fst x \<ge> fst y) l
   \<longleftrightarrow> sorted (rev (map fst l))"
 by (induct l) (auto simp add: sorted_append)
 
     
 subsubsection \<open>Take and Drop\<close>
   lemma take_update[simp]: "take n (l[i:=x]) = (take n l)[i:=x]"
     apply (induct l arbitrary: n i)
     apply (auto split: nat.split)
     apply (case_tac n)
     apply simp_all
     apply (case_tac n)
     apply simp_all
     done
 
   lemma take_update_last: "length list>n \<Longrightarrow> (take (Suc n) list) [n:=x] = take n list @ [x]"
     by (induct list arbitrary: n)
        (auto split: nat.split)
 
   lemma drop_upd_irrelevant: "m < n \<Longrightarrow> drop n (l[m:=x]) = drop n l"
     apply (induct n arbitrary: l m)
     apply simp
     apply (case_tac l)
     apply (auto split: nat.split)
     done
 
 lemma set_drop_conv:
   "set (drop n l) =  { l!i | i. n\<le>i \<and> i < length l }" (is "?L=?R")
 proof (intro equalityI subsetI)
   fix x
   assume "x\<in>?L"
   then obtain i where L: "i<length l - n" and X: "x = drop n l!i"
     by (auto simp add: in_set_conv_nth)
   note X
   also have "\<dots> = l!(n+i)" using L by simp
   finally show "x\<in>?R" using L by auto
 next
   fix x
   assume "x\<in>?R"
   then obtain i where L: "n\<le>i" "i<length l" and X: "x=l!i" by blast
   note X
   moreover have "l!i = drop n l ! (i - n)" and "(i-n) < length l - n" using L
     by (auto)
   ultimately show "x\<in>?L"
     by (auto simp add: in_set_conv_nth)
 qed
 
 lemma filter_upt_take_conv:
   "[i\<leftarrow>[n..<m]. P (take m l ! i) ] = [i\<leftarrow>[n..<m]. P (l ! i) ]"
   by (rule filter_cong) (simp_all)
 
 lemma in_set_drop_conv_nth: "x\<in>set (drop n l) \<longleftrightarrow> (\<exists>i. n\<le>i \<and> i<length l \<and> x = l!i)"
   apply (clarsimp simp: in_set_conv_nth)
   apply safe
   apply simp
   apply (metis le_add2 less_diff_conv add.commute)
   apply (rule_tac x="i-n" in exI)
   apply auto []
   done
 
 lemma Union_take_drop_id: "\<Union>(set (drop n l)) \<union> \<Union>(set (take n l)) = \<Union>(set l)"
   by (metis Union_Un_distrib append_take_drop_id set_union_code sup_commute)
 
 
 lemma Un_set_drop_extend: "\<lbrakk>j\<ge>Suc 0; j < length l\<rbrakk>
   \<Longrightarrow> l ! (j - Suc 0) \<union> \<Union>(set (drop j l)) = \<Union>(set (drop (j - Suc 0) l))"
   apply safe
   apply simp_all
   apply (metis diff_Suc_Suc diff_zero gr0_implies_Suc in_set_drop_conv_nth
     le_refl less_eq_Suc_le order.strict_iff_order)
   apply (metis Nat.diff_le_self set_drop_subset_set_drop subset_code(1))
   by (metis diff_Suc_Suc gr0_implies_Suc in_set_drop_conv_nth
     less_eq_Suc_le order.strict_iff_order minus_nat.diff_0)
 
 lemma drop_take_drop_unsplit:
   "i\<le>j \<Longrightarrow> drop i (take j l) @ drop j l = drop i l"
 proof -
   assume "i \<le> j"
   then obtain skf where "i + skf = j"
     by (metis le_iff_add)
   thus "drop i (take j l) @ drop j l = drop i l"
     by (metis append_take_drop_id diff_add_inverse drop_drop drop_take
       add.commute)
 qed
 
 lemma drop_last_conv[simp]: "l\<noteq>[] \<Longrightarrow> drop (length l - Suc 0) l = [last l]"
   by (cases l rule: rev_cases) auto
 
 lemma take_butlast_conv[simp]: "take (length l - Suc 0) l = butlast l"
   by (cases l rule: rev_cases) auto
 
   lemma drop_takeWhile:
     assumes "i\<le>length (takeWhile P l)"
     shows "drop i (takeWhile P l) = takeWhile P (drop i l)"  
     using assms
   proof (induction l arbitrary: i)
     case Nil thus ?case by auto
   next
     case (Cons x l) thus ?case  
       by (cases i) auto
   qed    
   
 lemma less_length_takeWhile_conv: "i < length (takeWhile P l) \<longleftrightarrow> (i<length l \<and> (\<forall>j\<le>i. P (l!j)))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (metis dual_order.strict_trans2 nth_mem set_takeWhileD takeWhile_nth)
   subgoal by (meson less_le_trans not_le_imp_less nth_length_takeWhile)
   done
   
 lemma eq_len_takeWhile_conv: "i=length (takeWhile P l) 
   \<longleftrightarrow> i\<le>length l \<and> (\<forall>j<i. P (l!j)) \<and> (i<length l \<longrightarrow> \<not>P (l!i))"  
   apply safe
   subgoal using length_takeWhile_le less_le_trans by blast
   subgoal by (auto simp: less_length_takeWhile_conv)
   subgoal using nth_length_takeWhile by blast 
   subgoal by (metis length_takeWhile_le nth_length_takeWhile order.order_iff_strict) 
   subgoal by (metis dual_order.strict_trans2 leI less_length_takeWhile_conv linorder_neqE_nat nth_length_takeWhile) 
   done
     
     
 subsubsection \<open>Up-to\<close>
 
 lemma upt_eq_append_conv: "i\<le>j \<Longrightarrow> [i..<j] = xs@ys \<longleftrightarrow> (\<exists>k. i\<le>k \<and> k\<le>j \<and> [i..<k] = xs \<and> [k..<j] = ys)"
 proof (rule iffI)
   assume "[i..<j] = xs @ ys"  
   and "i\<le>j"
   thus "\<exists>k\<ge>i. k \<le> j \<and> [i..<k] = xs \<and> [k..<j] = ys"
     apply (induction xs arbitrary: i)
     apply (auto; fail)
     apply (clarsimp simp: upt_eq_Cons_conv)
     by (meson Suc_le_eq less_imp_le_nat)
 qed auto
   
 lemma map_nth_upt_drop_take_conv: "N \<le> length l \<Longrightarrow> map (nth l) [M..<N] = drop M (take N l)"
   by (induction N) (auto simp: take_Suc_conv_app_nth)
     
 lemma upt_eq_lel_conv:
   "[l..<h] = is1@i#is2 \<longleftrightarrow> is1 = [l..<i] \<and> is2 = [Suc i..<h] \<and> l\<le>i \<and> i<h"
   apply (rule)
   subgoal
     apply (induction is1 arbitrary: l)
     apply (auto simp: upt_eq_Cons_conv) []
     apply (clarsimp simp: upt_eq_Cons_conv)
     using Suc_le_eq upt_rec by auto
   subgoal by (auto simp: upt_conv_Cons[symmetric])
   done
 
    
 lemma map_add_upt': "map (\<lambda>i. i + ofs) [a..<b] = [a+ofs..<b + ofs]"
   by (induct b) simp_all
     
     
 subsubsection \<open>Last and butlast\<close>
 lemma butlast_upt: "butlast [m..<n] = [m..<n - 1]"
   apply (cases "m<n")
     apply (cases n)
       apply simp
     apply simp
   apply simp
   done
 
 (*lemma butlast_upt: "n<m \<Longrightarrow> butlast [n..<m] = [n..<m - 1]"
   apply (cases "[n..<m]" rule: rev_cases)
   apply simp
   apply (cases m)
   apply simp
   apply simp
   done*)
 
 lemma butlast_update': "(butlast l) [i:=x] = butlast (l[i:=x])"
   by (metis butlast_conv_take butlast_list_update length_butlast take_update)
 
 
 lemma take_minus_one_conv_butlast:
   "n\<le>length l \<Longrightarrow> take (n - Suc 0) l = butlast (take n l)"
   by (simp add: butlast_take)
 
 lemma butlast_eq_cons_conv: "butlast l = x#xs \<longleftrightarrow> (\<exists>xl. l=x#xs@[xl])"
   by (metis Cons_eq_appendI append_butlast_last_id butlast.simps
     butlast_snoc eq_Nil_appendI)
 
 lemma butlast_eq_consE:
   assumes "butlast l = x#xs"
   obtains xl where "l=x#xs@[xl]"
   using assms
   by (auto simp: butlast_eq_cons_conv)
 
 lemma drop_eq_ConsD: "drop n xs = x # xs' \<Longrightarrow> drop (Suc n) xs = xs'"
 by(induct xs arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
 
 subsubsection \<open>List Slices\<close>  
   text \<open>Based on Lars Hupel's code.\<close>  
 definition slice :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "slice from to list = take (to - from) (drop from list)"
 
 lemma slice_len[simp]: "\<lbrakk> from \<le> to; to \<le> length xs \<rbrakk> \<Longrightarrow> length (slice from to xs) = to - from"
 unfolding slice_def
 by simp
 
 lemma slice_head: "\<lbrakk> from < to; to \<le> length xs \<rbrakk> \<Longrightarrow> hd (slice from to xs) = xs ! from"
 unfolding slice_def
 proof -
   assume a1: "from < to"
   assume "to \<le> length xs"
   then have "\<And>n. to - (to - n) \<le> length (take to xs)"
     by (metis (no_types) slice_def diff_le_self drop_take length_drop slice_len)
   then show "hd (take (to - from) (drop from xs)) = xs ! from"
     using a1 by (metis diff_diff_cancel drop_take hd_drop_conv_nth leI le_antisym less_or_eq_imp_le nth_take)
 qed
 
 lemma slice_eq_bounds_empty[simp]: "slice i i xs = []"
 unfolding slice_def by auto
 
 lemma slice_nth: "\<lbrakk> from < to; to \<le> length xs; i < to - from \<rbrakk> \<Longrightarrow> slice from to xs ! i = xs ! (from + i)"
 unfolding slice_def
 by (induction "to - from" arbitrary: "from" to i) simp+
 
 lemma slice_prepend: "\<lbrakk> i \<le> k; k \<le> length xs \<rbrakk> \<Longrightarrow> let p = length ys in slice i k xs = slice (i + p) (k + p) (ys @ xs)"
 unfolding slice_def Let_def
 by force
 
 lemma slice_Nil[simp]: "slice begin end [] = []"  
   unfolding slice_def by auto
   
 lemma slice_Cons: "slice begin end (x#xs) 
   = (if begin=0 \<and> end>0 then x#slice begin (end-1) xs else slice (begin - 1) (end - 1) xs)"
   unfolding slice_def
   by (auto simp: take_Cons' drop_Cons')
 
 lemma slice_complete[simp]: "slice 0 (length xs) xs = xs"
   unfolding slice_def
   by simp
 
   
   
 subsubsection \<open>Miscellaneous\<close>
   lemma length_compl_induct[case_names Nil Cons]: "\<lbrakk>P []; !! e l . \<lbrakk>!! ll . length ll <= length l \<Longrightarrow> P ll\<rbrakk> \<Longrightarrow> P (e#l)\<rbrakk> \<Longrightarrow> P l"
     apply(induct_tac l rule: length_induct)
     apply(case_tac "xs")
     apply(auto)
   done
 
   lemma in_set_list_format: "\<lbrakk> e\<in>set l; !!l1 l2. l=l1@e#l2 \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof (induct l arbitrary: P)
     case Nil thus ?case by auto
   next
     case (Cons a l) show ?case proof (cases "a=e")
       case True with Cons show ?thesis by force
     next
       case False with Cons.prems(1) have "e\<in>set l" by auto
       with Cons.hyps obtain l1 l2 where "l=l1@e#l2" by blast
       hence "a#l = (a#l1)@e#l2" by simp
       with Cons.prems(2) show P by blast
     qed
   qed
 
 lemma in_set_upd_cases:
   assumes "x\<in>set (l[i:=y])"
   obtains "i<length l" and "x=y" | "x\<in>set l"
   by (metis assms in_set_conv_nth length_list_update nth_list_update_eq
     nth_list_update_neq)
 
 lemma in_set_upd_eq_aux:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (\<forall>y. x\<in>set (l[i:=y]))"
   by (metis in_set_upd_cases assms list_update_overwrite
     set_update_memI)
 
 lemma in_set_upd_eq:
   assumes "i<length l"
   shows "x\<in>set (l[i:=y]) \<longleftrightarrow> x=y \<or> (x\<in>set l \<and> (\<forall>y. x\<in>set (l[i:=y])))"
   by (metis in_set_upd_cases in_set_upd_eq_aux assms)
 
 
   text \<open>Simultaneous induction over two lists, prepending an element to one of the lists in each step\<close>
   lemma list_2pre_induct[case_names base left right]: assumes BASE: "P [] []" and LEFT: "!!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2" and RIGHT: "!!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2')" shows "P w1 w2"
   proof -
     { \<comment> \<open>The proof is done by induction over the sum of the lengths of the lists\<close>
       fix n
       have "!!w1 w2. \<lbrakk>length w1 + length w2 = n; P [] []; !!e w1' w2. P w1' w2 \<Longrightarrow> P (e#w1') w2; !!e w1 w2'. P w1 w2' \<Longrightarrow> P w1 (e#w2') \<rbrakk> \<Longrightarrow> P w1 w2 "
         apply (induct n)
         apply simp
         apply (case_tac w1)
         apply auto
         apply (case_tac w2)
         apply auto
         done
     } from this[OF _ BASE LEFT RIGHT] show ?thesis by blast
   qed
 
 
   lemma list_decomp_1: "length l=1 \<Longrightarrow> \<exists>a. l=[a]"
     by (case_tac l, auto)
 
   lemma list_decomp_2: "length l=2 \<Longrightarrow> \<exists>a b. l=[a,b]"
     by (case_tac l, auto simp add: list_decomp_1)
 
 
 
   lemma list_rest_coinc: "\<lbrakk>length s2 \<le> length s1; s1@r1 = s2@r2\<rbrakk> \<Longrightarrow> \<exists>r1p. r2=r1p@r1"
     by (metis append_eq_append_conv_if)
 
   lemma list_tail_coinc: "n1#r1 = n2#r2 \<Longrightarrow> n1=n2 & r1=r2"
     by (auto)
 
 
   lemma last_in_set[intro]: "\<lbrakk>l\<noteq>[]\<rbrakk> \<Longrightarrow> last l \<in> set l"
     by (induct l) auto
 
   lemma empty_append_eq_id[simp]: "(@) [] = (\<lambda>x. x)" by auto
       
   lemma op_conc_empty_img_id[simp]: "((@) [] ` L) = L" by auto
 
 
   lemma distinct_match: "\<lbrakk> distinct (al@e#bl) \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e#bl') \<longleftrightarrow> (al=al' \<and> bl=bl')"
   proof (rule iffI, induct al arbitrary: al')
     case Nil thus ?case by (cases al') auto
   next
     case (Cons a al) note Cprems=Cons.prems note Chyps=Cons.hyps
     show ?case proof (cases al')
       case Nil with Cprems have False by auto
       thus ?thesis ..
     next
       case [simp]: (Cons a' all')
       with Cprems have [simp]: "a=a'" and P: "al@e#bl = all'@e#bl'" by auto
       from Cprems(1) have D: "distinct (al@e#bl)" by auto
       from Chyps[OF D P] have [simp]: "al=all'" "bl=bl'" by auto
       show ?thesis by simp
     qed
   qed simp
 
 
   lemma prop_match: "\<lbrakk> list_all P al; \<not>P e; \<not>P e'; list_all P bl \<rbrakk> \<Longrightarrow> (al@e#bl = al'@e'#bl') \<longleftrightarrow> (al=al' \<and> e=e' \<and> bl=bl')"
     apply (rule iffI, induct al arbitrary: al')
     apply (case_tac al', fastforce, fastforce)+
     done
 
   lemmas prop_matchD = rev_iffD1[OF _ prop_match[where P=P]] for P
 
   declare distinct_tl[simp]
 
 
 lemma list_se_match[simp]:
   "l1 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> l1@l2 = [a] \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   "l1 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [a] \<and> l2 = []"
   "l2 \<noteq> [] \<Longrightarrow> [a] = l1@l2 \<longleftrightarrow> l1 = [] \<and> l2 = [a]"
   apply (cases l1, simp_all)
   apply (cases l1, simp_all)
   apply (cases l1, auto) []
   apply (cases l1, auto) []
   done
 
 
 
 
 
     (* Placed here because it depends on xy_in_set_cases *)
 lemma distinct_map_eq: "\<lbrakk> distinct (List.map f l); f x = f y; x\<in>set l; y\<in>set l \<rbrakk> \<Longrightarrow> x=y"
   by (erule (2) xy_in_set_cases) auto
 
 
 
 lemma upt_append:
   assumes "i<j"
   shows "[0..<i]@[i..<j] = [0..<j]"
   using assms
   apply (induct j)
   apply simp
   apply (case_tac "i=j")
   apply auto
   done
 
 
 
 lemma upt_filter_extend:
   assumes LE: "u\<le>u'"
   assumes NP: "\<forall>i. u\<le>i \<and> i<u' \<longrightarrow> \<not>P i"
   shows "[i\<leftarrow>[0..<u]. P i] = [i\<leftarrow>[0..<u']. P i]"
 proof (cases "u=u'")
   case True thus ?thesis by simp
 next
   case False hence "u<u'" using LE by simp
   hence "[0..<u'] = [0..<u]@[u ..<u']"
     by (simp add: upt_append)
   hence "[i\<leftarrow>[0..<u']. P i] = [i\<leftarrow>[0..<u]. P i] @ [i\<leftarrow>[u..<u']. P i]"
     by simp
   also have "[i\<leftarrow>[u..<u']. P i] = []" using NP
     by (auto simp: filter_empty_conv)
   finally show ?thesis by simp
 qed
 
 
 lemma filter_upt_last:
   assumes E: "[k\<leftarrow>[0..<length l] . P (l!k)] = js @ [j]"
   assumes "j<i" and "i<length l"
   shows "\<not> P (l!i)"
 proof
   assume A: "P (l!i)"
   have "[0..<length l] = [0..<i]@[i..<length l]" using \<open>i<length l\<close>
     by (simp add: upt_append)
   also have "[i..<length l] = i#[Suc i..<length l]" using \<open>i<length l\<close>
     by (auto simp: upt_conv_Cons)
   finally
   have "[k\<leftarrow>[0..<i] . P (l!k)]@i#[k\<leftarrow>[Suc i..<length l] . P (l!k)] = js@[j]"
     unfolding E[symmetric]
     using \<open>P (l!i)\<close> by simp
   hence "j = last (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])"
     by (metis last_appendR last_snoc list.distinct(1))
   also have "\<dots> \<ge> i"
   proof -
     have "sorted (i#[k\<leftarrow>[Suc i..<length l] . P (l!k)])" (is "sorted ?l")
       by (simp add: sorted_filter[where f=id, simplified])
     hence "hd ?l \<le> last ?l"
       by (rule sorted_hd_last) simp
     thus ?thesis by simp
   qed
   finally have "i\<le>j" . thus False using \<open>j<i\<close> by simp
 qed
 
 lemma all_set_conv_nth: "(\<forall>x\<in>set l. P x) \<longleftrightarrow> (\<forall>i<length l. P (l!i))"
   by (auto intro: all_nth_imp_all_set)
 
 (* TODO: Special case of upt_eq_Nil_conv. Find cases where the latter does not work \<dots>
 *)    
 lemma upt_0_eq_Nil_conv[simp]: "[0..<j] = [] \<longleftrightarrow> j=0"
   by auto
 
 lemma filter_eq_snocD: "filter P l = l'@[x] \<Longrightarrow> x\<in>set l \<and> P x"
 proof -
   assume A: "filter P l = l'@[x]"
   hence "x\<in>set (filter P l)" by simp
   thus ?thesis by simp
 qed
 
 lemma lists_image_witness:
   assumes A: "x\<in>lists (f`Q)"
   obtains xo where "xo\<in>lists Q" "x=map f xo"
 proof -
   have "\<lbrakk> x\<in>lists (f`Q) \<rbrakk> \<Longrightarrow> \<exists>xo\<in>lists Q. x=map f xo"
   proof (induct x)
     case Nil thus ?case by auto
   next
     case (Cons x xs)
     then obtain xos where "xos\<in>lists Q" "xs=map f xos" by force
     moreover from Cons.prems have "x\<in>f`Q" by auto
     then obtain xo where "xo\<in>Q" "x=f xo" by auto
     ultimately show ?case
       by (rule_tac x="xo#xos" in bexI) auto
   qed
   thus ?thesis
     apply (simp_all add: A)
     apply (erule_tac bexE)
     apply (rule_tac that)
     apply assumption+
     done
 qed
 
 
 lemma map_of_None_filterD:
   "map_of xs x = None \<Longrightarrow> map_of (filter P xs) x = None"
 by(induct xs) auto
 
 lemma map_of_concat: "map_of (concat xss) = foldr (\<lambda>xs f. f ++ map_of xs) xss Map.empty"
 by(induct xss) simp_all
 
 lemma map_of_Some_split:
   "map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None"
 proof(induct xs)
   case (Cons x xs)
   obtain k' v' where x: "x = (k', v')" by(cases x)
   show ?case
   proof(cases "k' = k")
     case True
     with \<open>map_of (x # xs) k = Some v\<close> x have "x # xs = [] @ (k, v) # xs" "map_of [] k = None" by simp_all
     thus ?thesis by blast
   next
     case False
     with \<open>map_of (x # xs) k = Some v\<close> x
     have "map_of xs k = Some v" by simp
     from \<open>map_of xs k = Some v \<Longrightarrow> \<exists>ys zs. xs = ys @ (k, v) # zs \<and> map_of ys k = None\<close>[OF this]
     obtain ys zs where "xs = ys @ (k, v) # zs" "map_of ys k = None" by blast
     with False x have "x # xs = (x # ys) @ (k, v) # zs" "map_of (x # ys) k = None" by simp_all
     thus ?thesis by blast
   qed
 qed simp
 
 lemma map_add_find_left:
   "g k = None \<Longrightarrow> (f ++ g) k = f k"
 by(simp add: map_add_def)
 
 lemma map_add_left_None:
   "f k = None \<Longrightarrow> (f ++ g) k = g k"
 by(simp add: map_add_def split: option.split)
 
 lemma map_of_Some_filter_not_in:
   "\<lbrakk> map_of xs k = Some v; \<not> P (k, v); distinct (map fst xs) \<rbrakk> \<Longrightarrow> map_of (filter P xs) k = None"
 apply(induct xs)
 apply(auto)
 apply(auto simp add: map_of_eq_None_iff)
 done
 
 lemma distinct_map_fst_filterI: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (filter P xs))"
 by(induct xs) auto
 
 lemma distinct_map_fstD: "\<lbrakk> distinct (map fst xs); (x, y) \<in> set xs; (x, z) \<in> set xs \<rbrakk> \<Longrightarrow> y = z"
 by(induct xs)(fastforce elim: notE rev_image_eqI)+
 
 
 
 lemma concat_filter_neq_Nil:
   "concat [ys\<leftarrow>xs. ys \<noteq> Nil] = concat xs"
 by(induct xs) simp_all
 
 lemma distinct_concat':
   "\<lbrakk>distinct [ys\<leftarrow>xs. ys \<noteq> Nil]; \<And>ys. ys \<in> set xs \<Longrightarrow> distinct ys;
    \<And>ys zs. \<lbrakk>ys \<in> set xs; zs \<in> set xs; ys \<noteq> zs\<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}\<rbrakk>
   \<Longrightarrow> distinct (concat xs)"
 by(erule distinct_concat[of "[ys\<leftarrow>xs. ys \<noteq> Nil]", unfolded concat_filter_neq_Nil]) auto
 
 lemma distinct_idx:
   assumes "distinct (map f l)"
   assumes "i<length l"
   assumes "j<length l"
   assumes "f (l!i) = f (l!j)"
   shows "i=j"
   by (metis assms distinct_conv_nth length_map nth_map)
 
 lemma replicate_Suc_conv_snoc:
   "replicate (Suc n) x = replicate n x @ [x]"
 by (metis replicate_Suc replicate_append_same)
 
 
 lemma filter_nth_ex_nth:
   assumes "n < length (filter P xs)"
   shows "\<exists>m. n \<le> m \<and> m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
 using assms
 proof(induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs)
   show ?case
   proof(cases "P x")
     case [simp]: False
     from \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
     hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)" by(rule snoc)
     thus ?thesis by(auto simp add: nth_append)
   next
     case [simp]: True
     show ?thesis
     proof(cases "n = length (filter P xs)")
       case False
       with \<open>n < length (filter P (xs @ [x]))\<close> have "n < length (filter P xs)" by simp
       moreover hence "\<exists>m\<ge>n. m < length xs \<and> filter P xs ! n = xs ! m \<and> filter P (take m xs) = take n (filter P xs)"
         by(rule snoc)
       ultimately show ?thesis by(auto simp add: nth_append)
     next
       case [simp]: True
       hence "filter P (xs @ [x]) ! n = (xs @ [x]) ! length xs" by simp
       moreover have "length xs < length (xs @ [x])" by simp
       moreover have "length xs \<ge> n" by simp
       moreover have "filter P (take (length xs) (xs @ [x])) = take n (filter P (xs @ [x]))" by simp
       ultimately show ?thesis by blast
     qed
   qed
 qed
 
 lemma set_map_filter:
   "set (List.map_filter g xs) = {y. \<exists>x. x \<in> set xs \<and> g x = Some y}"
   by (induct xs) (auto simp add: List.map_filter_def set_eq_iff)
 
     
     
     
     
 
 subsection \<open>Quicksort by Relation\<close>
 
 text \<open>A functional implementation of quicksort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun partition_rev :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "partition_rev P (yes, no) [] = (yes, no)"
  | "partition_rev P (yes, no) (x # xs) =
       partition_rev P (if P x then (x # yes, no) else (yes, x # no)) xs"
 
 lemma partition_rev_filter_conv :
   "partition_rev P (yes, no) xs = (rev (filter P xs) @ yes,  rev (filter (Not \<circ> P) xs) @ no)"
 by (induct xs arbitrary: yes no) (simp_all)
 
 function quicksort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "quicksort_by_rel R sl [] = sl"
 | "quicksort_by_rel R sl (x#xs) =
    (let (xs_s, xs_b) = partition_rev (\<lambda>y. R y x) ([],[]) xs in
     quicksort_by_rel R (x # (quicksort_by_rel R sl xs_b)) xs_s)"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(_, _, xs). length xs)")
    (simp_all add: partition_rev_filter_conv less_Suc_eq_le)
 
 lemma quicksort_by_rel_remove_acc :
   "quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp1a = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2"]
     note ind_hyp1b = ind_hyp[OF length_le(1), of "x # quicksort_by_rel R [] xs2 @ sl"]
     note ind_hyp2 = ind_hyp[OF length_le(2), of sl]
 
     show ?thesis by (simp add: ind_hyp1a ind_hyp1b ind_hyp2)
   qed
 qed
 
 lemma quicksort_by_rel_remove_acc_guared :
   "sl \<noteq> [] \<Longrightarrow> quicksort_by_rel R sl xs = (quicksort_by_rel R [] xs @ sl)"
 by (metis quicksort_by_rel_remove_acc)
 
 lemma quicksort_by_rel_permutes [simp]:
   "mset (quicksort_by_rel R sl xs) = mset (xs @ sl)"
 proof (induct xs arbitrary: sl rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs'_multi_eq : "mset xs' = mset xs1 + mset xs2"
       unfolding partition_rev_filter_conv
       by (simp add: mset_filter)
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis by (simp add: xs'_multi_eq union_assoc)
   qed
 qed
 
 lemma set_quicksort_by_rel [simp]: "set (quicksort_by_rel R sl xs) = set (xs @ sl)"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_quicksort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (quicksort_by_rel R [] xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
 
     obtain xs1 xs2 where part_rev_eq[simp]: "partition_rev (\<lambda>y. R y x) ([], []) xs' = (xs1, xs2)"
       by (rule prod.exhaust)
 
     from part_rev_eq[symmetric] have xs1_props: "\<And>y. y \<in> set xs1 \<Longrightarrow> (R y x)" and
                                      xs2_props: "\<And>y. y \<in> set xs2 \<Longrightarrow> \<not>(R y x)"
       unfolding partition_rev_filter_conv
       by simp_all
 
     from xs2_props lin have xs2_props': "\<And>y. y \<in> set xs2 \<Longrightarrow> (R x y)" by blast
     from xs2_props' xs1_props trans_R have xs1_props':
       "\<And>y1 y2. y1 \<in> set xs1 \<Longrightarrow> y2 \<in> set xs2 \<Longrightarrow> (R y1 y2)"
       by metis
 
     from part_rev_eq[symmetric]
     have length_le: "length xs1 < length xs" "length xs2 < length xs"
       unfolding partition_rev_filter_conv by (simp_all add: less_Suc_eq_le)
 
     note ind_hyps = ind_hyp[OF length_le(1)] ind_hyp[OF length_le(2)]
     thus ?thesis
       by (simp add: quicksort_by_rel_remove_acc_guared sorted_wrt_append Ball_def
                     xs1_props xs2_props' xs1_props')
   qed
 qed
 
 lemma sorted_quicksort_by_rel:
   "sorted (quicksort_by_rel (\<le>) [] xs)"
   by (rule sorted_wrt_quicksort_by_rel) auto
 
 lemma sort_quicksort_by_rel:
   "sort = quicksort_by_rel (\<le>) []"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_quicksort_by_rel)
 done
 
 lemma [code]: "quicksort = quicksort_by_rel (\<le>) []"
   apply (subst sort_quicksort[symmetric])
   by (rule sort_quicksort_by_rel)
 
 subsection \<open>Mergesort by Relation\<close>
 
 text \<open>A functional implementation of mergesort on lists. It it similar to the
 one in Isabelle/HOL's example directory. However, it uses tail-recursion for append and arbitrary
 relations.\<close>
 
 fun mergesort_by_rel_split :: "('a list \<times> 'a list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> 'a list)" where
    "mergesort_by_rel_split (xs1, xs2) [] = (xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) [x] = (x # xs1, xs2)"
  | "mergesort_by_rel_split (xs1, xs2) (x1 # x2 # xs) =
     mergesort_by_rel_split (x1 # xs1, x2 # xs2) xs"
 
 lemma list_induct_first2 [consumes 0, case_names Nil Sing Cons2]:
 assumes "P []" "\<And>x. P [x]" "\<And>x1 x2 xs. P xs \<Longrightarrow> P (x1 # x2 #xs)"
 shows "P xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis using assms(1) by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis using assms(2) by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
       show ?thesis
         by (simp add: ind_hyp assms(3))
     qed
   qed
 qed
 
 lemma mergesort_by_rel_split_length :
   "length (fst (mergesort_by_rel_split (xs1, xs2) xs)) = length xs1 + (length xs div 2) + (length xs mod 2) \<and>
    length (snd (mergesort_by_rel_split (xs1, xs2) xs)) = length xs2 + (length xs div 2)"
 by (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
    (simp_all)
 
 lemma mset_mergesort_by_rel_split [simp]:
   "mset (fst (mergesort_by_rel_split (xs1, xs2) xs)) +
    mset (snd (mergesort_by_rel_split (xs1, xs2) xs)) =
    mset xs + mset xs1 + mset xs2"
   apply (induct xs arbitrary: xs1 xs2 rule: list_induct_first2)
   apply (simp_all add: ac_simps)
 done
 
 fun mergesort_by_rel_merge :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
 | "mergesort_by_rel_merge R xs [] = xs"
 | "mergesort_by_rel_merge R [] ys = ys"
 
 declare mergesort_by_rel_merge.simps [simp del]
 
 lemma mergesort_by_rel_merge_simps[simp] :
   "mergesort_by_rel_merge R (x#xs) (y#ys) =
      (if R x y then x # mergesort_by_rel_merge R xs (y#ys) else y # mergesort_by_rel_merge R (x#xs) ys)"
   "mergesort_by_rel_merge R xs [] = xs"
   "mergesort_by_rel_merge R [] ys = ys"
   apply (simp_all add: mergesort_by_rel_merge.simps)
   apply (cases ys)
   apply (simp_all add: mergesort_by_rel_merge.simps)
 done
 
 lemma mergesort_by_rel_merge_induct [consumes 0, case_names Nil1 Nil2 Cons1 Cons2]:
 assumes "\<And>xs::'a list. P xs []" "\<And>ys::'b list. P [] ys"
         "\<And>x xs y ys. R x y \<Longrightarrow> P xs (y # ys) \<Longrightarrow> P (x # xs) (y # ys)"
         "\<And>x xs y ys. \<not>(R x y) \<Longrightarrow> P (x # xs) ys \<Longrightarrow> P (x # xs) (y # ys)"
 shows "P xs ys"
 proof (induct xs arbitrary: ys)
   case Nil thus ?case using assms(2) by simp
 next
   case (Cons x xs) note P_xs = this
   show ?case
   proof (induct ys)
     case Nil thus ?case using assms(1) by simp
   next
     case (Cons y ys) note P_x_xs_ys = this
     show ?case using assms(3,4)[of x y xs ys] P_x_xs_ys P_xs by metis
   qed
 qed
 
 lemma mset_mergesort_by_rel_merge [simp]:
   "mset (mergesort_by_rel_merge R xs ys) = mset xs + mset ys"
 by (induct R xs ys rule: mergesort_by_rel_merge.induct) (simp_all add: ac_simps)
 
 lemma set_mergesort_by_rel_merge [simp]:
   "set (mergesort_by_rel_merge R xs ys) = set xs \<union> set ys"
   by (induct R xs ys rule: mergesort_by_rel_merge.induct) auto
 
 lemma sorted_wrt_mergesort_by_rel_merge [simp]:
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows  "sorted_wrt R (mergesort_by_rel_merge R xs ys) \<longleftrightarrow>
           sorted_wrt R xs \<and> sorted_wrt R ys"
 proof (induct xs ys rule: mergesort_by_rel_merge_induct[where R = R])
   case Nil1 thus ?case by simp
 next
   case Nil2 thus ?case by simp
 next
   case (Cons1 x xs y ys) thus ?case
     by (simp add: Ball_def) (metis trans_R)
 next
   case (Cons2 x xs y ys) thus ?case
     apply (auto simp add: Ball_def)
     apply (metis lin)
     apply (metis lin trans_R)
   done
 qed
 
 function mergesort_by_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
   "mergesort_by_rel R xs =
     (if length xs < 2 then xs else
      (mergesort_by_rel_merge R
        (mergesort_by_rel R (fst (mergesort_by_rel_split ([], []) xs)))
        (mergesort_by_rel R (snd (mergesort_by_rel_split ([], []) xs)))))"
 by auto
 termination
 by (relation "measure (\<lambda>(_, xs). length xs)")
   (simp_all add: mergesort_by_rel_split_length not_less minus_div_mult_eq_mod [symmetric])
 
 declare mergesort_by_rel.simps [simp del]
 
 lemma mergesort_by_rel_simps [simp, code] :
   "mergesort_by_rel R [] = []"
   "mergesort_by_rel R [x] = [x]"
   "mergesort_by_rel R (x1 # x2 # xs) =
    (let (xs1, xs2) = (mergesort_by_rel_split ([x1], [x2]) xs) in
    mergesort_by_rel_merge R (mergesort_by_rel R xs1) (mergesort_by_rel R xs2))"
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps)
 apply (simp add: mergesort_by_rel.simps[of _ "x1 # x2 # xs"] split: prod.splits)
 done
 
 lemma mergesort_by_rel_permutes [simp]:
   "mset (mergesort_by_rel R xs) = mset xs"
 proof (induct xs rule: length_induct)
   case (1 xs) note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x1 xs') note xs_eq[simp] = this
     show ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: ac_simps)
     qed
   qed
 qed
 
 lemma set_mergesort_by_rel [simp]: "set (mergesort_by_rel R xs) = set xs"
   unfolding set_mset_comp_mset [symmetric] o_apply by simp
 
 lemma sorted_wrt_mergesort_by_rel:
   fixes R:: "'x \<Rightarrow> 'x \<Rightarrow> bool"
   assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
       and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   shows "sorted_wrt R (mergesort_by_rel R xs)"
 proof (induct xs rule: measure_induct_rule[of "length"])
   case (less xs)
   note ind_hyp = this
 
   show ?case
   proof (cases xs)
     case Nil thus ?thesis by simp
   next
     case (Cons x xs') note xs_eq[simp] = this
     thus ?thesis
     proof (cases xs')
       case Nil thus ?thesis by simp
     next
       case (Cons x2 xs'') note xs'_eq[simp] = this
 
       have "length (fst (mergesort_by_rel_split ([], []) xs)) < length xs"
            "length (snd (mergesort_by_rel_split ([], []) xs)) < length xs"
         by (simp_all add: mergesort_by_rel_split_length)
       with ind_hyp show ?thesis
         unfolding mergesort_by_rel.simps[of _ xs]
         by (simp add: sorted_wrt_mergesort_by_rel_merge[OF lin trans_R])
     qed
   qed
 qed
 
 lemma sorted_mergesort_by_rel:
   "sorted (mergesort_by_rel (\<le>) xs)"
 by (rule sorted_wrt_mergesort_by_rel) auto
 
 lemma sort_mergesort_by_rel:
   "sort = mergesort_by_rel (\<le>)"
   apply (rule ext, rule properties_for_sort)
   apply(simp_all add: sorted_mergesort_by_rel)
 done
 
 definition "mergesort = mergesort_by_rel (\<le>)"
 
 lemma sort_mergesort: "sort = mergesort"
   unfolding mergesort_def by (rule sort_mergesort_by_rel)
 
 subsubsection \<open>Mergesort with Remdup\<close>
 term merge
 
 fun merge :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "merge [] l2 = l2"
  | "merge l1 [] = l1"
  | "merge (x1 # l1) (x2 # l2) =
     (if (x1 < x2) then x1 # (merge l1 (x2 # l2)) else
      (if (x1 = x2) then x1 # (merge l1 l2) else x2 # (merge (x1 # l1) l2)))"
 
 lemma merge_correct :
 assumes l1_OK: "distinct l1 \<and> sorted l1"
 assumes l2_OK: "distinct l2 \<and> sorted l2"
 shows "distinct (merge l1 l2) \<and> sorted (merge l1 l2) \<and> set (merge l1 l2) = set l1 \<union> set l2"
 using assms
 proof (induct l1 arbitrary: l2)
   case Nil thus ?case by simp
 next
   case (Cons x1 l1 l2)
   note x1_l1_props = Cons(2)
   note l2_props = Cons(3)
 
   from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                     and x1_nin_l1: "x1 \<notin> set l1"
                     and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
     by (simp_all add: Ball_def)
 
   note ind_hyp_l1 = Cons(1)[OF l1_props]
 
   show ?case
   using l2_props
   proof (induct l2)
     case Nil with x1_l1_props show ?case by simp
   next
     case (Cons x2 l2)
     note x2_l2_props = Cons(2)
     from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                     and x2_nin_l2: "x2 \<notin> set l2"
                     and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
     by (simp_all add: Ball_def)
 
     note ind_hyp_l2 = Cons(1)[OF l2_props]
     show ?case
     proof (cases "x1 < x2")
       case True note x1_less_x2 = this
 
       from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
       show ?thesis
         apply (auto simp add: Ball_def)
         apply (metis linorder_not_le)
         apply (metis linorder_not_less xt1(6) xt1(9))
       done
     next
       case False note x2_le_x1 = this
 
       show ?thesis
       proof (cases "x1 = x2")
         case True note x1_eq_x2 = this
 
         from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
         show ?thesis by (simp add: x1_eq_x2 Ball_def)
       next
         case False note x1_neq_x2 = this
         with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto
 
         from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
         show ?thesis
           apply (simp add: x2_less_x1 Ball_def)
           apply (metis linorder_not_le x2_less_x1 xt1(7))
         done
       qed
     qed
   qed
 qed
 
 function merge_list :: "'a::{linorder} list list \<Rightarrow> 'a list list \<Rightarrow> 'a list" where
    "merge_list [] [] = []"
  | "merge_list [] [l] = l"
  | "merge_list (la # acc2) [] = merge_list [] (la # acc2)"
  | "merge_list (la # acc2) [l] = merge_list [] (l # la # acc2)"
  | "merge_list acc2 (l1 # l2 # ls) =
     merge_list ((merge l1 l2) # acc2) ls"
 by pat_completeness simp_all
 termination
 by (relation "measure (\<lambda>(acc, ls). 3 * length acc + 2 * length ls)") (simp_all)
 
 lemma merge_list_correct :
 assumes ls_OK: "\<And>l. l \<in> set ls \<Longrightarrow> distinct l \<and> sorted l"
 assumes as_OK: "\<And>l. l \<in> set as \<Longrightarrow> distinct l \<and> sorted l"
 shows "distinct (merge_list as ls) \<and> sorted (merge_list as ls) \<and>
        set (merge_list as ls) = set (concat (as @ ls))"
 using assms
 proof (induct as ls rule: merge_list.induct)
   case 1 thus ?case by simp
 next
   case 2 thus ?case by simp
 next
   case 3 thus ?case by simp
 next
   case 4 thus ?case by auto
 next
   case (5 acc l1 l2 ls)
   note ind_hyp = 5(1)
   note l12_l_OK = 5(2)
   note acc_OK = 5(3)
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
     have set_merge_eq: "set (merge l1 l2) = set l1 \<union> set l2" by auto
 
   from l12_l_OK acc_OK merge_correct[of l1 l2]
   have "distinct (merge_list (merge l1 l2 # acc) ls) \<and>
         sorted (merge_list (merge l1 l2 # acc) ls) \<and>
         set (merge_list (merge l1 l2 # acc) ls) =
         set (concat ((merge l1 l2 # acc) @ ls))"
     by (rule_tac ind_hyp) auto
   with set_merge_eq show ?case by auto
 qed
 
 
 definition mergesort_remdups where
   "mergesort_remdups xs = merge_list [] (map (\<lambda>x. [x]) xs)"
 
 lemma mergesort_remdups_correct :
   "distinct (mergesort_remdups l)
   \<and> sorted (mergesort_remdups l)
   \<and> (set (mergesort_remdups l) = set l)"
 proof -
   let ?l' = "map (\<lambda>x. [x]) l"
 
   { fix xs
     assume "xs \<in> set ?l'"
     then obtain x where xs_eq: "xs = [x]" by auto
     hence "distinct xs \<and> sorted xs" by simp
   } note l'_OK = this
 
   from merge_list_correct[of "?l'" "[]", OF l'_OK]
   show ?thesis unfolding mergesort_remdups_def by simp
 qed
 
 (* TODO: Move *)
 lemma ex1_eqI: "\<lbrakk>\<exists>!x. P x; P a; P b\<rbrakk> \<Longrightarrow> a=b"
   by blast
 
 lemma remdup_sort_mergesort_remdups:
   "remdups o sort = mergesort_remdups" (is "?lhs=?rhs")
 proof
   fix l
   have "set (?lhs l) = set l" and "sorted (?lhs l)" and "distinct (?lhs l)"
     by simp_all
   moreover note mergesort_remdups_correct
   ultimately show "?lhs l = ?rhs l"
     by (auto intro!: ex1_eqI[OF finite_sorted_distinct_unique[OF finite_set]])
 qed
 
 subsection \<open>Native Integers\<close>  
 lemma int_of_integer_less_iff: "int_of_integer x < int_of_integer y \<longleftrightarrow> x<y"
   by (simp add: less_integer_def)
 
 lemma nat_of_integer_less_iff: "x\<ge>0 \<Longrightarrow> y\<ge>0 \<Longrightarrow> nat_of_integer x < nat_of_integer y \<longleftrightarrow> x<y"
   unfolding nat_of_integer.rep_eq
   by (auto simp: int_of_integer_less_iff nat_less_eq_zless int_of_integer_less_iff[of 0, simplified])
   
   
 subsection "Natural Numbers"
 lemma exists_leI:
   assumes hyp: "(\<forall>n' < n. \<not> P n') \<Longrightarrow> P (n::nat)"
   shows "\<exists>n' \<le> n. P n'"
 proof (rule classical)
   assume contra: "\<not> (\<exists>n'\<le>n. P n')"
   hence "\<forall>n' < n. \<not> P n'" by auto
   hence "P n" by (rule hyp)
   thus "\<exists>n'\<le>n. P n'" by auto
 qed
 
 subsubsection \<open>Induction on nat\<close>
   lemma nat_compl_induct[case_names 0 Suc]: "\<lbrakk>P 0; \<And>n . \<forall>nn. nn \<le> n \<longrightarrow> P nn \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nat_compl_induct'[case_names 0 Suc]: "\<lbrakk>P 0; !! n . \<lbrakk>!! nn . nn \<le> n \<Longrightarrow> P nn\<rbrakk> \<Longrightarrow> P (Suc n)\<rbrakk> \<Longrightarrow> P n"
     apply(induct_tac n rule: nat_less_induct)
     apply(case_tac n)
     apply(auto)
   done
 
   lemma nz_le_conv_less: "0<k \<Longrightarrow> k \<le> m \<Longrightarrow> k - Suc 0 < m"
     by auto
       
   lemma min_Suc_gt[simp]: 
     "a<b \<Longrightarrow> min (Suc a) b = Suc a"  
     "a<b \<Longrightarrow> min b (Suc a) = Suc a"  
     by auto
     
     
 subsection \<open>Integer\<close>
 
 text \<open>Some setup from \<open>int\<close> transferred to \<open>integer\<close>\<close>
 
 lemma atLeastLessThanPlusOne_atLeastAtMost_integer: "{l..<u+1} = {l..(u::integer)}"
   apply (auto simp add: atLeastAtMost_def atLeastLessThan_def)
   including integer.lifting
   apply transfer
   apply simp
   done
 
 lemma atLeastPlusOneAtMost_greaterThanAtMost_integer: "{l+1..u} = {l<..(u::integer)}"
   including integer.lifting
   by (auto simp add: atLeastAtMost_def greaterThanAtMost_def, transfer, simp)
 
 lemma atLeastPlusOneLessThan_greaterThanLessThan_integer:
     "{l+1..<u} = {l<..<u::integer}"
   including integer.lifting
   by (auto simp add: atLeastLessThan_def greaterThanLessThan_def, transfer, simp)
 
 lemma image_atLeastZeroLessThan_integer: "0 \<le> u \<Longrightarrow>
     {(0::integer)..<u} = of_nat ` {..<nat_of_integer u}"
   including integer.lifting
   apply (unfold image_def lessThan_def)
   apply auto
   apply (rule_tac x = "nat_of_integer x" in exI)
   apply transfer
   apply (auto simp add: zless_nat_eq_int_zless [THEN sym])
   apply transfer
   apply simp
   done
 
 lemma image_add_integer_atLeastLessThan:
     "(%x. x + (l::integer)) ` {0..<u-l} = {l..<u}"
   apply (auto simp add: image_def)
   apply (rule_tac x = "x - l" in bexI)
   apply auto
   done
 
 lemma finite_atLeastZeroLessThan_integer: "finite {(0::integer)..<u}"
   apply (cases "0 \<le> u")
   apply (subst image_atLeastZeroLessThan_integer, assumption)
   apply (rule finite_imageI)
   apply auto
   done
 
 lemma finite_atLeastLessThan_integer [iff]: "finite {l..<u::integer}"
   apply (subgoal_tac "(%x. x + l) ` {0..<u-l} = {l..<u}")
   apply (erule subst)
   apply (rule finite_imageI)
   apply (rule finite_atLeastZeroLessThan_integer)
   apply (rule image_add_integer_atLeastLessThan)
   done
 
 lemma finite_atLeastAtMost_integer [iff]: "finite {l..(u::integer)}"
   by (subst atLeastLessThanPlusOne_atLeastAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanAtMost_integer [iff]: "finite {l<..(u::integer)}"
   by (subst atLeastPlusOneAtMost_greaterThanAtMost_integer [THEN sym], simp)
 
 lemma finite_greaterThanLessThan_integer [iff]: "finite {l<..<u::integer}"
   by (subst atLeastPlusOneLessThan_greaterThanLessThan_integer [THEN sym], simp)
 
 
 subsection \<open>Functions of type @{typ "bool\<Rightarrow>bool"}\<close>
   lemma boolfun_cases_helper: "g=(\<lambda>x. False) | g=(\<lambda>x. x) | g=(\<lambda>x. True) | g= (\<lambda>x. \<not>x)"
   proof -
     { assume "g False" "g True"
       hence "g = (\<lambda>x. True)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "g False" "\<not>g True"
       hence "g = (\<lambda>x. \<not>x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "g True"
       hence "g = (\<lambda>x. x)" by (rule_tac ext, case_tac x, auto)
     } moreover {
       assume "\<not>g False" "\<not>g True"
       hence "g = (\<lambda>x. False)" by (rule_tac ext, case_tac x, auto)
     } ultimately show ?thesis by fast
   qed
 
   lemma boolfun_cases[case_names False Id True Neg]: "\<lbrakk>g=(\<lambda>x. False) \<Longrightarrow> P; g=(\<lambda>x. x) \<Longrightarrow> P; g=(\<lambda>x. True) \<Longrightarrow> P; g=(\<lambda>x. \<not>x) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   proof -
     note boolfun_cases_helper[of g]
     moreover assume "g=(\<lambda>x. False) \<Longrightarrow> P" "g=(\<lambda>x. x) \<Longrightarrow> P" "g=(\<lambda>x. True) \<Longrightarrow> P" "g=(\<lambda>x. \<not>x) \<Longrightarrow> P"
     ultimately show ?thesis by fast
   qed
 
 
 subsection \<open>Definite and indefinite description\<close>
         text "Combined definite and indefinite description for binary predicate"
   lemma some_theI: assumes EX: "\<exists>a b . P a b" and BUN: "!! b1 b2 . \<lbrakk>\<exists>a . P a b1; \<exists>a . P a b2\<rbrakk> \<Longrightarrow> b1=b2"
     shows "P (SOME a . \<exists>b . P a b) (THE b . \<exists>a . P a b)"
   proof -
                 from EX have "\<exists>b. P (SOME a. \<exists>b. P a b) b" by (rule someI_ex)
                 moreover from EX have "\<exists>b. \<exists>a. P a b" by blast
     with BUN theI'[of "\<lambda>b. \<exists>a. P a b"] have "\<exists>a. P a (THE b. \<exists>a. P a b)" by (unfold Ex1_def, blast)
                 moreover note BUN
                 ultimately show ?thesis by (fast)
         qed
 
   lemma some_insert_self[simp]: "S\<noteq>{} \<Longrightarrow> insert (SOME x. x\<in>S) S = S"
     by (auto intro: someI)
 
   lemma some_elem[simp]: "S\<noteq>{} \<Longrightarrow> (SOME x. x\<in>S) \<in> S"
     by (auto intro: someI)
 
 subsubsection\<open>Hilbert Choice with option\<close>
 
 definition Eps_Opt where
   "Eps_Opt P = (if (\<exists>x. P x) then Some (SOME x. P x) else None)"
 
 lemma some_opt_eq_trivial[simp] :
   "Eps_Opt (\<lambda>y. y = x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_sym_eq_trivial[simp] :
   "Eps_Opt ((=) x) = Some x"
 unfolding Eps_Opt_def by simp
 
 lemma some_opt_false_trivial[simp] :
   "Eps_Opt (\<lambda>_. False) = None"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_None[simp] :
   "Eps_Opt P = None \<longleftrightarrow> \<not>(Ex P)"
 unfolding Eps_Opt_def by simp
 
 lemma Eps_Opt_eq_Some_implies :
   "Eps_Opt P = Some x \<Longrightarrow> P x"
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 lemma Eps_Opt_eq_Some :
 assumes P_prop: "\<And>x'. P x \<Longrightarrow> P x' \<Longrightarrow> x' = x"
 shows "Eps_Opt P = Some x \<longleftrightarrow> P x"
 using P_prop
 unfolding Eps_Opt_def
 by (metis option.inject option.simps(2) someI_ex)
 
 subsection \<open>Product Type\<close>
 
 lemma nested_case_prod_simp: "(\<lambda>(a,b) c. f a b c) x y =
   (case_prod (\<lambda>a b. f a b y) x)"
   by (auto split: prod.split)
 
 lemma fn_fst_conv: "(\<lambda>x. (f (fst x))) = (\<lambda>(a,_). f a)"
   by auto
 lemma fn_snd_conv: "(\<lambda>x. (f (snd x))) = (\<lambda>(_,b). f b)"
   by auto
 
 fun pairself where
   "pairself f (a,b) = (f a, f b)"
 
 lemma pairself_image_eq[simp]:
   "pairself f ` {(a,b). P a b} = {(f a, f b)| a b. P a b}"
   by force
 
 lemma pairself_image_cart[simp]: "pairself f ` (A\<times>B) = f`A \<times> f`B"
   by (auto simp: image_def)
 
 lemma in_prod_fst_sndI: "fst x \<in> A \<Longrightarrow> snd x \<in> B \<Longrightarrow> x\<in>A\<times>B"
   by (cases x) auto
 
 lemma inj_Pair[simp]:
   "inj_on (\<lambda>x. (x,c x)) S"
   "inj_on (\<lambda>x. (c x,x)) S"
   by (auto intro!: inj_onI)
 
 declare Product_Type.swap_inj_on[simp]
 
 lemma img_fst [intro]:
   assumes "(a,b) \<in> S"
   shows "a \<in> fst ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma img_snd [intro]:
   assumes "(a,b) \<in> S"
   shows "b \<in> snd ` S"
 by (rule image_eqI[OF _ assms]) simp
 
 lemma range_prod:
   "range f \<subseteq> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
 proof
   fix y
   assume "y \<in> range f"
   then obtain x where y: "y = f x" by auto
   hence "y = (fst(f x), snd(f x))"
     by simp
   thus "y \<in> (range (fst \<circ> f)) \<times> (range (snd \<circ> f))"
     by (fastforce simp add: image_def)
 qed
 
 lemma finite_range_prod:
   assumes fst: "finite (range (fst \<circ> f))"
   and     snd: "finite (range (snd \<circ> f))"
   shows "finite (range f)"
 proof -
   from fst snd have "finite (range (fst \<circ> f) \<times> range (snd \<circ> f))"
     by (rule finite_SigmaI)
   thus ?thesis
     by (rule finite_subset[OF range_prod])
 qed
 
 lemma fstE:
   "x = (a,b) \<Longrightarrow> P (fst x) \<Longrightarrow> P a"
 by (metis fst_conv)
 
 lemma sndE:
   "x = (a,b) \<Longrightarrow> P (snd x) \<Longrightarrow> P b"
 by (metis snd_conv)
 
 subsubsection \<open>Uncurrying\<close>
 
 (* TODO: Move to HOL/Product_Type? Lars H: "It's equal to case_prod, should use an abbreviation"*)
 definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" where
   "uncurry f \<equiv> \<lambda>(a,b). f a b"
 
 lemma uncurry_apply[simp]: "uncurry f (a,b) = f a b"
   unfolding uncurry_def
   by simp
 
 lemma curry_uncurry_id[simp]: "curry (uncurry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma uncurry_curry_id[simp]: "uncurry (curry f) = f"
   unfolding uncurry_def
   by simp
 
 lemma do_curry: "f (a,b) = curry f a b" by simp
 lemma do_uncurry: "f a b = uncurry f (a,b)" by simp
   
 subsection \<open>Sum Type\<close>    
 lemma map_sum_Inr_conv: "map_sum fl fr s = Inr y \<longleftrightarrow> (\<exists>x. s=Inr x \<and> y = fr x)"
   by (cases s) auto
 lemma map_sum_Inl_conv: "map_sum fl fr s = Inl y \<longleftrightarrow> (\<exists>x. s=Inl x \<and> y = fl x)"
   by (cases s) auto
   
   
 subsection \<open>Directed Graphs and Relations\<close>
 
   subsubsection "Reflexive-Transitive Closure"
   lemma r_le_rtrancl[simp]: "S\<subseteq>S\<^sup>*" by auto
   lemma rtrancl_mono_rightI: "S\<subseteq>S' \<Longrightarrow> S\<subseteq>S'\<^sup>*" by auto
 
   lemma trancl_sub:
     "R \<subseteq> R\<^sup>+"
   by auto
 
   lemma trancl_single[simp]:
     "{(a,b)}\<^sup>+ = {(a,b)}"
     by (auto simp: trancl_insert)
 
 
   text \<open>Pick first non-reflexive step\<close>
   lemma converse_rtranclE'[consumes 1, case_names base step]:
     assumes "(u,v)\<in>R\<^sup>*"
     obtains "u=v"
     | vh where "u\<noteq>vh" and "(u,vh)\<in>R" and "(vh,v)\<in>R\<^sup>*"
     using assms
     apply (induct rule: converse_rtrancl_induct)
     apply auto []
     apply (case_tac "y=z")
     apply auto
     done
 
   lemma in_rtrancl_insert: "x\<in>R\<^sup>* \<Longrightarrow> x\<in>(insert r R)\<^sup>*"
     by (metis in_mono rtrancl_mono subset_insertI)
 
 
   lemma rtrancl_apply_insert: "R\<^sup>*``(insert x S) = insert x (R\<^sup>*``(S\<union>R``{x}))"
     apply (auto)
     apply (erule converse_rtranclE)
     apply auto [2]
     apply (erule converse_rtranclE)
     apply (auto intro: converse_rtrancl_into_rtrancl) [2]
     done
 
 
 
 
   text \<open>A path in a graph either does not use nodes from S at all, or it has a prefix leading to a node in S and a suffix that does not use nodes in S\<close>
   lemma rtrancl_last_visit[cases set, case_names no_visit last_visit_point]:
     shows
     "\<lbrakk> (q,q')\<in>R\<^sup>*;
        (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P;
        !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>+; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P
      \<rbrakk> \<Longrightarrow> P"
   proof (induct rule: converse_rtrancl_induct[case_names refl step])
     case refl thus ?case by auto
   next
     case (step q qh)
     show P proof (rule step.hyps(3))
       assume A: "(qh,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       show P proof (cases "qh\<in>S")
         case False
         with step.hyps(1) A have "(q,q')\<in>(R-UNIV\<times>S)\<^sup>*"
           by (auto intro: converse_rtrancl_into_rtrancl)
         with step.prems(1) show P .
       next
         case True
         from step.hyps(1) have "(q,qh)\<in>R\<^sup>+" by auto
         with step.prems(2) True A show P by blast
       qed
     next
       fix qt
       assume A: "qt\<in>S" "(qh,qt)\<in>R\<^sup>+" "(qt,q')\<in>(R-UNIV\<times>S)\<^sup>*"
       with step.hyps(1) have "(q,qt)\<in>R\<^sup>+" by auto
       with step.prems(2) A(1,3) show P by blast
     qed
   qed
 
   text \<open>Less general version of \<open>rtrancl_last_visit\<close>, but there's a short automatic proof\<close>
   lemma rtrancl_last_visit': "\<lbrakk> (q,q')\<in>R\<^sup>*; (q,q')\<in>(R-UNIV\<times>S)\<^sup>* \<Longrightarrow> P; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (induct rule: converse_rtrancl_induct) (auto intro: converse_rtrancl_into_rtrancl)
 
   lemma rtrancl_last_visit_node:
     assumes "(s,s')\<in>R\<^sup>*"
     shows "s\<noteq>sh \<and> (s,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>* \<or>
             (s,sh)\<in>R\<^sup>* \<and> (sh,s')\<in>(R \<inter> (UNIV \<times> (-{sh})))\<^sup>*"
     using assms
   proof (induct rule: converse_rtrancl_induct)
     case base thus ?case by auto
   next
     case (step s st)
     moreover {
       assume P: "(st,s')\<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       {
         assume "st=sh" with step have ?case
           by auto
       } moreover {
         assume "st\<noteq>sh"
         with \<open>(s,st)\<in>R\<close> have "(s,st)\<in>(R \<inter> UNIV \<times> - {sh})\<^sup>*" by auto
         also note P
         finally have ?case by blast
       } ultimately have ?case by blast
     } moreover {
       assume P: "(st, sh) \<in> R\<^sup>* \<and> (sh, s') \<in> (R \<inter> UNIV \<times> - {sh})\<^sup>*"
       with step(1) have ?case
         by (auto dest: converse_rtrancl_into_rtrancl)
     } ultimately show ?case by blast
   qed
 
   text \<open>Find last point where a path touches a set\<close>
   lemma rtrancl_last_touch: "\<lbrakk> (q,q')\<in>R\<^sup>*; q\<in>S; !!qt. \<lbrakk> qt\<in>S; (q,qt)\<in>R\<^sup>*; (qt,q')\<in>(R-UNIV\<times>S)\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (erule rtrancl_last_visit') auto
 
   text \<open>A path either goes over edge once, or not at all\<close>
   lemma trancl_over_edgeE:
     assumes "(u,w)\<in>(insert (v1,v2) E)\<^sup>+"
     obtains "(u,w)\<in>E\<^sup>+"
     | "(u,v1)\<in>E\<^sup>*" and "(v2,w)\<in>E\<^sup>*"
     using assms
   proof induct
     case (base z) thus ?thesis
       by (metis insertE prod.inject r_into_trancl' rtrancl_eq_or_trancl)
   next
     case (step y z) thus ?thesis
       by (metis (opaque_lifting, no_types)
         Pair_inject insertE rtrancl.simps trancl.simps trancl_into_rtrancl)
   qed
 
   lemma rtrancl_image_advance: "\<lbrakk>q\<in>R\<^sup>* `` Q0; (q,x)\<in>R\<rbrakk> \<Longrightarrow> x\<in>R\<^sup>* `` Q0"
     by (auto intro: rtrancl_into_rtrancl)
 
   lemma trancl_image_by_rtrancl: "(E\<^sup>+)``Vi \<union> Vi = (E\<^sup>*)``Vi"
     by (metis Image_Id Un_Image rtrancl_trancl_reflcl)
 
   lemma reachable_mono: "\<lbrakk>R\<subseteq>R'; X\<subseteq>X'\<rbrakk> \<Longrightarrow> R\<^sup>*``X \<subseteq> R'\<^sup>*``X'"
     by (metis Image_mono rtrancl_mono)
 
   lemma finite_reachable_advance:
     "\<lbrakk> finite (E\<^sup>*``{v0}); (v0,v)\<in>E\<^sup>* \<rbrakk> \<Longrightarrow> finite (E\<^sup>*``{v})"
     by (erule finite_subset[rotated]) auto
 
 lemma rtrancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>* \<Longrightarrow> x\<in>V\<^sup>*" by (metis in_mono rtrancl_mono)
 lemma trancl_mono_mp: "U\<subseteq>V \<Longrightarrow> x\<in>U\<^sup>+ \<Longrightarrow> x\<in>V\<^sup>+" by (metis trancl_mono)
 
 lemma rtrancl_mapI: "(a,b)\<in>E\<^sup>* \<Longrightarrow> (f a, f b)\<in>(pairself f `E)\<^sup>*"
   apply (induction rule: rtrancl_induct)
   apply (force intro: rtrancl.intros)+
   done
 
 lemma rtrancl_image_advance_rtrancl:
   assumes "q \<in> R\<^sup>*``Q0"
   assumes "(q,x) \<in> R\<^sup>*"
   shows "x \<in> R\<^sup>*``Q0"
   using assms
   by (metis rtrancl_idemp rtrancl_image_advance)
 
 lemma nth_step_trancl:
   "\<And>n m. \<lbrakk> \<And> n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R \<rbrakk> \<Longrightarrow> n < length xs \<Longrightarrow> m < n \<Longrightarrow> (xs ! n, xs ! m) \<in> R\<^sup>+"
 proof (induction xs)
   case (Cons x xs)
   hence "\<And>n. n < length xs - 1 \<Longrightarrow> (xs ! Suc n, xs ! n) \<in> R"
     apply clarsimp
     by (metis One_nat_def diff_Suc_eq_diff_pred nth_Cons_Suc zero_less_diff)
   note IH = this[THEN Cons.IH]
 
   from Cons obtain n' where n': "Suc n' = n" by (cases n) blast+
 
   show ?case
   proof (cases m)
     case "0" with Cons have "xs \<noteq> []" by auto
     with "0" Cons.prems(1)[of m] have "(xs ! 0, x) \<in> R" by simp
     moreover from IH[where m = 0] have "\<And>n. n < length xs \<Longrightarrow> n > 0 \<Longrightarrow> (xs ! n, xs ! 0) \<in> R\<^sup>+" by simp
     ultimately have "\<And>n. n < length xs \<Longrightarrow> (xs ! n, x) \<in> R\<^sup>+" by (metis trancl_into_trancl gr0I r_into_trancl')
     with Cons "0" show ?thesis by auto
   next
     case (Suc m') with Cons.prems n' have "n' < length xs" "m' < n'" by auto
     with IH have "(xs ! n', xs ! m') \<in> R\<^sup>+" by simp
     with Suc n' show ?thesis by auto
   qed
 qed simp
 
 lemma Image_empty_trancl_Image_empty:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>+ `` {v} = {}"
   unfolding Image_def
   by (auto elim: converse_tranclE)
 
 lemma Image_empty_rtrancl_Image_id:
   "R `` {v} = {} \<Longrightarrow> R\<^sup>* `` {v} = {v}"
   unfolding Image_def
   by (auto elim: converse_rtranclE)
 
 lemma trans_rtrancl_eq_reflcl:
   "trans A \<Longrightarrow> A^* = A^="
   by (simp add: rtrancl_trancl_reflcl)
 
 lemma refl_on_reflcl_Image:
   "refl_on B A \<Longrightarrow> C \<subseteq> B \<Longrightarrow> A^= `` C = A `` C"
   by (auto simp add: Image_def dest: refl_onD)
 
 lemma Image_absorb_rtrancl:
   "\<lbrakk> trans A; refl_on B A; C \<subseteq> B \<rbrakk> \<Longrightarrow> A^* `` C = A `` C"
   by (simp add: trans_rtrancl_eq_reflcl refl_on_reflcl_Image)
 
 lemma trancl_Image_unfold_left: "E\<^sup>+``S = E\<^sup>*``E``S"
   by (auto simp: trancl_unfold_left)
 
 lemma trancl_Image_unfold_right: "E\<^sup>+``S = E``E\<^sup>*``S"
   by (auto simp: trancl_unfold_right)
 
 lemma trancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>+``{v} \<subseteq> E\<^sup>+``{u}"
   by auto
 
 lemma rtrancl_Image_advance_ss: "(u,v)\<in>E \<Longrightarrow> E\<^sup>*``{v} \<subseteq> E\<^sup>*``{u}"
   by auto
 
 (* FIXME: nicer name *)
 lemma trancl_union_outside:
   assumes "(v,w) \<in> (E\<union>U)\<^sup>+"
   and "(v,w) \<notin> E\<^sup>+"
   shows "\<exists>x y. (v,x) \<in> (E\<union>U)\<^sup>* \<and> (x,y) \<in> U \<and> (y,w) \<in> (E\<union>U)\<^sup>*"
 using assms
 proof (induction)
   case base thus ?case by auto
 next
   case (step w x)
   show ?case
   proof (cases "(v,w)\<in>E\<^sup>+")
     case True
     from step have "(v,w)\<in>(E\<union>U)\<^sup>*" by simp
     moreover from True step have "(w,x) \<in> U" by (metis Un_iff trancl.simps)
     moreover have "(x,x) \<in> (E\<union>U)\<^sup>*" by simp
     ultimately show ?thesis by blast
   next
     case False with step.IH obtain a b where "(v,a) \<in> (E\<union>U)\<^sup>*" "(a,b) \<in> U" "(b,w) \<in> (E\<union>U)\<^sup>*" by blast
     moreover with step have "(b,x) \<in> (E\<union>U)\<^sup>*" by (metis rtrancl_into_rtrancl)
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma trancl_restrict_reachable:
   assumes "(u,v) \<in> E\<^sup>+"
   assumes "E``S \<subseteq> S"
   assumes "u\<in>S"
   shows "(u,v) \<in> (E\<inter>S\<times>S)\<^sup>+"
   using assms
   by (induction rule: converse_trancl_induct)
      (auto intro: trancl_into_trancl2)
 
 lemma rtrancl_image_unfold_right: "E``E\<^sup>*``V \<subseteq> E\<^sup>*``V"
   by (auto intro: rtrancl_into_rtrancl)
 
 
 lemma trancl_Image_in_Range:
   "R\<^sup>+ `` V \<subseteq> Range R"
 by (auto elim: trancl.induct)
 
 lemma rtrancl_Image_in_Field:
   "R\<^sup>* `` V \<subseteq> Field R \<union> V"
 proof -
   from trancl_Image_in_Range have "R\<^sup>+ `` V \<subseteq> Field R"
     unfolding Field_def by fast
   hence "R\<^sup>+ `` V \<union> V \<subseteq> Field R \<union> V" by blast
   with trancl_image_by_rtrancl show ?thesis by metis
 qed
 
 lemma rtrancl_sub_insert_rtrancl:
   "R\<^sup>* \<subseteq> (insert x R)\<^sup>*"
 by (auto elim: rtrancl.induct rtrancl_into_rtrancl)
 
 lemma trancl_sub_insert_trancl:
   "R\<^sup>+ \<subseteq> (insert x R)\<^sup>+"
 by (auto elim: trancl.induct trancl_into_trancl)
 
 lemma Restr_rtrancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>* \<Longrightarrow> (v,w) \<in> E\<^sup>*"
   by (metis inf_le1 rtrancl_mono subsetCE)
 
 lemma Restr_trancl_mono:
   "(v,w) \<in> (Restr E U)\<^sup>+ \<Longrightarrow> (v,w) \<in> E\<^sup>+"
   by (metis inf_le1 trancl_mono)
 
 
 
 
 
 
 
 
   subsubsection "Converse Relation"
 
   lemmas converse_add_simps = converse_Times trancl_converse[symmetric] converse_Un converse_Int
 
   lemma dom_ran_disj_comp[simp]: "Domain R \<inter> Range R = {} \<Longrightarrow> R O R = {}"
     by auto
 
   lemma below_Id_inv[simp]: "R\<inverse>\<subseteq>Id \<longleftrightarrow> R\<subseteq>Id" by (auto)
     
     
   subsubsection "Cyclicity"
 
   lemma cyclicE: "\<lbrakk>\<not>acyclic g; !!x. (x,x)\<in>g\<^sup>+ \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
     by (unfold acyclic_def) blast
 
   lemma acyclic_insert_cyclic: "\<lbrakk>acyclic g; \<not>acyclic (insert (x,y) g)\<rbrakk> \<Longrightarrow> (y,x)\<in>g\<^sup>*"
     by (unfold acyclic_def) (auto simp add: trancl_insert)
 
 
   text \<open>
     This lemma makes a case distinction about a path in a graph where a couple of edges with the same
     endpoint have been inserted: If there is a path from a to b, then there's such a path in the original graph, or
     there's a path that uses an inserted edge only once.
 
     Originally, this lemma was used to reason about the graph of an updated acquisition history. Any path in
     this graph is either already contained in the original graph, or passes via an
     inserted edge. Because all the inserted edges point to the same target node, in the
     second case, the path can be short-circuited to use exactly one inserted edge.
 \<close>
   lemma trancl_multi_insert[cases set, case_names orig via]:
     "\<lbrakk> (a,b)\<in>(r\<union>X\<times>{m})\<^sup>+;
       (a,b)\<in>r\<^sup>+ \<Longrightarrow> P;
        !!x. \<lbrakk> x\<in>X; (a,x)\<in>r\<^sup>*; (m,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
   proof (induct arbitrary: P rule: trancl_induct)
     case (base b) thus ?case by auto
   next
     case (step b c) show ?case proof (rule step.hyps(3))
       assume A: "(a,b)\<in>r\<^sup>+"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A have "(a,c)\<in>r\<^sup>+" by auto
         with step.prems have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     next
       fix x
       assume A: "x \<in> X" "(a, x) \<in> r\<^sup>*" "(m, b) \<in> r\<^sup>*"
       note step.hyps(2)
       moreover {
         assume "(b,c)\<in>r"
         with A(3) have "(m,c)\<in>r\<^sup>*" by auto
         with step.prems(2)[OF A(1,2)] have P by blast
       } moreover {
         assume "b\<in>X" "c=m"
         with A have P by (rule_tac step.prems(2)) simp+
       } ultimately show P by auto
     qed
   qed
 
   text \<open>
     Version of @{thm [source] trancl_multi_insert} for inserted edges with the same startpoint.
 \<close>
   lemma trancl_multi_insert2[cases set, case_names orig via]:
     "\<lbrakk>(a,b)\<in>(r\<union>{m}\<times>X)\<^sup>+; (a,b)\<in>r\<^sup>+ \<Longrightarrow> P; !!x. \<lbrakk> x\<in>X; (a,m)\<in>r\<^sup>*; (x,b)\<in>r\<^sup>* \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   proof goal_cases
     case prems: 1 from prems(1) have "(b,a)\<in>((r\<union>{m}\<times>X)\<^sup>+)\<inverse>" by simp
     also have "((r\<union>{m}\<times>X)\<^sup>+)\<inverse> = (r\<inverse>\<union>X\<times>{m})\<^sup>+" by (simp add: converse_add_simps)
     finally have "(b, a) \<in> (r\<inverse> \<union> X \<times> {m})\<^sup>+" .
     thus ?case
       by (auto elim!: trancl_multi_insert
                intro: prems(2,3)
             simp add: trancl_converse rtrancl_converse
     )
   qed
 
 lemma cyclic_subset:
   "\<lbrakk> \<not> acyclic R; R \<subseteq> S \<rbrakk> \<Longrightarrow> \<not> acyclic S"
   unfolding acyclic_def
   by (blast intro: trancl_mono)
 
 
 
 
 
   subsubsection \<open>Wellfoundedness\<close>
   lemma wf_min: assumes A: "wf R" "R\<noteq>{}" "!!m. m\<in>Domain R - Range R \<Longrightarrow> P" shows P proof -
     have H: "!!x. wf R \<Longrightarrow> \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"
       by (erule_tac wf_induct_rule[where P="\<lambda>x. \<forall>y. (x,y)\<in>R \<longrightarrow> x\<in>Domain R - Range R \<or> (\<exists>m. m\<in>Domain R - Range R)"]) auto
     from A(2) obtain x y where "(x,y)\<in>R" by auto
     with A(1,3) H show ?thesis by blast
   qed
 
   lemma finite_wf_eq_wf_converse: "finite R \<Longrightarrow> wf (R\<inverse>) \<longleftrightarrow> wf R"
     by (metis acyclic_converse finite_acyclic_wf finite_acyclic_wf_converse wf_acyclic)
 
   lemma wf_max: assumes A: "wf (R\<inverse>)" "R\<noteq>{}" and C: "!!m. m\<in>Range R - Domain R \<Longrightarrow> P" shows "P"
   proof -
     from A(2) have NE: "R\<inverse>\<noteq>{}" by auto
     from wf_min[OF A(1) NE] obtain m where "m\<in>Range R - Domain R" by auto
     thus P by (blast intro: C)
   qed
 
     \<comment> \<open>Useful lemma to show well-foundedness of some process approaching a finite upper bound\<close>
   lemma wf_bounded_supset: "finite S \<Longrightarrow> wf {(Q',Q). Q'\<supset>Q \<and> Q'\<subseteq> S}"
   proof -
     assume [simp]: "finite S"
     hence [simp]: "!!x. finite (S-x)" by auto
     have "{(Q',Q). Q\<subset>Q' \<and> Q'\<subseteq> S} \<subseteq> inv_image ({(s'::nat,s). s'<s}) (\<lambda>Q. card (S-Q))"
     proof (intro subsetI, case_tac x, simp)
       fix a b
       assume A: "b\<subset>a \<and> a\<subseteq>S"
       hence "S-a \<subset> S-b" by blast
       thus "card (S-a) < card (S-b)" by (auto simp add: psubset_card_mono)
     qed
     moreover have "wf ({(s'::nat,s). s'<s})" by (rule wf_less)
     ultimately show ?thesis by (blast intro: wf_inv_image wf_subset)
   qed
 
   lemma wf_no_path: "Domain R \<inter> Range R = {} \<Longrightarrow> wf R"
     apply (rule wf_no_loop)
     by simp
 
 text \<open>Extend a wf-relation by a break-condition\<close>
 definition "brk_rel R \<equiv>
     {((False,x),(False,y)) | x y. (x,y)\<in>R}
   \<union> {((True,x),(False,y)) | x y. True}"
 
 lemma brk_rel_wf[simp,intro!]:
   assumes WF[simp]: "wf R"
   shows "wf (brk_rel R)"
 proof -
   have "wf {((False,x),(False,y)) | x y. (x,y)\<in>R}"
   proof -
     have "{((False,x),(False,y)) | x y. (x,y)\<in>R} \<subseteq> inv_image R snd"
       by auto
     from wf_subset[OF wf_inv_image[OF WF] this] show ?thesis .
   qed
   moreover have "wf {((True,x),(False,y)) | x y. True}"
     by (rule wf_no_path) auto
   ultimately show ?thesis
     unfolding brk_rel_def
     apply (subst Un_commute)
     by (blast intro: wf_Un)
 qed
 
 
 subsubsection \<open>Restrict Relation\<close>
 definition rel_restrict :: "('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set"
 where
   "rel_restrict R A \<equiv> {(v,w). (v,w) \<in> R \<and> v \<notin> A \<and> w \<notin> A}"
 
 lemma rel_restrict_alt_def:
   "rel_restrict R A = R \<inter> (-A) \<times> (-A)"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_empty[simp]:
   "rel_restrict R {} = R"
 by (simp add: rel_restrict_def)
 
 lemma rel_restrict_notR:
   assumes "(x,y) \<in> rel_restrict A R"
   shows "x \<notin> R" and "y \<notin> R"
 using assms
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_sub:
   "rel_restrict R A \<subseteq> R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_Int_empty:
   "A \<inter> Field R = {} \<Longrightarrow> rel_restrict R A = R"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma Domain_rel_restrict:
   "Domain (rel_restrict R A) \<subseteq> Domain R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Range_rel_restrict:
   "Range (rel_restrict R A) \<subseteq> Range R - A"
 unfolding rel_restrict_def
 by auto
 
 lemma Field_rel_restrict:
   "Field (rel_restrict R A) \<subseteq> Field R - A"
 unfolding rel_restrict_def Field_def
 by auto
 
 lemma rel_restrict_compl:
   "rel_restrict R A \<inter> rel_restrict R (-A) = {}"
 unfolding rel_restrict_def
 by auto
 
 lemma finite_rel_restrict:
   "finite R \<Longrightarrow> finite (rel_restrict R A)"
 by (metis finite_subset rel_restrict_sub)
 
 lemma R_subset_Field: "R \<subseteq> Field R \<times> Field R"
   unfolding Field_def
   by auto
 
 lemma homo_rel_restrict_mono:
   "R \<subseteq> B \<times> B \<Longrightarrow> rel_restrict R A \<subseteq> (B - A) \<times> (B - A)"
 proof -
   assume A: "R \<subseteq> B \<times> B"
   hence "Field R \<subseteq> B" unfolding Field_def by auto
   with Field_rel_restrict have "Field (rel_restrict R A) \<subseteq> B - A"
     by (metis Diff_mono order_refl order_trans)
   with R_subset_Field show ?thesis by blast
 qed
 
 lemma rel_restrict_union:
   "rel_restrict R (A \<union> B) = rel_restrict (rel_restrict R A) B"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrictI:
   "x \<notin> R \<Longrightarrow> y \<notin> R \<Longrightarrow> (x,y) \<in> E \<Longrightarrow> (x,y) \<in> rel_restrict E R"
 unfolding rel_restrict_def
 by auto
 
 lemma rel_restrict_lift:
   "(x,y) \<in> rel_restrict E R \<Longrightarrow> (x,y) \<in> E"
 unfolding rel_restrict_def
 by simp
 
 lemma rel_restrict_trancl_mem:
   "(a,b) \<in> (rel_restrict A R)\<^sup>+ \<Longrightarrow> (a,b) \<in> rel_restrict (A\<^sup>+) R"
 by (induction rule: trancl_induct) (auto simp add: rel_restrict_def)
 
 lemma rel_restrict_trancl_sub:
   "(rel_restrict A R)\<^sup>+ \<subseteq> rel_restrict (A\<^sup>+) R"
 by (metis subrelI rel_restrict_trancl_mem)
 
 lemma rel_restrict_mono:
   "A \<subseteq> B \<Longrightarrow> rel_restrict A R \<subseteq> rel_restrict B R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_mono2:
   "R \<subseteq> S \<Longrightarrow> rel_restrict A S \<subseteq> rel_restrict A R"
 unfolding rel_restrict_def by auto
 
 lemma rel_restrict_Sigma_sub:
   "rel_restrict ((A\<times>A)\<^sup>+) R \<subseteq> ((A - R) \<times> (A - R))\<^sup>+"
 unfolding rel_restrict_def
 by auto (metis DiffI converse_tranclE mem_Sigma_iff r_into_trancl tranclE)
 
 
 lemma finite_reachable_restrictedI:
   assumes F: "finite Q"
   assumes I: "I\<subseteq>Q"
   assumes R: "Range E \<subseteq> Q"
   shows "finite (E\<^sup>*``I)"
 proof -
   from I R have "E\<^sup>*``I \<subseteq> Q"
     by (force elim: rtrancl.cases)
   also note F
   finally (finite_subset) show ?thesis .
 qed
 
 context begin
   private lemma rtrancl_restrictI_aux:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>* \<and> v\<notin>R"
     using assms
     by (induction) (auto simp: rel_restrict_def intro: rtrancl.intros)
 
   corollary rtrancl_restrictI:
     assumes "(u,v)\<in>(E-UNIV\<times>R)\<^sup>*"
     assumes "u\<notin>R"
     shows "(u,v)\<in>(rel_restrict E R)\<^sup>*"
     using rtrancl_restrictI_aux[OF assms] ..
 end
 
 lemma E_closed_restr_reach_cases:
   assumes P: "(u,v)\<in>E\<^sup>*"
   assumes CL: "E``R \<subseteq> R"
   obtains "v\<in>R" | "u\<notin>R" "(u,v)\<in>(rel_restrict E R)\<^sup>*"
   using P
 proof (cases rule: rtrancl_last_visit[where S=R])
   case no_visit
   show ?thesis proof (cases "u\<in>R")
     case True with P have "v\<in>R"
       using rtrancl_reachable_induct[OF _ CL, where I="{u}"]
       by auto
     thus ?thesis ..
   next
     case False with no_visit have "(u,v)\<in>(rel_restrict E R)\<^sup>*"
       by (rule rtrancl_restrictI)
     with False show ?thesis ..
   qed
 next
   case (last_visit_point x)
   from \<open>(x, v) \<in> (E - UNIV \<times> R)\<^sup>*\<close> have "(x,v)\<in>E\<^sup>*"
     by (rule rtrancl_mono_mp[rotated]) auto
   with \<open>x\<in>R\<close> have "v\<in>R"
     using rtrancl_reachable_induct[OF _ CL, where I="{x}"]
     by auto
   thus ?thesis ..
 qed
 
 lemma rel_restrict_trancl_notR:
   assumes "(v,w) \<in> (rel_restrict E R)\<^sup>+"
   shows "v \<notin> R" and "w \<notin> R"
   using assms
   by (metis rel_restrict_trancl_mem rel_restrict_notR)+
 
 lemma rel_restrict_tranclI:
   assumes "(x,y) \<in> E\<^sup>+"
   and "x \<notin> R" "y \<notin> R"
   and "E `` R \<subseteq> R"
   shows "(x,y) \<in> (rel_restrict E R)\<^sup>+"
   using assms
   proof (induct)
     case base thus ?case by (metis r_into_trancl rel_restrictI)
   next
     case (step y z) hence "y \<notin> R" by auto
     with step show ?case by (metis trancl_into_trancl rel_restrictI)
   qed
 
 
 subsubsection \<open>Single-Valued Relations\<close>
 lemma single_valued_inter1: "single_valued R \<Longrightarrow> single_valued (R\<inter>S)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_inter2: "single_valued R \<Longrightarrow> single_valued (S\<inter>R)"
   by (auto intro: single_valuedI dest: single_valuedD)
 
 lemma single_valued_below_Id: "R\<subseteq>Id \<Longrightarrow> single_valued R"
   by (auto intro: single_valuedI)
   
 
 subsubsection \<open>Bijective Relations\<close>
 definition "bijective R \<equiv>
   (\<forall>x y z. (x,y)\<in>R \<and> (x,z)\<in>R \<longrightarrow> y=z) \<and>
   (\<forall>x y z. (x,z)\<in>R \<and> (y,z)\<in>R \<longrightarrow> x=y)"
 
 lemma bijective_alt: "bijective R \<longleftrightarrow> single_valued R \<and> single_valued (R\<inverse>)"
   unfolding bijective_def single_valued_def by blast
 
 lemma bijective_Id[simp, intro!]: "bijective Id"
   by (auto simp: bijective_def)
 
 lemma bijective_Empty[simp, intro!]: "bijective {}"
   by (auto simp: bijective_def)
 
 subsubsection \<open>Miscellaneous\<close>
 
   lemma pair_vimage_is_Image[simp]: "(Pair u -` E) = E``{u}"
     by auto
 
 lemma fst_in_Field: "fst ` R \<subseteq> Field R"
   by (simp add: Field_def fst_eq_Domain)
 
 lemma snd_in_Field: "snd ` R \<subseteq> Field R"
   by (simp add: Field_def snd_eq_Range)
 
 lemma ran_map_of:
   "ran (map_of xs) \<subseteq> snd ` set (xs)"
 by (induct xs) (auto simp add: ran_def)
 
 lemma Image_subset_snd_image:
   "A `` B \<subseteq> snd ` A"
 unfolding Image_def image_def
 by force
 
 lemma finite_Image_subset:
   "finite (A `` B) \<Longrightarrow> C \<subseteq> A \<Longrightarrow> finite (C `` B)"
 by (metis Image_mono order_refl rev_finite_subset)
 
 lemma finite_Field_eq_finite[simp]: "finite (Field R) \<longleftrightarrow> finite R"
   by (metis finite_cartesian_product finite_subset R_subset_Field finite_Field)
 
 
 
 definition "fun_of_rel R x \<equiv> SOME y. (x,y)\<in>R"
 
 lemma for_in_RI(*[intro]*): "x\<in>Domain R \<Longrightarrow> (x,fun_of_rel R x)\<in>R"
   unfolding fun_of_rel_def
   by (auto intro: someI)
 
 lemma Field_not_elem:
   "v \<notin> Field R \<Longrightarrow> \<forall>(x,y) \<in> R. x \<noteq> v \<and> y \<noteq> v"
 unfolding Field_def by auto
 
 lemma Sigma_UNIV_cancel[simp]: "(A \<times> X - A \<times> UNIV) = {}" by auto
 
 lemma same_fst_trancl[simp]: "(same_fst P R)\<^sup>+ = same_fst P (\<lambda>x. (R x)\<^sup>+)"
 proof -
   {
     fix x y
     assume "(x,y)\<in>(same_fst P R)\<^sup>+"
     hence "(x,y)\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
       by induction (auto simp: same_fst_def)
   } moreover {
     fix f f' x y
     assume "((f,x),(f',y))\<in>same_fst P (\<lambda>x. (R x)\<^sup>+)"
     hence [simp]: "f'=f" "P f" and 1: "(x,y)\<in>(R f)\<^sup>+" by (auto simp: same_fst_def)
     from 1 have "((f,x),(f',y))\<in>(same_fst P R)\<^sup>+"
       apply induction
       subgoal by (rule r_into_trancl) auto
       subgoal by (erule trancl_into_trancl) auto
       done
   } ultimately show ?thesis by auto
 qed  
     
 
 subsection \<open>\<open>option\<close> Datatype\<close>
 lemma le_some_optE: "\<lbrakk>Some m\<le>x; !!m'. \<lbrakk>x=Some m'; m\<le>m'\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
   by (cases x) auto
 
 
 lemma not_Some_eq2[simp]: "(\<forall>x y. v \<noteq> Some (x,y)) = (v = None)"
   by (cases v) auto
 
 
 subsection "Maps"
   primrec the_default where
     "the_default _ (Some x) = x"
   | "the_default x None = x"
 
   declare map_add_dom_app_simps[simp]  
   declare map_add_upd_left[simp]  
 
   lemma ran_add[simp]: "dom f \<inter> dom g = {} \<Longrightarrow> ran (f++g) = ran f \<union> ran g" by (fastforce simp add: ran_def map_add_def split: option.split_asm option.split)
 
   lemma nempty_dom: "\<lbrakk>e\<noteq>Map.empty; !!m. m\<in>dom e \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
     by (subgoal_tac "dom e \<noteq> {}") (blast, auto)
 
 
 
   lemma le_map_dom_mono: "m\<le>m' \<Longrightarrow> dom m \<subseteq> dom m'"
     apply (safe)
     apply (drule_tac x=x in le_funD)
     apply simp
     apply (erule le_some_optE)
     apply simp
     done
 
   lemma map_add_first_le: fixes m::"'a\<rightharpoonup>('b::order)" shows "\<lbrakk> m\<le>m' \<rbrakk> \<Longrightarrow> m++n \<le> m'++n"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split elim: le_funE)
     done
 
   lemma map_add_distinct_le: shows "\<lbrakk> m\<le>m'; n\<le>n'; dom m' \<inter> dom n' = {} \<rbrakk> \<Longrightarrow> m++n \<le> m'++n'"
     apply (rule le_funI)
     apply (auto simp add: map_add_def split: option.split)
     apply (fastforce elim: le_funE)
     apply (drule le_map_dom_mono)
     apply (drule le_map_dom_mono)
     apply (case_tac "m x")
     apply simp
     apply (force)
     apply (fastforce dest!: le_map_dom_mono)
     apply (erule le_funE)
     apply (erule_tac x=x in le_funE)
     apply simp
     done
 
   lemma map_add_left_comm: assumes A: "dom A \<inter> dom B = {}" shows "A ++ (B ++ C) = B ++ (A ++ C)"
   proof -
     have "A ++ (B ++ C) = (A++B)++C" by simp
     also have "\<dots> = (B++A)++C" by (simp add: map_add_comm[OF A])
     also have "\<dots> = B++(A++C)" by simp
     finally show ?thesis .
   qed
   lemmas map_add_ac = map_add_assoc map_add_comm map_add_left_comm
 
   lemma le_map_restrict[simp]: fixes m :: "'a \<rightharpoonup> ('b::order)" shows "m |` X \<le> m"
     by (rule le_funI) (simp add: restrict_map_def)
 
 lemma map_of_distinct_upd:
   "x \<notin> set (map fst xs) \<Longrightarrow> [x \<mapsto> y] ++ map_of xs = (map_of xs) (x \<mapsto> y)"
   by (induct xs) (auto simp add: fun_upd_twist)
 
 lemma map_of_distinct_upd2:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd3:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) = (map_of (xs @ (x,y') # ys))(x \<mapsto> y)"
   apply(insert assms)
   apply(induct xs)
   apply (auto intro: ext)
   done
 
 lemma map_of_distinct_upd4:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ ys) = (map_of (xs @ (x,y) # ys))(x := None)"
   using assms by (induct xs) (auto simp: map_of_eq_None_iff)
 
 lemma map_of_distinct_lookup:
   assumes "x \<notin> set(map fst xs)"
   "x \<notin> set (map fst ys)"
   shows "map_of (xs @ (x,y) # ys) x = Some y"
 proof -
   have "map_of (xs @ (x,y) # ys) = (map_of (xs @ ys)) (x \<mapsto> y)"
     using assms map_of_distinct_upd2 by simp
   thus ?thesis
     by simp
 qed
 
 lemma ran_distinct:
   assumes dist: "distinct (map fst al)"
   shows "ran (map_of al) = snd ` set al"
 using assms proof (induct al)
   case Nil then show ?case by simp
 next
   case (Cons kv al)
   then have "ran (map_of al) = snd ` set al" by simp
   moreover from Cons.prems have "map_of al (fst kv) = None"
     by (simp add: map_of_eq_None_iff)
   ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
 qed
 
 lemma ran_is_image:
   "ran M = (the \<circ> M) ` (dom M)"
 unfolding ran_def dom_def image_def
 by auto
 
 lemma map_card_eq_iff:
   assumes finite: "finite (dom M)"
   and card_eq: "card (dom M) = card (ran M)"
   and indom: "x \<in> dom M"
   shows "(M x = M y) \<longleftrightarrow> (x = y)"
 proof -
   from ran_is_image finite card_eq have *: "inj_on (the \<circ> M) (dom M)" using eq_card_imp_inj_on by metis
   thus ?thesis
   proof (cases "y \<in> dom M")
     case False with indom show ?thesis by auto
   next
     case True with indom have "the (M x) = the (M y) \<longleftrightarrow> (x = y)" using inj_on_eq_iff[OF *] by auto
     thus ?thesis by auto
   qed
 qed
 
 lemma map_dom_ran_finite:
   "finite (dom M) \<Longrightarrow> finite (ran M)"
 by (simp add: ran_is_image)
 
 lemma map_update_eta_repair[simp]:
   (* An update operation may get simplified, if it happens to be eta-expanded.
     This lemma tries to repair some common expressions *)
   "dom (\<lambda>x. if x=k then Some v else m x) = insert k (dom m)"
   "m k = None \<Longrightarrow> ran (\<lambda>x. if x=k then Some v else m x) = insert v (ran m)"
   apply auto []
   apply (force simp: ran_def)
   done
 
 lemma map_leI[intro?]: "\<lbrakk>\<And>x v. m1 x = Some v \<Longrightarrow> m2 x = Some v\<rbrakk> \<Longrightarrow> m1\<subseteq>\<^sub>mm2"
   unfolding map_le_def by force
 lemma map_leD: "m1\<subseteq>\<^sub>mm2 \<Longrightarrow> m1 k = Some v \<Longrightarrow> m2 k = Some v"
   unfolding map_le_def by force
     
 lemma map_restrict_insert_none_simp: "m x = None \<Longrightarrow> m|`(-insert x s) = m|`(-s)"
   by (auto intro!: ext simp:restrict_map_def)
 
 (* TODO: Move *)
 lemma eq_f_restr_conv: "s\<subseteq>dom (f A) \<and> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   apply auto
   subgoal by (metis map_leI restrict_map_eq(2))
   subgoal by (metis ComplD restrict_map_eq(2))
   subgoal by (metis Compl_iff restrict_in)
   subgoal by (force simp: map_le_def restrict_map_def)
   done
   
 corollary eq_f_restr_ss_eq: "\<lbrakk> s\<subseteq>dom (f A) \<rbrakk> \<Longrightarrow> A = f A |` (-s) \<longleftrightarrow> A \<subseteq>\<^sub>m f A \<and> s = dom (f A) - dom A"
   using eq_f_restr_conv by blast
     
     
     
   subsubsection \<open>Simultaneous Map Update\<close>
   definition "map_mmupd m K v k \<equiv> if k\<in>K then Some v else m k"
   lemma map_mmupd_empty[simp]: "map_mmupd m {} v = m"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_in_upd[simp]: "k\<in>K \<Longrightarrow> map_mmupd m K v k = Some v"
     by (auto simp: map_mmupd_def)
 
   lemma mmupd_notin_upd[simp]: "k\<notin>K \<Longrightarrow> map_mmupd m K v k = m k"
     by (auto simp: map_mmupd_def)
 
   lemma map_mmupdE:
     assumes "map_mmupd m K v k = Some x"
     obtains "k\<notin>K" "m k = Some x"
           | "k\<in>K" "x=v"
     using assms by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma dom_mmupd[simp]: "dom (map_mmupd m K v) = dom m \<union> K"  
     by (auto simp: map_mmupd_def split: if_split_asm)      
 
   lemma le_map_mmupd_not_dom[simp, intro!]: "m \<subseteq>\<^sub>m map_mmupd m (K-dom m) v" 
     by (auto simp: map_le_def)
 
   lemma map_mmupd_update_less: "K\<subseteq>K' \<Longrightarrow> map_mmupd m (K - dom m) v \<subseteq>\<^sub>m map_mmupd m (K'-dom m) v"
     by (auto simp: map_le_def map_mmupd_def)
 
     
 
 subsection\<open>Connection between Maps and Sets of Key-Value Pairs\<close>
 
 definition map_to_set where
   "map_to_set m = {(k, v) . m k = Some v}"
 
 definition set_to_map where
   "set_to_map S k = Eps_Opt (\<lambda>v. (k, v) \<in> S)"
 
 lemma set_to_map_simp :
 assumes inj_on_fst: "inj_on fst S"
 shows "(set_to_map S k = Some v) \<longleftrightarrow> (k, v) \<in> S"
 proof (cases "\<exists>v. (k, v) \<in> S")
   case True
   note kv_ex = this
   then obtain v' where kv'_in: "(k, v') \<in> S" by blast
 
   with inj_on_fst have kv''_in: "\<And>v''. (k, v'') \<in> S \<longleftrightarrow> v' = v''"
     unfolding inj_on_def Ball_def
     by auto
 
   show ?thesis
     unfolding set_to_map_def
     by (simp add: kv_ex kv''_in)
 next
   case False
   hence kv''_nin: "\<And>v''. (k, v'') \<notin> S" by simp
   thus ?thesis
     by (simp add: set_to_map_def)
 qed
 
 lemma inj_on_fst_map_to_set :
   "inj_on fst (map_to_set m)"
 unfolding map_to_set_def inj_on_def by simp
 
 lemma map_to_set_inverse :
    "set_to_map (map_to_set m) = m"
 proof
   fix k
   show "set_to_map (map_to_set m) k = m k"
   proof (cases "m k")
     case None note mk_eq = this
     hence "\<And>v. (k, v) \<notin> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k]
     show ?thesis unfolding mk_eq by auto
   next
     case (Some v) note mk_eq = this
     hence "(k, v) \<in> map_to_set m"
       unfolding map_to_set_def by simp
     with set_to_map_simp [OF inj_on_fst_map_to_set, of m k v]
     show ?thesis unfolding mk_eq by auto
   qed
 qed
 
 lemma set_to_map_inverse :
 assumes inj_on_fst_S: "inj_on fst S"
 shows "map_to_set (set_to_map S) = S"
 proof (rule set_eqI)
   fix kv
   from set_to_map_simp [OF inj_on_fst_S, of "fst kv" "snd kv"]
   show "(kv \<in> map_to_set (set_to_map S)) = (kv \<in> S)"
     unfolding map_to_set_def
     by auto
 qed
 
 lemma map_to_set_empty[simp]: "map_to_set Map.empty = {}"
   unfolding map_to_set_def by simp
 
 lemma set_to_map_empty[simp]: "set_to_map {} = Map.empty"
   unfolding set_to_map_def[abs_def] by simp
 
 lemma map_to_set_empty_iff: "map_to_set m = {} \<longleftrightarrow> m = Map.empty"
                             "{} = map_to_set m \<longleftrightarrow> m = Map.empty"
   unfolding map_to_set_def by auto
 
 lemma set_to_map_empty_iff: "set_to_map S = Map.empty \<longleftrightarrow> S = {}" (is ?T1)
                             "Map.empty = set_to_map S \<longleftrightarrow> S = {}" (is ?T2)
 proof -
   show T1: ?T1
     apply (simp only: set_eq_iff)
     apply (simp only: fun_eq_iff)
     apply (simp add: set_to_map_def)
     apply auto
   done
   from T1 show ?T2 by auto
 qed
 
 lemma map_to_set_upd[simp]: "map_to_set (m (k \<mapsto> v)) = insert (k, v) (map_to_set m - {(k, v') |v'. True})"
   unfolding map_to_set_def
   apply (simp add: set_eq_iff)
   apply metis
 done
 
 lemma set_to_map_insert:
 assumes k_nin: "fst kv \<notin> fst ` S"
 shows "set_to_map (insert kv S) = (set_to_map S) (fst kv \<mapsto> snd kv)"
 proof
   fix k'
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from k_nin have k_nin': "\<And>v'. (k, v') \<notin> S"
     by (auto simp add: image_iff Ball_def)
 
   show "set_to_map (insert kv S) k' = (set_to_map S(fst kv \<mapsto> snd kv)) k'"
     by (simp add: set_to_map_def k_nin')
 qed
 
 lemma map_to_set_dom :
   "dom m = fst ` (map_to_set m)"
 unfolding dom_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma map_to_set_ran :
   "ran m = snd ` (map_to_set m)"
 unfolding ran_def map_to_set_def
 by (auto simp add: image_iff)
 
 lemma set_to_map_dom :
   "dom (set_to_map S) = fst ` S"
 unfolding set_to_map_def[abs_def] dom_def
 by (auto simp add: image_iff Bex_def)
 
 lemma set_to_map_ran :
   "ran (set_to_map S) \<subseteq> snd ` S"
 unfolding set_to_map_def[abs_def] ran_def subset_iff
 by (auto simp add: image_iff Bex_def)
    (metis Eps_Opt_eq_Some)
 
 lemma finite_map_to_set:
 "finite (map_to_set m) = finite (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (intro iffI finite_imageI)
   apply assumption
   apply (rule finite_imageD[of fst])
   apply assumption
   apply (simp add: inj_on_def)
 done
 
 lemma card_map_to_set :
   "card (map_to_set m) = card (dom m)"
 unfolding map_to_set_def map_to_set_dom
   apply (rule card_image[symmetric])
   apply (simp add: inj_on_def)
 done
 
 lemma map_of_map_to_set :
 "distinct (map fst l) \<Longrightarrow>
  map_of l = m \<longleftrightarrow> set l = map_to_set m"
 proof (induct l arbitrary: m)
   case Nil thus ?case by (simp add: map_to_set_empty_iff) blast
 next
   case (Cons kv l m)
   obtain k v where kv_eq[simp]: "kv = (k, v)" by (rule prod.exhaust)
 
   from Cons(2) have dist_l: "distinct (map fst l)" and kv'_nin: "\<And>v'. (k, v') \<notin> set l"
     by (auto simp add: image_iff)
   note ind_hyp = Cons(1)[OF dist_l]
 
   from kv'_nin have l_eq: "set (kv # l) = map_to_set m \<longleftrightarrow> (set l = map_to_set (m (k := None))) \<and> m k = Some v"
     apply (simp add: map_to_set_def restrict_map_def set_eq_iff)
     apply (auto)
     apply (metis)
     apply (metis option.inject)
   done
 
   from kv'_nin have m_eq: "map_of (kv # l) = m \<longleftrightarrow> map_of l = (m (k := None)) \<and> m k = Some v"
     apply (simp add: fun_eq_iff restrict_map_def map_of_eq_None_iff image_iff Ball_def)
     apply metis
   done
 
   show ?case
     unfolding m_eq l_eq
     using ind_hyp[of "m (k := None)"]
     by metis
 qed
 
 lemma map_to_set_map_of :
 "distinct (map fst l) \<Longrightarrow> map_to_set (map_of l) = set l"
 by (metis map_of_map_to_set)
 
 subsubsection \<open>Mapping empty set to None\<close>
 definition "dflt_None_set S \<equiv> if S={} then None else Some S"
 
 lemma the_dflt_None_empty[simp]: "dflt_None_set {} = None"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_nonempty[simp]: "S\<noteq>{} \<Longrightarrow> dflt_None_set S = Some S"
   unfolding dflt_None_set_def by simp
 
 lemma the_dflt_None_set[simp]: "the_default {} (dflt_None_set x) = x"
   unfolding dflt_None_set_def by auto
 
 subsection \<open>Orderings\<close>
 
   
   
 lemma (in order) min_arg_le[simp]:
   "n \<le> min m n \<longleftrightarrow> min m n = n"
   "m \<le> min m n \<longleftrightarrow> min m n = m"
   by (auto simp: min_def)
 
 lemma (in linorder) min_arg_not_ge[simp]:
   "\<not> min m n < m \<longleftrightarrow> min m n = m"
   "\<not> min m n < n \<longleftrightarrow> min m n = n"
   by (auto simp: min_def)
 
 lemma (in linorder) min_eq_arg[simp]:
   "min m n = m \<longleftrightarrow> m\<le>n"
   "min m n = n \<longleftrightarrow> n\<le>m"
   by (auto simp: min_def)
 
 lemma min_simps[simp]:
   "a<(b::'a::order) \<Longrightarrow> min a b = a"
   "b<(a::'a::order) \<Longrightarrow> min a b = b"
   by (auto simp add: min_def dest: less_imp_le)
 
 lemma (in -) min_less_self_conv[simp]: 
   "min a b < a \<longleftrightarrow> b < (a::_::linorder)" 
   "min a b < b \<longleftrightarrow> a < (b::_::linorder)" 
   by (auto simp: min_def)
     
 lemma ord_eq_le_eq_trans: "\<lbrakk> a=b; b\<le>c; c=d \<rbrakk> \<Longrightarrow> a\<le>d" by auto
 
 lemma zero_comp_diff_simps[simp]: 
   "(0::'a::linordered_idom) \<le> a - b \<longleftrightarrow> b \<le> a" 
   "(0::'a::linordered_idom) < a - b \<longleftrightarrow> b < a" 
   by auto
     
 
 subsubsection \<open>Termination Measures\<close>    
 text \<open>Lexicographic measure, assuming upper bound for second component\<close>
 lemma mlex_fst_decrI:
   fixes a a' b b' N :: nat
   assumes "a<a'"
   assumes "b<N" "b'<N"
   shows "a*N + b < a'*N + b'"
 proof -  
   have "a*N + b + 1 \<le> a*N + N" using \<open>b<N\<close> by linarith 
   also have "\<dots> \<le> a'*N" using \<open>a<a'\<close>
     by (metis Suc_leI ab_semigroup_add_class.add.commute 
       ab_semigroup_mult_class.mult.commute mult_Suc_right mult_le_mono2) 
   also have "\<dots> \<le> a'*N + b'" by auto
   finally show ?thesis by auto
 qed      
   
 lemma mlex_leI:
   fixes a a' b b' N :: nat
   assumes "a\<le>a'"
   assumes "b\<le>b'"
   shows "a*N + b \<le> a'*N + b'"
   using assms
   by (auto intro!: add_mono)
     
 lemma mlex_snd_decrI:
   fixes a a' b b' N :: nat
   assumes "a=a'"
   assumes "b<b'"
   shows "a*N + b < a'*N + b'"
   using assms
   by (auto)
 
 lemma mlex_bound:  
   fixes a b :: nat
   assumes "a<A"
   assumes "b<N"
   shows "a*N + b < A*N"
   using assms
   using mlex_fst_decrI by fastforce
     
 subsection \<open>CCPOs\<close>
 
 context ccpo
 begin
 
 lemma ccpo_Sup_mono:
   assumes C: "Complete_Partial_Order.chain (\<le>) A"
     "Complete_Partial_Order.chain (\<le>) B"
   assumes B: "\<forall>x\<in>A. \<exists>y\<in>B. x\<le>y"
   shows "Sup A \<le> Sup B"
 proof (rule ccpo_Sup_least)
   fix x
   assume "x\<in>A"
   with B obtain y where I: "y\<in>B" and L: "x\<le>y" by blast
   note L
   also from I ccpo_Sup_upper have "y\<le>Sup B" by (blast intro: C)
   finally show "x\<le>Sup B" .
 qed (rule C)
 
 lemma fixp_mono:
   assumes M: "monotone (\<le>) (\<le>) f" "monotone (\<le>) (\<le>) g"
   assumes LE: "\<And>Z. f Z \<le> g Z"
   shows "ccpo_class.fixp f \<le> ccpo_class.fixp g"
   unfolding fixp_def[abs_def]
   apply (rule ccpo_Sup_mono)
   apply (rule chain_iterates M)+
 proof rule
   fix x
   assume "x\<in>ccpo_class.iterates f"
   thus "\<exists>y\<in>ccpo_class.iterates g. x\<le>y"
   proof (induct)
     case (step x)
     then obtain y where I: "y\<in>ccpo_class.iterates g" and L: "x\<le>y" by blast
     hence "g y \<in> ccpo_class.iterates g" and "f x \<le> g y"
       apply -
       apply (erule iterates.step)
       apply (rule order_trans)
       apply (erule monotoneD[OF M(1)])
       apply (rule LE)
       done
     thus "\<exists>y\<in>ccpo_class.iterates g. f x \<le> y" ..
   next
     case (Sup M)
     define N where "N = {SOME y. y\<in>ccpo_class.iterates g \<and> x\<le>y | x. x\<in>M}"
 
     have N1: "\<forall>y\<in>N. y\<in>ccpo_class.iterates g \<and> (\<exists>x\<in>M. x\<le>y)"
       unfolding N_def
       apply auto
       apply (metis (lifting) Sup.hyps(2) tfl_some)
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have N2: "\<forall>x\<in>M. \<exists>y\<in>N. x\<le>y"
       unfolding N_def
       apply auto
       by (metis (lifting) Sup.hyps(2) tfl_some)
 
     have "N \<subseteq> ccpo_class.iterates g" using Sup
       using N1 by auto
     hence C_chain: "Complete_Partial_Order.chain (\<le>) N"
       using chain_iterates[OF M(2)]
       unfolding chain_def by auto
 
     have "Sup N \<in> ccpo_class.iterates g" and "Sup M \<le> Sup N"
       apply -
       apply (rule iterates.Sup[OF C_chain])
       using N1 apply blast
       apply (rule ccpo_Sup_mono)
       apply (rule Sup.hyps)
       apply (rule C_chain)
       apply (rule N2)
       done
 
     thus ?case by blast
   qed
 qed
 
 end
 
   
 subsection \<open>Code\<close>  
 text \<open>Constant for code-abort. If that gets executed, an abort-exception is raised.\<close>  
 definition [simp]: "CODE_ABORT f = f ()"
 declare [[code abort: CODE_ABORT]]
   
   
 end
diff --git a/thys/Buchi_Complementation/Complementation_Implement.thy b/thys/Buchi_Complementation/Complementation_Implement.thy
--- a/thys/Buchi_Complementation/Complementation_Implement.thy
+++ b/thys/Buchi_Complementation/Complementation_Implement.thy
@@ -1,974 +1,975 @@
 section \<open>Complementation Implementation\<close>
 
 theory Complementation_Implement
 imports
-  "HOL-Library.Lattice_Syntax"
   "Transition_Systems_and_Automata.NBA_Implement"
   "Complementation"
 begin
 
+  unbundle lattice_syntax
+
   type_synonym item = "nat \<times> bool"
   type_synonym 'state items = "'state \<rightharpoonup> item"
 
   type_synonym state = "(nat \<times> item) list"
   abbreviation "item_rel \<equiv> nat_rel \<times>\<^sub>r bool_rel"
   abbreviation "state_rel \<equiv> \<langle>nat_rel, item_rel\<rangle> list_map_rel"
 
   abbreviation "pred A a q \<equiv> {p. q \<in> transition A a p}"
 
   subsection \<open>Phase 1\<close>
 
   definition cs_lr :: "'state items \<Rightarrow> 'state lr" where
     "cs_lr f \<equiv> map_option fst \<circ> f"
   definition cs_st :: "'state items \<Rightarrow> 'state st" where
     "cs_st f \<equiv> f -` Some ` snd -` {True}"
   abbreviation cs_abs :: "'state items \<Rightarrow> 'state cs" where
     "cs_abs f \<equiv> (cs_lr f, cs_st f)"
   definition cs_rep :: "'state cs \<Rightarrow> 'state items" where
     "cs_rep \<equiv> \<lambda> (g, P) p. map_option (\<lambda> k. (k, p \<in> P)) (g p)"
 
   lemma cs_abs_rep[simp]: "cs_rep (cs_abs f) = f"
   proof
     show "cs_rep (cs_abs f) x = f x" for x
       unfolding cs_lr_def cs_st_def cs_rep_def by (cases "f x") (force+)
   qed
   lemma cs_rep_lr[simp]: "cs_lr (cs_rep (g, P)) = g"
   proof
     show "cs_lr (cs_rep (g, P)) x = g x" for x
       unfolding cs_rep_def cs_lr_def by (cases "g x") (auto)
   qed
   lemma cs_rep_st[simp]: "cs_st (cs_rep (g, P)) = P \<inter> dom g"
     unfolding cs_rep_def cs_st_def by force
 
   lemma cs_lr_dom[simp]: "dom (cs_lr f) = dom f" unfolding cs_lr_def by simp
   lemma cs_lr_apply[simp]:
     assumes "p \<in> dom f"
     shows "the (cs_lr f p) = fst (the (f p))"
     using assms unfolding cs_lr_def by auto
 
   lemma cs_rep_dom[simp]: "dom (cs_rep (g, P)) = dom g" unfolding cs_rep_def by auto
   lemma cs_rep_apply[simp]:
     assumes "p \<in> dom f"
     shows "fst (the (cs_rep (f, P) p)) = the (f p)"
     using assms unfolding cs_rep_def by auto
 
   abbreviation cs_rel :: "('state items \<times> 'state cs) set" where
     "cs_rel \<equiv> br cs_abs top"
 
   lemma cs_rel_inv_single_valued: "single_valued (cs_rel\<inverse>)"
     by (auto intro!: inj_onI) (metis cs_abs_rep)
 
   definition refresh_1 :: "'state items \<Rightarrow> 'state items" where
     "refresh_1 f \<equiv> if True \<in> snd ` ran f then f else map_option (apsnd top) \<circ> f"
   definition ranks_1 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "ranks_1 A a f \<equiv> {g.
       dom g = \<Union>((transition A a) ` (dom f)) \<and>
       (\<forall> p \<in> dom f. \<forall> q \<in> transition A a p. fst (the (g q)) \<le> fst (the (f p))) \<and>
       (\<forall> q \<in> dom g. accepting A q \<longrightarrow> even (fst (the (g q)))) \<and>
       cs_st g = {q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))}}"
   definition complement_succ_1 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "complement_succ_1 A a = ranks_1 A a \<circ> refresh_1"
   definition complement_1 :: "('label, 'state) nba \<Rightarrow> ('label, 'state items) nba" where
     "complement_1 A \<equiv> nba
       (alphabet A)
       ({const (Some (2 * card (nodes A), False)) |` initial A})
       (complement_succ_1 A)
       (\<lambda> f. cs_st f = {})"
 
   lemma refresh_1_dom[simp]: "dom (refresh_1 f) = dom f" unfolding refresh_1_def by simp
   lemma refresh_1_apply[simp]: "fst (the (refresh_1 f p)) = fst (the (f p))"
     unfolding refresh_1_def by (cases "f p") (auto)
   lemma refresh_1_cs_st[simp]: "cs_st (refresh_1 f) = (if cs_st f = {} then dom f else cs_st f)"
     unfolding refresh_1_def cs_st_def ran_def image_def vimage_def by auto
 
   lemma complement_succ_1_abs:
     assumes "g \<in> complement_succ_1 A a f"
     shows "cs_abs g \<in> complement_succ A a (cs_abs f)"
   unfolding complement_succ_def
   proof (simp, rule)
     have 1:
       "dom g = \<Union>((transition A a) ` (dom f))"
       "\<forall> p \<in> dom f. \<forall> q \<in> transition A a p. fst (the (g q)) \<le> fst (the (f p))"
       "\<forall> p \<in> dom g. accepting A p \<longrightarrow> even (fst (the (g p)))"
       using assms unfolding complement_succ_1_def ranks_1_def by simp_all
     show "cs_lr g \<in> lr_succ A a (cs_lr f)"
     unfolding lr_succ_def
     proof (intro CollectI conjI ballI impI)
       show "dom (cs_lr g) = \<Union> (transition A a ` dom (cs_lr f))" using 1 by simp
     next
       fix p q
       assume 2: "p \<in> dom (cs_lr f)" "q \<in> transition A a p"
       have 3: "q \<in> dom (cs_lr g)" using 1 2 by auto
       show "the (cs_lr g q) \<le> the (cs_lr f p)" using 1 2 3 by simp
     next
       fix p
       assume 2: "p \<in> dom (cs_lr g)" "accepting A p"
       show "even (the (cs_lr g p))" using 1 2 by auto
     qed
     have 2: "cs_st g = {q \<in> \<Union> (transition A a ` cs_st (refresh_1 f)). even (fst (the (g q)))}"
       using assms unfolding complement_succ_1_def ranks_1_def by simp
     show "cs_st g = st_succ A a (cs_lr g) (cs_st f)"
     proof (cases "cs_st f = {}")
       case True
       have 3: "the (cs_lr g q) = fst (the (g q))" if "q \<in> \<Union>((transition A a) ` (dom f))" for q
         using that 1(1) by simp
       show ?thesis using 2 3 unfolding st_succ_def refresh_1_cs_st True cs_lr_dom 1(1) by force
     next
       case False
       have 3: "the (cs_lr g q) = fst (the (g q))" if "q \<in> \<Union>((transition A a) ` (cs_st f))" for q
         using that 1(1) by 
           (auto intro!: cs_lr_apply)
           (metis IntE UN_iff cs_abs_rep cs_lr_dom cs_rep_st domD prod.collapse)
       have "cs_st g = {q \<in> \<Union> (transition A a ` cs_st (refresh_1 f)). even (fst (the (g q)))}"
         using 2 by this
       also have "cs_st (refresh_1 f) = cs_st f" using False by simp
       also have "{q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))} =
         {q \<in> \<Union>((transition A a) ` (cs_st f)). even (the (cs_lr g q))}" using 3 by metis
       also have "\<dots> = st_succ A a (cs_lr g) (cs_st f)" unfolding st_succ_def using False by simp
       finally show ?thesis by this
     qed
   qed
   lemma complement_succ_1_rep:
     assumes "P \<subseteq> dom f" "(g, Q) \<in> complement_succ A a (f, P)"
     shows "cs_rep (g, Q) \<in> complement_succ_1 A a (cs_rep (f, P))"
   unfolding complement_succ_1_def ranks_1_def comp_apply
   proof (intro CollectI conjI ballI impI)
     have 1:
       "dom g = \<Union>((transition A a) ` (dom f))"
       "\<forall> p \<in> dom f. \<forall> q \<in> transition A a p. the (g q) \<le> the (f p)"
       "\<forall> p \<in> dom g. accepting A p \<longrightarrow> even (the (g p))"
       using assms(2) unfolding complement_succ_def lr_succ_def by simp_all
     have 2: "Q = {q \<in> if P = {} then dom g else \<Union>((transition A a) ` P). even (the (g q))}"
       using assms(2) unfolding complement_succ_def st_succ_def by simp
     have 3: "Q \<subseteq> dom g" unfolding 2 1(1) using assms(1) by auto
     show "dom (cs_rep (g, Q)) = \<Union> (transition A a ` dom (refresh_1 (cs_rep (f, P))))" using 1 by simp
     show "\<And> p q. p \<in> dom (refresh_1 (cs_rep (f, P))) \<Longrightarrow> q \<in> transition A a p \<Longrightarrow>
       fst (the (cs_rep (g, Q) q)) \<le> fst (the (refresh_1 (cs_rep (f, P)) p))"
       using 1(1, 2) by (auto) (metis UN_I cs_rep_apply domI option.sel)
     show "\<And> p. p \<in> dom (cs_rep (g, Q)) \<Longrightarrow> accepting A p \<Longrightarrow> even (fst (the (cs_rep (g, Q) p)))"
       using 1(1, 3) by auto
     show "cs_st (cs_rep (g, Q)) = {q \<in> \<Union> (transition A a ` cs_st (refresh_1 (cs_rep (f, P)))).
       even (fst (the (cs_rep (g, Q) q)))}"
     proof (cases "P = {}")
       case True
       have "cs_st (cs_rep (g, Q)) = Q" using 3 by auto
       also have "\<dots> = {q \<in> dom g. even (the (g q))}" unfolding 2 using True by auto
       also have "\<dots> = {q \<in> dom g. even (fst (the (cs_rep (g, Q) q)))}" using cs_rep_apply by metis
       also have "dom g = \<Union>((transition A a) ` (dom f))" using 1(1) by this
       also have "dom f = cs_st (refresh_1 (cs_rep (f, P)))" using True by simp
       finally show ?thesis by this
     next
       case False
       have 4: "fst (the (cs_rep (g, Q) q)) = the (g q)" if "q \<in> \<Union>((transition A a) ` P)" for q
         using 1(1) that assms(1) by (fast intro: cs_rep_apply)
       have "cs_st (cs_rep (g, Q)) = Q" using 3 by auto
       also have "\<dots> = {q \<in> \<Union>((transition A a) ` P). even (the (g q))}" unfolding 2 using False by auto
       also have "\<dots> = {q \<in> \<Union>((transition A a) ` P). even (fst (the (cs_rep (g, Q) q)))}" using 4 by force
       also have "P = (cs_st (refresh_1 (cs_rep (f, P))))" using assms(1) False by auto
       finally show ?thesis by simp
     qed
   qed
 
   lemma complement_succ_1_refine: "(complement_succ_1, complement_succ) \<in>
     Id \<rightarrow> Id \<rightarrow> cs_rel \<rightarrow> \<langle>cs_rel\<rangle> set_rel"
   proof (clarsimp simp: br_set_rel_alt in_br_conv)
     fix A :: "('a, 'b) nba"
     fix a f
     show "complement_succ A a (cs_abs f) = cs_abs ` complement_succ_1 A a f"
     proof safe
       fix g Q
       assume 1: "(g, Q) \<in> complement_succ A a (cs_abs f)"
       have 2: "Q \<subseteq> dom g"
         using 1 unfolding complement_succ_def lr_succ_def st_succ_def
         by (auto) (metis IntE cs_abs_rep cs_lr_dom cs_rep_st)
       have 3: "cs_st f \<subseteq> dom (cs_lr f)" unfolding cs_st_def by auto
       show "(g, Q) \<in> cs_abs ` complement_succ_1 A a f"
       proof
         show "(g, Q) = cs_abs (cs_rep (g, Q))" using 2 by auto
         have "cs_rep (g, Q) \<in> complement_succ_1 A a (cs_rep (cs_abs f))"
           using complement_succ_1_rep 3 1 by this
         also have "cs_rep (cs_abs f) = f" by simp
         finally show "cs_rep (g, Q) \<in> complement_succ_1 A a f" by this
       qed
     next
       fix g
       assume 1: "g \<in> complement_succ_1 A a f"
       show "cs_abs g \<in> complement_succ A a (cs_abs f)" using complement_succ_1_abs 1 by this
     qed
   qed
   lemma complement_1_refine: "(complement_1, complement) \<in> \<langle>Id, Id\<rangle> nba_rel \<rightarrow> \<langle>Id, cs_rel\<rangle> nba_rel"
   unfolding complement_1_def complement_def
   proof parametricity
     fix A B :: "('a, 'b) nba"
     assume 1: "(A, B) \<in> \<langle>Id, Id\<rangle> nba_rel"
     have 2: "(const (Some (2 * card (nodes B), False)) |` initial B,
       const (Some (2 * card (nodes B))) |` initial B, {}) \<in> cs_rel"
       unfolding cs_lr_def cs_st_def in_br_conv by (force simp: restrict_map_def)
     show "(complement_succ_1 A, complement_succ B) \<in> Id \<rightarrow> cs_rel \<rightarrow> \<langle>cs_rel\<rangle> set_rel"
       using complement_succ_1_refine 1 by parametricity auto
     show "({const (Some (2 * card (nodes A), False)) |` initial A},
       {const (Some (2 * card (nodes B))) |` initial B} \<times> {{}}) \<in> \<langle>cs_rel\<rangle> set_rel"
       using 1 2 by simp parametricity
     show "(\<lambda> f. cs_st f = {}, \<lambda> (f, P). P = {}) \<in> cs_rel \<rightarrow> bool_rel" by (auto simp: in_br_conv)
   qed
 
   subsection \<open>Phase 2\<close>
 
   definition ranks_2 :: "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "ranks_2 A a f \<equiv> {g.
       dom g = \<Union>((transition A a) ` (dom f)) \<and>
       (\<forall> q l d. g q = Some (l, d) \<longrightarrow>
         l \<le> \<Sqinter> (fst ` Some -` f ` pred A a q) \<and>
         (d \<longleftrightarrow> \<Squnion> (snd ` Some -` f ` pred A a q) \<and> even l) \<and>
         (accepting A q \<longrightarrow> even l))}"
   definition complement_succ_2 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "complement_succ_2 A a \<equiv> ranks_2 A a \<circ> refresh_1"
   definition complement_2 :: "('label, 'state) nba \<Rightarrow> ('label, 'state items) nba" where
     "complement_2 A \<equiv> nba
       (alphabet A)
       ({const (Some (2 * card (nodes A), False)) |` initial A})
       (complement_succ_2 A)
       (\<lambda> f. True \<notin> snd ` ran f)"
 
   lemma ranks_2_refine: "ranks_2 = ranks_1"
   proof (intro ext)
     fix A :: "('a, 'b) nba" and a f
     show "ranks_2 A a f = ranks_1 A a f"
     proof safe
       fix g
       assume 1: "g \<in> ranks_2 A a f"
       have 2: "dom g = \<Union>((transition A a) ` (dom f))" using 1 unfolding ranks_2_def by auto
       have 3: "g q = Some (l, d) \<Longrightarrow> l \<le> \<Sqinter> (fst ` Some -` f ` pred A a q)" for q l d
         using 1 unfolding ranks_2_def by auto
       have 4: "g q = Some (l, d) \<Longrightarrow> d \<longleftrightarrow> \<Squnion> (snd ` Some -` f ` pred A a q) \<and> even l" for q l d
         using 1 unfolding ranks_2_def by auto
       have 5: "g q = Some (l, d) \<Longrightarrow> accepting A q \<Longrightarrow> even l" for q l d
         using 1 unfolding ranks_2_def by auto
       show "g \<in> ranks_1 A a f"
       unfolding ranks_1_def
       proof (intro CollectI conjI ballI impI)
         show "dom g = \<Union>((transition A a) ` (dom f))" using 2 by this
       next
         fix p q
         assume 10: "p \<in> dom f" "q \<in> transition A a p"
         obtain k c where 11: "f p = Some (k, c)" using 10(1) by auto
         have 12: "q \<in> dom g" using 10 2 by auto
         obtain l d where 13: "g q = Some (l, d)" using 12 by auto
         have "fst (the (g q)) = l" unfolding 13 by simp
         also have "\<dots> \<le> \<Sqinter> (fst ` Some -` f ` pred A a q)" using 3 13 by this
         also have "\<dots> \<le> k"
         proof (rule cInf_lower)
           show "k \<in> fst ` Some -` f ` pred A a q" using 11 10(2) by force
           show "bdd_below (fst ` Some -` f ` pred A a q)" by simp
         qed
         also have "\<dots> = fst (the (f p))" unfolding 11 by simp
         finally show "fst (the (g q)) \<le> fst (the (f p))" by this
       next
         fix q
         assume 10: "q \<in> dom g" "accepting A q"
         show "even (fst (the (g q)))" using 10 5 by auto
       next
         show "cs_st g = {q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))}"
         proof
           show "cs_st g \<subseteq> {q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))}"
             using 4 unfolding cs_st_def image_def vimage_def by auto metis+
           show "{q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))} \<subseteq> cs_st g"
           proof safe
             fix p q
             assume 10: "even (fst (the (g q)))" "p \<in> cs_st f" "q \<in> transition A a p"
             have 12: "q \<in> dom g" using 10 2 unfolding cs_st_def by auto
             show "q \<in> cs_st g" using 10 4 12 unfolding cs_st_def image_def by force
           qed
         qed
       qed
     next
       fix g
       assume 1: "g \<in> ranks_1 A a f"
       have 2: "dom g = \<Union>((transition A a) ` (dom f))" using 1 unfolding ranks_1_def by auto
       have 3: "\<And> p q. p \<in> dom f \<Longrightarrow> q \<in> transition A a p \<Longrightarrow> fst (the (g q)) \<le> fst (the (f p))"
         using 1 unfolding ranks_1_def by auto
       have 4: "\<And> q. q \<in> dom g \<Longrightarrow> accepting A q \<Longrightarrow> even (fst (the (g q)))"
         using 1 unfolding ranks_1_def by auto
       have 5: "cs_st g = {q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))}"
         using 1 unfolding ranks_1_def by auto
       show "g \<in> ranks_2 A a f"
         unfolding ranks_2_def
       proof (intro CollectI conjI allI impI)
         show "dom g = \<Union>((transition A a) ` (dom f))" using 2 by this
       next
         fix q l d
         assume 10: "g q = Some (l, d)"
         have 11: "q \<in> dom g" using 10 by auto
         show "l \<le> \<Sqinter> (fst ` Some -` f ` pred A a q)"
         proof (rule cInf_greatest)
           show "fst ` Some -` f ` pred A a q \<noteq> {}" using 11 unfolding 2 image_def vimage_def by force
           show "\<And> x. x \<in> fst ` Some -` f ` pred A a q \<Longrightarrow> l \<le> x"
             using 3 10 by (auto) (metis domI fst_conv option.sel)
         qed
         have "d \<longleftrightarrow> q \<in> cs_st g" unfolding cs_st_def by (force simp: 10)
         also have "cs_st g = {q \<in> \<Union>((transition A a) ` (cs_st f)). even (fst (the (g q)))}" using 5 by this
         also have "q \<in> \<dots> \<longleftrightarrow> (\<exists> x \<in> cs_st f. q \<in> transition A a x) \<and> even l"
           unfolding mem_Collect_eq 10 by simp
         also have "\<dots> \<longleftrightarrow> \<Squnion> (snd ` Some -` f ` pred A a q) \<and> even l"
           unfolding cs_st_def image_def vimage_def by auto metis+
         finally show "d \<longleftrightarrow> \<Squnion> (snd ` Some -` f ` pred A a q) \<and> even l" by this
         show "accepting A q \<Longrightarrow> even l" using 4 10 11 by force
       qed
     qed
   qed
 
   lemma complement_2_refine: "(complement_2, complement_1) \<in> \<langle>Id, Id\<rangle> nba_rel \<rightarrow> \<langle>Id, Id\<rangle> nba_rel"
     unfolding complement_2_def complement_1_def complement_succ_2_def complement_succ_1_def
     unfolding ranks_2_refine cs_st_def image_def vimage_def ran_def by auto
 
   subsection \<open>Phase 3\<close>
 
   definition bounds_3 :: "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items" where
     "bounds_3 A a f \<equiv> \<lambda> q. let S = Some -` f ` pred A a q in
       if S = {} then None else Some (\<Sqinter>(fst ` S), \<Squnion>(snd ` S))"
   definition items_3 :: "('label, 'state) nba \<Rightarrow> 'state \<Rightarrow> item \<Rightarrow> item set" where
     "items_3 A p \<equiv> \<lambda> (k, c). {(l, c \<and> even l) |l. l \<le> k \<and> (accepting A p \<longrightarrow> even l)}"
   definition get_3 :: "('label, 'state) nba \<Rightarrow> 'state items \<Rightarrow> ('state \<rightharpoonup> item set)" where
     "get_3 A f \<equiv> \<lambda> p. map_option (items_3 A p) (f p)"
   definition complement_succ_3 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "complement_succ_3 A a \<equiv> expand_map \<circ> get_3 A \<circ> bounds_3 A a \<circ> refresh_1"
   definition complement_3 :: "('label, 'state) nba \<Rightarrow> ('label, 'state items) nba" where
     "complement_3 A \<equiv> nba
       (alphabet A)
       ({(Some \<circ> (const (2 * card (nodes A), False))) |` initial A})
       (complement_succ_3 A)
       (\<lambda> f. \<forall> (p, k, c) \<in> map_to_set f. \<not> c)"
 
   lemma bounds_3_dom[simp]: "dom (bounds_3 A a f) = \<Union>((transition A a) ` (dom f))"
     unfolding bounds_3_def Let_def dom_def by (force split: if_splits)
 
   lemma items_3_nonempty[intro!, simp]: "items_3 A p s \<noteq> {}" unfolding items_3_def by auto
   lemma items_3_finite[intro!, simp]: "finite (items_3 A p s)"
     unfolding items_3_def by (auto split: prod.splits)
 
   lemma get_3_dom[simp]: "dom (get_3 A f) = dom f" unfolding get_3_def by (auto split: bind_splits)
   lemma get_3_finite[intro, simp]: "S \<in> ran (get_3 A f) \<Longrightarrow> finite S"
     unfolding get_3_def ran_def by auto
   lemma get_3_update[simp]: "get_3 A (f (p \<mapsto> s)) = (get_3 A f) (p \<mapsto> items_3 A p s)"
     unfolding get_3_def by auto
 
   lemma expand_map_get_bounds_3: "expand_map \<circ> get_3 A \<circ> bounds_3 A a = ranks_2 A a"
   proof (intro ext set_eqI, unfold comp_apply)
     fix f g
     have 1: "(\<forall> x S y. get_3 A (bounds_3 A a f) x = Some S \<longrightarrow> g x = Some y \<longrightarrow> y \<in> S) \<longleftrightarrow>
       (\<forall> q S l d. get_3 A (bounds_3 A a f) q = Some S \<longrightarrow> g q = Some (l, d) \<longrightarrow> (l, d) \<in> S)"
       by auto
     have 2: "(\<forall> S. get_3 A (bounds_3 A a f) q = Some S \<longrightarrow> g q = Some (l, d) \<longrightarrow> (l, d) \<in> S) \<longleftrightarrow>
       (g q = Some (l, d) \<longrightarrow> l \<le> \<Sqinter>(fst ` (Some -` f ` pred A a q)) \<and>
       (d \<longleftrightarrow> \<Squnion>(snd ` (Some -` f ` pred A a q)) \<and> even l) \<and> (accepting A q \<longrightarrow> even l))"
       if 3: "dom g = \<Union>((transition A a) ` (dom f))" for q l d
     proof -
       have 4: "q \<notin> dom g" if "Some -` f ` pred A a q = {}" unfolding 3 using that by force
       show ?thesis unfolding get_3_def items_3_def bounds_3_def Let_def using 4 by auto
     qed
     show "g \<in> expand_map (get_3 A (bounds_3 A a f)) \<longleftrightarrow> g \<in> ranks_2 A a f"
       unfolding expand_map_alt_def ranks_2_def mem_Collect_eq
       unfolding get_3_dom bounds_3_dom 1 using 2 by blast
   qed
 
   lemma complement_succ_3_refine: "complement_succ_3 = complement_succ_2"
     unfolding complement_succ_3_def complement_succ_2_def expand_map_get_bounds_3 by rule
   lemma complement_initial_3_refine: "{const (Some (2 * card (nodes A), False)) |` initial A} =
     {(Some \<circ> (const (2 * card (nodes A), False))) |` initial A}"
     unfolding comp_apply by rule
   lemma complement_accepting_3_refine: "True \<notin> snd ` ran f \<longleftrightarrow> (\<forall> (p, k, c) \<in> map_to_set f. \<not> c)"
     unfolding map_to_set_def ran_def by auto
 
   lemma complement_3_refine: "(complement_3, complement_2) \<in> \<langle>Id, Id\<rangle> nba_rel \<rightarrow> \<langle>Id, Id\<rangle> nba_rel"
     unfolding complement_3_def complement_2_def
     unfolding complement_succ_3_refine complement_initial_3_refine complement_accepting_3_refine
     by auto
 
   subsection \<open>Phase 4\<close>
 
   definition items_4 :: "('label, 'state) nba \<Rightarrow> 'state \<Rightarrow> item \<Rightarrow> item set" where
     "items_4 A p \<equiv> \<lambda> (k, c). {(l, c \<and> even l) |l. k \<le> Suc l \<and> l \<le> k \<and> (accepting A p \<longrightarrow> even l)}"
   definition get_4 :: "('label, 'state) nba \<Rightarrow> 'state items \<Rightarrow> ('state \<rightharpoonup> item set)" where
     "get_4 A f \<equiv> \<lambda> p. map_option (items_4 A p) (f p)"
   definition complement_succ_4 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set" where
     "complement_succ_4 A a \<equiv> expand_map \<circ> get_4 A \<circ> bounds_3 A a \<circ> refresh_1"
   definition complement_4 :: "('label, 'state) nba \<Rightarrow> ('label, 'state items) nba" where
     "complement_4 A \<equiv> nba
       (alphabet A)
       ({(Some \<circ> (const (2 * card (nodes A), False))) |` initial A})
       (complement_succ_4 A)
       (\<lambda> f. \<forall> (p, k, c) \<in> map_to_set f. \<not> c)"
 
   lemma get_4_dom[simp]: "dom (get_4 A f) = dom f" unfolding get_4_def by (auto split: bind_splits)
 
   definition R :: "'state items rel" where
     "R \<equiv> {(f, g).
       dom f = dom g \<and>
       (\<forall> p \<in> dom f. fst (the (f p)) \<le> fst (the (g p))) \<and>
       (\<forall> p \<in> dom f. snd (the (f p)) \<longleftrightarrow> snd (the (g p)))}"
 
   lemma bounds_R:
     assumes "(f, g) \<in> R"
     assumes "bounds_3 A a (refresh_1 f) p = Some (n, e)"
     assumes "bounds_3 A a (refresh_1 g) p = Some (k, c)"
     shows "n \<le> k" "e \<longleftrightarrow> c"
   proof -
     have 1:
       "dom f = dom g"
       "\<forall> p \<in> dom f. fst (the (f p)) \<le> fst (the (g p))"
       "\<forall> p \<in> dom f. snd (the (f p)) \<longleftrightarrow> snd (the (g p))"
       using assms(1) unfolding R_def by auto
     have "n = \<Sqinter>(fst ` (Some -` refresh_1 f ` pred A a p))"
       using assms(2) unfolding bounds_3_def by (auto simp: Let_def split: if_splits)
     also have "fst ` Some -` refresh_1 f ` pred A a p = fst ` Some -` f ` pred A a p"
     proof
       show " fst ` Some -` refresh_1 f ` pred A a p \<subseteq> fst ` Some -` f ` pred A a p"
         unfolding refresh_1_def image_def
         by (auto simp: map_option_case split: option.split) (force)
       show "fst ` Some -` f ` pred A a p \<subseteq> fst ` Some -` refresh_1 f ` pred A a p"
         unfolding refresh_1_def image_def
         by (auto simp: map_option_case split: option.split) (metis fst_conv option.sel)
     qed
     also have "\<dots> = fst ` Some -` f ` (pred A a p \<inter> dom f)"
       unfolding dom_def image_def Int_def by auto metis
     also have "\<dots> = fst ` the ` f ` (pred A a p \<inter> dom f)"
       unfolding dom_def by force
     also have "\<dots> = (fst \<circ> the \<circ> f) ` (pred A a p \<inter> dom f)" by force
     also have "\<Sqinter>((fst \<circ> the \<circ> f) ` (pred A a p \<inter> dom f)) \<le>
       \<Sqinter>((fst \<circ> the \<circ> g) ` (pred A a p \<inter> dom g))"
     proof (rule cINF_mono)
       show "pred A a p \<inter> dom g \<noteq> {}"
         using assms(2) 1(1) unfolding bounds_3_def refresh_1_def
         by (auto simp: Let_def split: if_splits) (force+)
       show "bdd_below ((fst \<circ> the \<circ> f) ` (pred A a p \<inter> dom f))" by rule
       show "\<exists> n \<in> pred A a p \<inter> dom f. (fst \<circ> the \<circ> f) n \<le> (fst \<circ> the \<circ> g) m"
         if "m \<in> pred A a p \<inter> dom g" for m using 1 that by auto
     qed
     also have "(fst \<circ> the \<circ> g) ` (pred A a p \<inter> dom g) = fst ` the ` g ` (pred A a p \<inter> dom g)" by force
     also have "\<dots> = fst ` Some -` g ` (pred A a p \<inter> dom g)"
       unfolding dom_def by force
     also have "\<dots> = fst ` Some -` g ` pred A a p"
       unfolding dom_def image_def Int_def by auto metis
     also have "\<dots> = fst ` Some -` refresh_1 g ` pred A a p"
     proof
       show "fst ` Some -` g ` pred A a p \<subseteq> fst ` Some -` refresh_1 g ` pred A a p"
         unfolding refresh_1_def image_def
         by (auto simp: map_option_case split: option.split) (metis fst_conv option.sel)
       show "fst ` Some -` refresh_1 g ` pred A a p \<subseteq> fst ` Some -` g ` pred A a p"
         unfolding refresh_1_def image_def
         by (auto simp: map_option_case split: option.split) (force)
     qed
     also have "\<Sqinter>(fst ` (Some -` refresh_1 g ` pred A a p)) = k"
       using assms(3) unfolding bounds_3_def by (auto simp: Let_def split: if_splits)
     finally show "n \<le> k" by this
     have "e \<longleftrightarrow> \<Squnion>(snd ` (Some -` refresh_1 f ` pred A a p))"
       using assms(2) unfolding bounds_3_def by (auto simp: Let_def split: if_splits)
     also have "snd ` Some -` refresh_1 f ` pred A a p = snd ` Some -` refresh_1 f ` (pred A a p \<inter> dom (refresh_1 f))"
       unfolding dom_def image_def Int_def by auto metis
     also have "\<dots> = snd ` the ` refresh_1 f ` (pred A a p \<inter> dom (refresh_1 f))"
       unfolding dom_def by force
     also have "\<dots> = (snd \<circ> the \<circ> refresh_1 f) ` (pred A a p \<inter> dom (refresh_1 f))" by force
     also have "\<dots> = (snd \<circ> the \<circ> refresh_1 g) ` (pred A a p \<inter> dom (refresh_1 g))"
     proof (rule image_cong)
       show "pred A a p \<inter> dom (refresh_1 f) = pred A a p \<inter> dom (refresh_1 g)"
         unfolding refresh_1_dom 1(1) by rule
       show "(snd \<circ> the \<circ> refresh_1 f) q \<longleftrightarrow> (snd \<circ> the \<circ> refresh_1 g) q"
         if 2: "q \<in> pred A a p \<inter> dom (refresh_1 g)" for q
       proof
         have 3: "\<forall> x \<in> ran f. \<not> snd x \<Longrightarrow> (n, True) \<in> ran g \<Longrightarrow> g q = Some (k, c) \<Longrightarrow> c" for n k c
           using 1(1, 3) unfolding dom_def ran_def
           by (auto dest!: Collect_inj) (metis option.sel snd_conv)
         have 4: "g q = Some (n, True) \<Longrightarrow> f q = Some (k, c) \<Longrightarrow> c" for n k c
           using 1(3) unfolding dom_def by force
         have 5: "\<forall> x \<in> ran g. \<not> snd x \<Longrightarrow> (k, True) \<in> ran f \<Longrightarrow> False" for k
           using 1(1, 3) unfolding dom_def ran_def
           by (auto dest!: Collect_inj) (metis option.sel snd_conv)
         show "(snd \<circ> the \<circ> refresh_1 f) q \<Longrightarrow> (snd \<circ> the \<circ> refresh_1 g) q"
           using 1(1, 3) 2 3 unfolding refresh_1_def by (force split: if_splits)
         show "(snd \<circ> the \<circ> refresh_1 g) q \<Longrightarrow> (snd \<circ> the \<circ> refresh_1 f) q"
           using 1(1, 3) 2 4 5 unfolding refresh_1_def
           by (auto simp: map_option_case split: option.splits if_splits) (force+)
       qed
     qed
     also have "\<dots> = snd ` the ` refresh_1 g ` (pred A a p \<inter> dom (refresh_1 g))" by force
     also have "\<dots> = snd ` Some -` refresh_1 g ` (pred A a p \<inter> dom (refresh_1 g))"
       unfolding dom_def by force
     also have "\<dots> = snd ` Some -` refresh_1 g ` pred A a p"
       unfolding dom_def image_def Int_def by auto metis
     also have "\<Squnion>(snd ` (Some -` refresh_1 g ` pred A a p)) \<longleftrightarrow> c"
       using assms(3) unfolding bounds_3_def by (auto simp: Let_def split: if_splits)
     finally show "e \<longleftrightarrow> c" by this
   qed
 
   lemma complement_4_language_1: "language (complement_3 A) \<subseteq> language (complement_4 A)"
   proof (rule simulation_language)
     show "alphabet (complement_3 A) \<subseteq> alphabet (complement_4 A)"
       unfolding complement_3_def complement_4_def by simp
     show "\<exists> q \<in> initial (complement_4 A). (p, q) \<in> R" if "p \<in> initial (complement_3 A)" for p
       using that unfolding complement_3_def complement_4_def R_def by simp
     show "\<exists> g' \<in> transition (complement_4 A) a g. (f', g') \<in> R"
       if "f' \<in> transition (complement_3 A) a f" "(f, g) \<in> R"
       for a f f' g
     proof -
       have 1: "f' \<in> expand_map (get_3 A (bounds_3 A a (refresh_1 f)))"
         using that(1) unfolding complement_3_def complement_succ_3_def by auto
       have 2:
         "dom f = dom g"
         "\<forall> p \<in> dom f. fst (the (f p)) \<le> fst (the (g p))"
         "\<forall> p \<in> dom f. snd (the (f p)) \<longleftrightarrow> snd (the (g p))"
         using that(2) unfolding R_def by auto
       have "dom f' = dom (get_3 A (bounds_3 A a (refresh_1 f)))" using expand_map_dom 1 by this
       also have "\<dots> = dom (bounds_3 A a (refresh_1 f))" by simp
       finally have 3: "dom f' = dom (bounds_3 A a (refresh_1 f))" by this
       define g' where "g' p \<equiv> do
       {
         (k, c) \<leftarrow> bounds_3 A a (refresh_1 g) p;
         (l, d) \<leftarrow> f' p;
         Some (if even k = even l then k else k - 1, d)
       }" for p
       have 4: "g' p = do
       {
         kc \<leftarrow> bounds_3 A a (refresh_1 g) p;
         ld \<leftarrow> f' p;
         Some (if even (fst kc) = even (fst ld) then fst kc else fst kc - 1, snd ld)
       }" for p unfolding g'_def case_prod_beta by rule
       have "dom g' = dom (bounds_3 A a (refresh_1 g)) \<inter> dom f'" using 4 bind_eq_Some_conv by fastforce
       also have "\<dots> = dom f'" using 2 3 by simp
       finally have 5: "dom g' = dom f'" by this
       have 6: "(l, d) \<in> items_3 A p (k, c)"
         if "bounds_3 A a (refresh_1 f) p = Some (k, c)" "f' p = Some (l, d)" for p k c l d
         using 1 that unfolding expand_map_alt_def get_3_def by blast
       show ?thesis
       unfolding complement_4_def nba.sel complement_succ_4_def comp_apply
       proof
         show "(f', g') \<in> R"
         unfolding R_def mem_Collect_eq prod.case
         proof (intro conjI ballI)
           show "dom f' = dom g'" using 5 by rule
         next
           fix p
           assume 10: "p \<in> dom f'"
           have 11: "p \<in> dom (bounds_3 A a (refresh_1 g))" using 2(1) 3 10 by simp
           obtain k c where 12: "bounds_3 A a (refresh_1 g) p = Some (k, c)" using 11 by fast
           obtain l d where 13: "f' p = Some (l, d)" using 10 by auto
           obtain n e where 14: "bounds_3 A a (refresh_1 f) p = Some (n, e)" using 10 3 by fast
           have 15: "(l, d) \<in> items_3 A p (n, e)" using 6 14 13 by this
           have 16: "n \<le> k" using bounds_R(1) that(2) 14 12 by this
           have 17: "l \<le> k" using 15 16 unfolding items_3_def by simp
           have 18: "even k \<longleftrightarrow> odd l \<Longrightarrow> l \<le> k \<Longrightarrow> l \<le> k - 1" by presburger
           have 19: "e \<longleftrightarrow> c" using bounds_R(2) that(2) 14 12 by this
           show "fst (the (f' p)) \<le> fst (the (g' p))" using 17 18 unfolding 4 12 13 by simp
           show "snd (the (f' p)) \<longleftrightarrow> snd (the (g' p))" using 19 unfolding 4 12 13 by simp
         qed
         show "g' \<in> expand_map (get_4 A (bounds_3 A a (refresh_1 g)))"
         unfolding expand_map_alt_def mem_Collect_eq
         proof (intro conjI allI impI)
           show "dom g' = dom (get_4 A (bounds_3 A a (refresh_1 g)))" using 2(1) 3 5 by simp
           fix p S xy
           assume 10: "get_4 A (bounds_3 A a (refresh_1 g)) p = Some S"
           assume 11: "g' p = Some xy"
           obtain k c where 12: "bounds_3 A a (refresh_1 g) p = Some (k, c)" "S = items_4 A p (k, c)"
             using 10 unfolding get_4_def by auto
           obtain l d where 13: "f' p = Some (l, d)" "xy = (if even k \<longleftrightarrow> even l then k else k - 1, d)"
             using 11 12 unfolding g'_def by (auto split: bind_splits)
           obtain n e where 14: "bounds_3 A a (refresh_1 f) p = Some (n, e)" using 13(1) 3 by fast
           have 15: "(l, d) \<in> items_3 A p (n, e)" using 6 14 13(1) by this
           have 16: "n \<le> k" using bounds_R(1) that(2) 14 12(1) by this
           have 17: "e \<longleftrightarrow> c" using bounds_R(2) that(2) 14 12(1) by this
           show "xy \<in> S" using 15 16 17 unfolding 12(2) 13(2) items_3_def items_4_def by auto
         qed
       qed
     qed
     show "\<And> p q. (p, q) \<in> R \<Longrightarrow> accepting (complement_3 A) p \<Longrightarrow> accepting (complement_4 A) q"
       unfolding complement_3_def complement_4_def R_def map_to_set_def
       by (auto) (metis domIff eq_snd_iff option.exhaust_sel option.sel)
   qed
   lemma complement_4_less: "complement_4 A \<le> complement_3 A"
   unfolding less_eq_nba_def
   unfolding complement_4_def complement_3_def nba.sel
   unfolding complement_succ_4_def complement_succ_3_def
   proof (safe intro!: le_funI, unfold comp_apply)
     fix a f g
     assume "g \<in> expand_map (get_4 A (bounds_3 A a (refresh_1 f)))"
     then show "g \<in> expand_map (get_3 A (bounds_3 A a (refresh_1 f)))"
       unfolding get_4_def get_3_def items_4_def items_3_def expand_map_alt_def by blast
   qed
   lemma complement_4_language_2: "language (complement_4 A) \<subseteq> language (complement_3 A)"
     using language_mono complement_4_less by (auto dest: monoD)
   lemma complement_4_language: "language (complement_3 A) = language (complement_4 A)"
     using complement_4_language_1 complement_4_language_2 by blast
 
   lemma complement_4_finite[simp]:
     assumes "finite (nodes A)"
     shows "finite (nodes (complement_4 A))"
   proof -
     have "(nodes (complement_3 A), nodes (complement_2 A)) \<in> \<langle>Id\<rangle> set_rel"
       using complement_3_refine by parametricity auto
     also have "(nodes (complement_2 A), nodes (complement_1 A)) \<in> \<langle>Id\<rangle> set_rel"
       using complement_2_refine by parametricity auto
     also have "(nodes (complement_1 A), nodes (complement A)) \<in> \<langle>cs_rel\<rangle> set_rel"
       using complement_1_refine by parametricity auto
     finally have 1: "(nodes (complement_3 A), nodes (complement A)) \<in> \<langle>cs_rel\<rangle> set_rel" by simp
     have 2: "finite (nodes (complement A))" using complement_finite assms(1) by this
     have 3: "finite (nodes (complement_3 A))"
       using finite_set_rel_transfer_back 1 cs_rel_inv_single_valued 2 by this
     have 4: "nodes (complement_4 A) \<subseteq> nodes (complement_3 A)"
       using nodes_mono complement_4_less by (auto dest: monoD)
     show "finite (nodes (complement_4 A))" using finite_subset 4 3 by this
   qed
   lemma complement_4_correct:
     assumes "finite (nodes A)"
     shows "language (complement_4 A) = streams (alphabet A) - language A"
   proof -
     have "language (complement_4 A) = language (complement_3 A)"
       using complement_4_language by rule
     also have "(language (complement_3 A), language (complement_2 A)) \<in> \<langle>\<langle>Id\<rangle> stream_rel\<rangle> set_rel"
       using complement_3_refine by parametricity auto
     also have "(language (complement_2 A), language (complement_1 A)) \<in> \<langle>\<langle>Id\<rangle> stream_rel\<rangle> set_rel"
       using complement_2_refine by parametricity auto
     also have "(language (complement_1 A), language (complement A)) \<in> \<langle>\<langle>Id\<rangle> stream_rel\<rangle> set_rel"
       using complement_1_refine by parametricity auto
     also have "language (complement A) = streams (alphabet A) - language A"
       using complement_language assms(1) by this
     finally show "language (complement_4 A) = streams (alphabet A) - language A" by simp
   qed
 
   subsection \<open>Phase 5\<close>
 
   definition refresh_5 :: "'state items \<Rightarrow> 'state items nres" where
     "refresh_5 f \<equiv> if \<exists> (p, k, c) \<in> map_to_set f. c
       then RETURN f
       else do
       {
         ASSUME (finite (dom f));
         FOREACH (map_to_set f) (\<lambda> (p, k, c) m. do
         {
           ASSERT (p \<notin> dom m);
           RETURN (m (p \<mapsto> (k, True)))
         }
         ) Map.empty
       }"
   definition merge_5 :: "item \<Rightarrow> item option \<Rightarrow> item" where
     "merge_5 \<equiv> \<lambda> (k, c). \<lambda> None \<Rightarrow> (k, c) | Some (l, d) \<Rightarrow> (k \<sqinter> l, c \<squnion> d)"
   definition bounds_5 :: "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items nres" where
     "bounds_5 A a f \<equiv> do
     {
       ASSUME (finite (dom f));
       ASSUME (\<forall> p. finite (transition A a p));
       FOREACH (map_to_set f) (\<lambda> (p, s) m.
         FOREACH (transition A a p) (\<lambda> q f.
           RETURN (f (q \<mapsto> merge_5 s (f q))))
         m)
       Map.empty
     }"
   definition items_5 :: "('label, 'state) nba \<Rightarrow> 'state \<Rightarrow> item \<Rightarrow> item set" where
     "items_5 A p \<equiv> \<lambda> (k, c). do
     {
       let values = if accepting A p then Set.filter even {k - 1 .. k} else {k - 1 .. k};
       let item = \<lambda> l. (l, c \<and> even l);
       item ` values
     }"
   definition get_5 :: "('label, 'state) nba \<Rightarrow> 'state items \<Rightarrow> ('state \<rightharpoonup> item set)" where
     "get_5 A f \<equiv> \<lambda> p. map_option (items_5 A p) (f p)"
   definition expand_5 :: "('a \<rightharpoonup> 'b set) \<Rightarrow> ('a \<rightharpoonup> 'b) set nres" where
     "expand_5 f \<equiv> FOREACH (map_to_set f) (\<lambda> (x, S) X. do {
         ASSERT (\<forall> g \<in> X. x \<notin> dom g);
         ASSERT (\<forall> a \<in> S. \<forall> b \<in> S. a \<noteq> b \<longrightarrow> (\<lambda> y. (\<lambda> g. g (x \<mapsto> y)) ` X) a \<inter> (\<lambda> y. (\<lambda> g. g (x \<mapsto> y)) ` X) b = {});
         RETURN (\<Union> y \<in> S. (\<lambda> g. g (x \<mapsto> y)) ` X)
       }) {Map.empty}"
   definition complement_succ_5 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set nres" where
     "complement_succ_5 A a f \<equiv> do
     {
       f \<leftarrow> refresh_5 f;
       f \<leftarrow> bounds_5 A a f;
       ASSUME (finite (dom f));
       expand_5 (get_5 A f)
     }"
 
   lemma bounds_3_empty: "bounds_3 A a Map.empty = Map.empty"
     unfolding bounds_3_def Let_def by auto
   lemma bounds_3_update: "bounds_3 A a (f (p \<mapsto> s)) =
     override_on (bounds_3 A a f) (Some \<circ> merge_5 s \<circ> bounds_3 A a (f (p := None))) (transition A a p)"
   proof
     note fun_upd_image[simp]
     fix q
     show "bounds_3 A a (f (p \<mapsto> s)) q =
       override_on (bounds_3 A a f) (Some \<circ> merge_5 s \<circ> bounds_3 A a (f (p := None))) (transition A a p) q"
     proof (cases "q \<in> transition A a p")
       case True
       define S where "S \<equiv> Some -` f ` (pred A a q - {p})"
       have 1: "Some -` f (p := Some s) ` pred A a q = insert s S" using True unfolding S_def by auto
       have 2: "Some -` f (p := None) ` pred A a q = S" unfolding S_def by auto
       have "bounds_3 A a (f (p \<mapsto> s)) q = Some (\<Sqinter>(fst ` (insert s S)), \<Squnion>(snd ` (insert s S)))"
         unfolding bounds_3_def 1 by simp
       also have "\<dots> = Some (merge_5 s (bounds_3 A a (f (p := None)) q))"
         unfolding 2 bounds_3_def merge_5_def by (cases s) (simp_all add: cInf_insert)
       also have "\<dots> = override_on (bounds_3 A a f) (Some \<circ> merge_5 s \<circ> bounds_3 A a (f (p := None)))
         (transition A a p) q" using True by simp
       finally show ?thesis by this
     next
       case False
       then have "pred A a q \<inter> {x. x \<noteq> p} = pred A a q"
         by auto
       with False show ?thesis by (simp add: bounds_3_def)
     qed
   qed
 
   lemma refresh_5_refine: "(refresh_5, \<lambda> f. RETURN (refresh_1 f)) \<in> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
   proof safe
     fix f :: "'a \<Rightarrow> item option"
     have 1: "(\<exists> (p, k, c) \<in> map_to_set f. c) \<longleftrightarrow> True \<in> snd ` ran f"
       unfolding image_def map_to_set_def ran_def by force
     show "(refresh_5 f, RETURN (refresh_1 f)) \<in> \<langle>Id\<rangle> nres_rel"
       unfolding refresh_5_def refresh_1_def 1
       by (refine_vcg FOREACH_rule_map_eq[where X = "\<lambda> m. map_option (apsnd \<top>) \<circ> m"]) (auto)
   qed
   lemma bounds_5_refine: "(bounds_5 A a, \<lambda> f. RETURN (bounds_3 A a f)) \<in> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
     unfolding bounds_5_def by
       (refine_vcg FOREACH_rule_map_eq[where X = "bounds_3 A a"] FOREACH_rule_insert_eq)
       (auto simp: override_on_insert bounds_3_empty bounds_3_update)
   lemma items_5_refine: "items_5 = items_4"
     unfolding items_5_def items_4_def by (intro ext) (auto split: if_splits)
   lemma get_5_refine: "get_5 = get_4"
     unfolding get_5_def get_4_def items_5_refine by rule
   lemma expand_5_refine: "(expand_5 f, ASSERT (finite (dom f)) \<then> RETURN (expand_map f)) \<in> \<langle>Id\<rangle> nres_rel"
     unfolding expand_5_def
     by (refine_vcg FOREACH_rule_map_eq[where X = expand_map]) (auto dest!: expand_map_dom map_upd_eqD1)
 
   lemma complement_succ_5_refine: "(complement_succ_5, RETURN \<circ>\<circ>\<circ> complement_succ_4) \<in>
     Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
     unfolding complement_succ_5_def complement_succ_4_def get_5_refine comp_apply
     by (refine_vcg vcg1[OF refresh_5_refine] vcg1[OF bounds_5_refine] vcg0[OF expand_5_refine]) (auto)
 
   subsection \<open>Phase 6\<close>
 
   definition expand_map_get_6 :: "('label, 'state) nba \<Rightarrow> 'state items \<Rightarrow> 'state items set nres" where
     "expand_map_get_6 A f \<equiv> FOREACH (map_to_set f) (\<lambda> (k, v) X. do {
       ASSERT (\<forall> g \<in> X. k \<notin> dom g);
       ASSERT (\<forall> a \<in> (items_5 A k v). \<forall> b \<in> (items_5 A k v). a \<noteq> b \<longrightarrow> (\<lambda> y. (\<lambda> g. g (k \<mapsto> y)) ` X) a \<inter> (\<lambda> y. (\<lambda> g. g (k \<mapsto> y)) ` X) b = {});
       RETURN (\<Union> y \<in> items_5 A k v. (\<lambda> g. g (k \<mapsto> y)) ` X)
       }) {Map.empty}"
 
   lemma expand_map_get_6_refine: "(expand_map_get_6, expand_5 \<circ>\<circ> get_5) \<in> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
     unfolding expand_map_get_6_def expand_5_def get_5_def by (auto intro: FOREACH_rule_map_map[param_fo])
 
   definition complement_succ_6 ::
     "('label, 'state) nba \<Rightarrow> 'label \<Rightarrow> 'state items \<Rightarrow> 'state items set nres" where
     "complement_succ_6 A a f \<equiv> do
     {
       f \<leftarrow> refresh_5 f;
       f \<leftarrow> bounds_5 A a f;
       ASSUME (finite (dom f));
       expand_map_get_6 A f
     }"
 
   lemma complement_succ_6_refine:
     "(complement_succ_6, complement_succ_5) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
     unfolding complement_succ_6_def complement_succ_5_def
     by (refine_vcg vcg2[OF expand_map_get_6_refine]) (auto intro: refine_IdI)
 
   subsection \<open>Phase 7\<close>
 
   interpretation autoref_syn by this
 
   context
     fixes fi f
     assumes fi[autoref_rules]: "(fi, f) \<in> state_rel"
   begin
 
     private lemma [simp]: "finite (dom f)"
       using list_map_rel_finite fi unfolding finite_map_rel_def by force
 
     schematic_goal refresh_7: "(?f :: ?'a, refresh_5 f) \<in> ?R"
       unfolding refresh_5_def by (autoref_monadic (plain))
 
   end
 
   concrete_definition refresh_7 uses refresh_7
 
   lemma refresh_7_refine: "(\<lambda> f. RETURN (refresh_7 f), refresh_5) \<in> state_rel \<rightarrow> \<langle>state_rel\<rangle> nres_rel"
     using refresh_7.refine by fast
 
   context
     fixes A :: "('label, nat) nba"
     fixes succi a fi f
     assumes succi[autoref_rules]: "(succi, transition A a) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle> list_set_rel"
     assumes fi[autoref_rules]: "(fi, f) \<in> state_rel"
   begin
 
     private lemma [simp]: "finite (transition A a p)"
       using list_set_rel_finite succi[param_fo] unfolding finite_set_rel_def by blast
     private lemma [simp]: "finite (dom f)" using fi by force
 
     private lemma [autoref_op_pat]: "transition A a \<equiv> OP (transition A a)" by simp
 
     private lemma [autoref_rules]: "(min, min) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel" by simp
 
     schematic_goal bounds_7: 
       notes ty_REL[where R = "\<langle>nat_rel, item_rel\<rangle> dflt_ahm_rel", autoref_tyrel]
       shows "(?f :: ?'a, bounds_5 A a f) \<in> ?R"
       unfolding bounds_5_def merge_5_def sup_bool_def inf_nat_def by (autoref_monadic (plain))
 
   end
 
   concrete_definition bounds_7 uses bounds_7
 
   lemma bounds_7_refine: "(si, transition A a) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle> list_set_rel \<Longrightarrow>
     (\<lambda> p. RETURN (bounds_7 si p), bounds_5 A a) \<in>
     state_rel \<rightarrow> \<langle>\<langle>nat_rel, item_rel\<rangle> dflt_ahm_rel\<rangle> nres_rel"
     using bounds_7.refine by auto
 
   context
     fixes A :: "('label, nat) nba"
     fixes acci
     assumes [autoref_rules]: "(acci, accepting A) \<in> nat_rel \<rightarrow> bool_rel"
   begin
 
     private lemma [autoref_op_pat]: "accepting A \<equiv> OP (accepting A)" by simp
 
     private lemma [autoref_rules]: "((dvd), (dvd)) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel" by simp
     private lemma [autoref_rules]: "(\<lambda> k l. upt k (Suc l), atLeastAtMost) \<in>
       nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle> list_set_rel"
       by (auto simp: list_set_rel_def in_br_conv)
 
     schematic_goal items_7: "(?f :: ?'a, items_5 A) \<in> ?R"
       unfolding items_5_def Let_def Set.filter_def by autoref
 
   end
 
   concrete_definition items_7 uses items_7
 
   (* TODO: use generic expand_map implementation *)
   context
     fixes A :: "('label, nat) nba"
     fixes ai
     fixes fi f
     assumes ai: "(ai, accepting A) \<in> nat_rel \<rightarrow> bool_rel"
     assumes fi[autoref_rules]: "(fi, f) \<in> \<langle>nat_rel, item_rel\<rangle> dflt_ahm_rel"
   begin
 
     private lemma [simp]: "finite (dom f)"
       using dflt_ahm_rel_finite_nat fi unfolding finite_map_rel_def by force
     private lemma [simp]:
       assumes "\<And> m. m \<in> S \<Longrightarrow> x \<notin> dom m"
       shows "inj_on (\<lambda> m. m (x \<mapsto> y)) S"
       using assms unfolding dom_def inj_on_def by (auto) (metis fun_upd_triv fun_upd_upd)
     private lemmas [simp] = op_map_update_def[abs_def]
 
     private lemma [autoref_op_pat]: "items_5 A \<equiv> OP (items_5 A)" by simp
 
     private lemmas [autoref_rules] = items_7.refine[OF ai]
 
     schematic_goal expand_map_get_7: "(?f, expand_map_get_6 A f) \<in>
       \<langle>\<langle>state_rel\<rangle> list_set_rel\<rangle> nres_rel"
       unfolding expand_map_get_6_def by (autoref_monadic (plain))
 
   end
 
   concrete_definition expand_map_get_7 uses expand_map_get_7
 
   lemma expand_map_get_7_refine:
     assumes "(ai, accepting A) \<in> nat_rel \<rightarrow> bool_rel"
     shows "(\<lambda> fi. RETURN (expand_map_get_7 ai fi),
       \<lambda> f. ASSUME (finite (dom f)) \<then> expand_map_get_6 A f) \<in>
       \<langle>nat_rel, item_rel\<rangle> dflt_ahm_rel \<rightarrow> \<langle>\<langle>state_rel\<rangle> list_set_rel\<rangle> nres_rel"
     using expand_map_get_7.refine[OF assms] by auto
 
   context
     fixes A :: "('label, nat) nba"
     fixes a :: "'label"
     fixes p :: "nat items"
     fixes Ai
     fixes ai
     fixes pi
     assumes Ai: "(Ai, A) \<in> \<langle>Id, Id\<rangle> nbai_nba_rel"
     assumes ai: "(ai, a) \<in> Id"
     assumes pi[autoref_rules]: "(pi, p) \<in> state_rel"
   begin
 
     private lemmas succi = nbai_nba_param(4)[THEN fun_relD, OF Ai, THEN fun_relD, OF ai]
     private lemmas acceptingi = nbai_nba_param(5)[THEN fun_relD, OF Ai]
 
     private lemma [autoref_op_pat]: "(\<lambda> g. ASSUME (finite (dom g)) \<then> expand_map_get_6 A g) \<equiv>
       OP (\<lambda> g. ASSUME (finite (dom g)) \<then> expand_map_get_6 A g)" by simp
     private lemma [autoref_op_pat]: "bounds_5 A a \<equiv> OP (bounds_5 A a)" by simp
 
     private lemmas [autoref_rules] =
       refresh_7_refine
       bounds_7_refine[OF succi]
       expand_map_get_7_refine[OF acceptingi]
 
     schematic_goal complement_succ_7: "(?f :: ?'a, complement_succ_6 A a p) \<in> ?R"
       unfolding complement_succ_6_def by (autoref_monadic (plain))
 
   end
 
   concrete_definition complement_succ_7 uses complement_succ_7
 
   lemma complement_succ_7_refine:
     "(RETURN \<circ>\<circ>\<circ> complement_succ_7, complement_succ_6) \<in>
       \<langle>Id, Id\<rangle> nbai_nba_rel \<rightarrow> Id \<rightarrow> state_rel \<rightarrow>
       \<langle>\<langle>state_rel\<rangle> list_set_rel\<rangle> nres_rel"
     using complement_succ_7.refine unfolding comp_apply by parametricity
 
   context
     fixes A :: "('label, nat) nba"
     fixes Ai
     fixes n ni :: nat
     assumes Ai: "(Ai, A) \<in> \<langle>Id, Id\<rangle> nbai_nba_rel"
     assumes ni[autoref_rules]: "(ni, n) \<in> Id"
   begin
 
     private lemma [autoref_op_pat]: "initial A \<equiv> OP (initial A)" by simp
 
     private lemmas [autoref_rules] = nbai_nba_param(3)[THEN fun_relD, OF Ai]
 
     schematic_goal complement_initial_7:
       "(?f, {(Some \<circ> (const (2 * n, False))) |` initial A}) \<in> \<langle>state_rel\<rangle> list_set_rel"
       by autoref
 
   end
 
   concrete_definition complement_initial_7 uses complement_initial_7
 
   schematic_goal complement_accepting_7: "(?f, \<lambda> f. \<forall> (p, k, c) \<in> map_to_set f. \<not> c) \<in>
     state_rel \<rightarrow> bool_rel"
     by autoref
 
   concrete_definition complement_accepting_7 uses complement_accepting_7
 
   definition complement_7 :: "('label, nat) nbai \<Rightarrow> nat \<Rightarrow> ('label, state) nbai" where
     "complement_7 Ai ni \<equiv> nbai
       (alphabeti Ai)
       (complement_initial_7 Ai ni)
       (complement_succ_7 Ai)
       (complement_accepting_7)"
 
   lemma complement_7_refine[autoref_rules]:
     assumes "(Ai, A) \<in> \<langle>Id, Id\<rangle> nbai_nba_rel"
     assumes "(ni,
       (OP card ::: \<langle>Id\<rangle> ahs_rel bhc \<rightarrow> nat_rel) $
       ((OP nodes ::: \<langle>Id, Id\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id\<rangle> ahs_rel bhc) $ A)) \<in> nat_rel"
     shows "(complement_7 Ai ni, (OP complement_4 :::
       \<langle>Id, Id\<rangle> nbai_nba_rel \<rightarrow> \<langle>Id, state_rel\<rangle> nbai_nba_rel) $ A) \<in> \<langle>Id, state_rel\<rangle> nbai_nba_rel"
   proof -
     note complement_succ_7_refine
     also note complement_succ_6_refine
     also note complement_succ_5_refine
     finally have 1: "(complement_succ_7, complement_succ_4) \<in>
       \<langle>Id, Id\<rangle> nbai_nba_rel \<rightarrow> Id \<rightarrow> state_rel \<rightarrow> \<langle>state_rel\<rangle> list_set_rel"
       unfolding nres_rel_comp unfolding nres_rel_def unfolding fun_rel_def by auto
     show ?thesis
       unfolding complement_7_def complement_4_def
       using 1 complement_initial_7.refine complement_accepting_7.refine assms
       unfolding autoref_tag_defs
       by parametricity
   qed
 
 end
\ No newline at end of file
diff --git a/thys/Concurrent_Ref_Alg/Refinement_Lattice.thy b/thys/Concurrent_Ref_Alg/Refinement_Lattice.thy
--- a/thys/Concurrent_Ref_Alg/Refinement_Lattice.thy
+++ b/thys/Concurrent_Ref_Alg/Refinement_Lattice.thy
@@ -1,115 +1,116 @@
 section \<open>Refinement Lattice \label{S:lattice}\<close>
 
 theory Refinement_Lattice
 imports
   Main
-  "HOL-Library.Lattice_Syntax"
 begin
 
+unbundle lattice_syntax
+
 text \<open>
   The underlying lattice of commands is complete and distributive.
   We follow the refinement calculus tradition so that $\nondet$ 
   is non-deterministic choice and $c \refsto d$ means $c$ is refined 
   (or implemented) by $d$.
 \<close>
 
 declare [[show_sorts]]
 
 text \<open>Remove existing notation for quotient as it interferes with the rely quotient\<close>
 no_notation Equiv_Relations.quotient  (infixl "'/'/" 90)
 
 class refinement_lattice = complete_distrib_lattice
 begin
 
 text \<open>The refinement lattice infimum corresponds to non-deterministic choice for commands.\<close>
 
 abbreviation
   refine :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
 where
   "c \<sqsubseteq> d \<equiv> less_eq c d"
 
 abbreviation
   refine_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 50)
 where
   "c \<sqsubset> d \<equiv> less c d"
 
 text \<open>Non-deterministic choice is monotonic in both arguments\<close>
 lemma inf_mono_left: "a \<sqsubseteq> b \<Longrightarrow> a \<sqinter> c \<sqsubseteq> b \<sqinter> c"
   using inf_mono by auto
 
 lemma inf_mono_right: "c \<sqsubseteq> d \<Longrightarrow> a \<sqinter> c \<sqsubseteq> a \<sqinter> d"
   using inf_mono by auto
 
 text \<open>Binary choice is a special case of choice over a set.\<close>
 lemma Inf2_inf: "\<Sqinter>{ f x | x. x \<in> {c, d}} = f c \<sqinter> f d"
 proof -
   have "{ f x | x. x \<in> {c, d}} = {f c, f d}" by blast
   then have "\<Sqinter>{ f x | x. x \<in> {c, d}} = \<Sqinter>{f c, f d}" by simp
   also have "... = f c \<sqinter> f d" by simp
   finally show ?thesis .
 qed
 
 text \<open>Helper lemma for choice over indexed set.\<close>
 lemma INF_Inf: "(\<Sqinter>x\<in>X. f x) = (\<Sqinter>{f x |x. x \<in> X})"
   by (simp add: Setcompr_eq_image)
 
 lemma (in -) INF_absorb_args: "(\<Sqinter>i j. (f::nat \<Rightarrow> 'c::complete_lattice) (i + j)) = (\<Sqinter>k. f k)"
 proof (rule order_class.order.antisym)
   show "(\<Sqinter>k. f k) \<le> (\<Sqinter>i j. f (i + j))"
     by (simp add: complete_lattice_class.INF_lower complete_lattice_class.le_INF_iff)
 next
   have "\<And>k. \<exists>i j. f (i + j) \<le> f k"
     by (metis Nat.add_0_right order_refl)
   then have "\<And>k. \<exists>i. (\<Sqinter>j. f (i + j)) \<le> f k"
     by (meson UNIV_I complete_lattice_class.INF_lower2)
   then show "(\<Sqinter>i j. f (i + j)) \<le> (\<Sqinter>k. f k)"
     by (simp add: complete_lattice_class.INF_mono)
 qed
 
 lemma (in -) nested_Collect: "{f y |y. y \<in> {g x |x. x \<in> X}} = {f (g x) |x. x \<in> X}"
   by blast
 
 text \<open>A transition lemma for INF distributivity properties, going from Inf to INF,
   qualified version followed by a straightforward one.\<close>
 
 lemma Inf_distrib_INF_qual:
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   assumes qual: "P {d x |x. x \<in> X}"
   assumes f_Inf_distrib: "\<And>c D. P D \<Longrightarrow> f c (\<Sqinter> D) = \<Sqinter> {f c d | d . d \<in> D }"
   shows "f c (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. f c (d x))"
 proof -
   have "f c (\<Sqinter>x\<in>X. d x) = f c (\<Sqinter>{d x |x. x \<in> X})" by (simp add: INF_Inf)
   also have "... = (\<Sqinter>{f c dx |dx. dx \<in> {d x | x. x \<in> X}})" by (simp add: qual f_Inf_distrib)
   also have "... = (\<Sqinter>{f c (d x) |x. x \<in> X})" by (simp only: nested_Collect)
   also have "... = (\<Sqinter>x\<in>X. f c (d x))" by (simp add: INF_Inf)
   finally show ?thesis .
 qed
 
 lemma Inf_distrib_INF:
   fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   assumes f_Inf_distrib: "\<And>c D. f c (\<Sqinter> D) = \<Sqinter> {f c d | d . d \<in> D }"
   shows "f c (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. f c (d x))"
   by (simp add: Setcompr_eq_image f_Inf_distrib image_comp)
 
     
 end
 
 lemmas refine_trans = order.trans
 
 text \<open>More transitivity rules to make calculational reasoning smoother\<close>
 declare ord_eq_le_trans[trans]
 declare ord_le_eq_trans[trans]
 declare dual_order.trans[trans]
 
 
 abbreviation
   dist_over_sup :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
 where
   "dist_over_sup F \<equiv> (\<forall> X . F (\<Squnion> X) = (\<Squnion>x\<in>X. F (x)))"
 
 abbreviation
   dist_over_inf :: "('a::refinement_lattice \<Rightarrow> 'a) \<Rightarrow> bool"
 where
   "dist_over_inf F \<equiv> (\<forall> X . F (\<Sqinter> X) = (\<Sqinter>x\<in>X. F (x)))"
 
 end
diff --git a/thys/Dependent_SIFUM_Type_Systems/Preliminaries.thy b/thys/Dependent_SIFUM_Type_Systems/Preliminaries.thy
--- a/thys/Dependent_SIFUM_Type_Systems/Preliminaries.thy
+++ b/thys/Dependent_SIFUM_Type_Systems/Preliminaries.thy
@@ -1,124 +1,124 @@
 (*
 Title: Value-Dependent SIFUM-Type-Systems
 Authors: Toby Murray, Robert Sison, Edward Pierzchalski, Christine Rizkallah
 (Based on the SIFUM-Type-Systems AFP entry, whose authors
  are: Sylvia Grewe, Heiko Mantel, Daniel Schoepe)
 *)
 section \<open>Preliminaries\<close>
 theory Preliminaries
-imports Main (* "HOL-Library.Lattice_Syntax" *)
+imports Main
 begin
 
 text \<open>Possible modes for variables:\<close>
 datatype Mode = AsmNoReadOrWrite | AsmNoWrite | GuarNoReadOrWrite | GuarNoWrite
 
 text \<open>We consider a two-element security lattice:\<close>
 datatype Sec = High | Low
 
 
 text \<open>@{term Sec} forms a (complete) lattice:\<close>
 instantiation Sec :: complete_lattice
 begin
 
 definition top_Sec_def: "top = High"
 definition sup_Sec_def: "sup d1 d2 = (if (d1 = High \<or> d2 = High) then High else Low)"
 definition inf_Sec_def: "inf d1 d2 = (if (d1 = Low \<or> d2 = Low) then Low else High)"
 definition bot_Sec_def: "bot = Low"
 definition less_eq_Sec_def: "d1 \<le> d2 = (d1 = d2 \<or> d1 = Low)"
 definition less_Sec_def: "d1 < d2 = (d1 = Low \<and> d2 = High)"
 definition Sup_Sec_def: "Sup S = (if (High \<in> S) then High else Low)"
 definition Inf_Sec_def: "Inf S = (if (Low \<in> S) then Low else High)"
 
 instance
   apply (intro_classes)
                  using Sec.exhaust less_Sec_def less_eq_Sec_def inf_Sec_def sup_Sec_def apply auto[10]
        apply (metis Inf_Sec_def Sec.exhaust less_eq_Sec_def)
       apply (metis Inf_Sec_def Sec.exhaust less_eq_Sec_def)
      using Sec.exhaust less_Sec_def less_eq_Sec_def inf_Sec_def sup_Sec_def Inf_Sec_def Sup_Sec_def top_Sec_def bot_Sec_def 
      by auto
 end
 
 text \<open>Memories are mappings from variables to values\<close>
 type_synonym ('var, 'val) Mem = "'var \<Rightarrow> 'val"
 
 text \<open>A mode state maps modes to the set of variables for which the
   given mode is set.\<close>
 type_synonym 'var Mds = "Mode \<Rightarrow> 'var set"
 
 text \<open>Local configurations:\<close>
 type_synonym ('com, 'var, 'val) LocalConf = "('com \<times> 'var Mds) \<times> ('var, 'val) Mem"
 
 text \<open>Global configurations:\<close>
 type_synonym ('com, 'var, 'val) GlobalConf = "('com \<times> 'var Mds) list \<times> ('var, 'val) Mem"
 
 text \<open>A locale to fix various parametric components in Mantel et. al, and assumptions
   about them:\<close>
 locale sifum_security_init =
   fixes dma :: "('Var,'Val) Mem \<Rightarrow> 'Var \<Rightarrow> Sec"
   fixes \<C>_vars :: "'Var \<Rightarrow> 'Var set"
   fixes \<C> :: "'Var set" (* classification control variables *)
   fixes eval :: "('Com, 'Var, 'Val) LocalConf rel"
   fixes some_val :: "'Val"
   fixes INIT :: "('Var,'Val) Mem \<Rightarrow> bool"
   assumes deterministic: "\<lbrakk> (lc, lc') \<in> eval; (lc, lc'') \<in> eval \<rbrakk> \<Longrightarrow> lc' = lc''"
   assumes finite_memory: "finite {(x::'Var). True}"
   defines "\<C> \<equiv> \<Union>x. \<C>_vars x"
   assumes \<C>_vars_\<C>: "x \<in> \<C> \<Longrightarrow> \<C>_vars x = {}"
   assumes dma_\<C>_vars: "\<forall>x\<in>\<C>_vars y. mem\<^sub>1 x = mem\<^sub>2 x \<Longrightarrow> dma mem\<^sub>1 y = dma mem\<^sub>2 y"
   assumes \<C>_Low: "\<forall>x\<in>\<C>. dma mem x = Low"
 
 locale sifum_security = sifum_security_init dma \<C>_vars \<C> eval some_val "\<lambda>_.True"
   for dma :: "('Var,'Val) Mem \<Rightarrow> 'Var \<Rightarrow> Sec"
   and \<C>_vars :: "'Var \<Rightarrow> 'Var set"
   and \<C> :: "'Var set" (* classification control variables *)
   and eval :: "('Com, 'Var, 'Val) LocalConf rel"
   and some_val :: "'Val"
 
 context sifum_security_init begin
 
 lemma \<C>_vars_subset_\<C>:
   "\<C>_vars x \<subseteq> \<C>"
   by(force simp: \<C>_def)
 
 lemma dma_\<C>:
   "\<forall>x\<in>\<C>. mem\<^sub>1 x = mem\<^sub>2 x \<Longrightarrow> dma mem\<^sub>1 = dma mem\<^sub>2"
   proof
     fix y
     assume "\<forall>x\<in>\<C>. mem\<^sub>1 x = mem\<^sub>2 x"
     hence "\<forall>x\<in>\<C>_vars y. mem\<^sub>1 x = mem\<^sub>2 x"
       using \<C>_vars_subset_\<C> by blast
     thus "dma mem\<^sub>1 y = dma mem\<^sub>2 y"
       by(rule dma_\<C>_vars)
   qed
 
 end
 
 (* induction tools, moved up as far as possible *)
 
 lemma my_trancl_induct [consumes 1, case_names base step]:
   "\<lbrakk>(a, b) \<in> r\<^sup>+; 
     P a ; 
    \<And>x y. \<lbrakk>(x, y) \<in> r; P x\<rbrakk> \<Longrightarrow> P y\<rbrakk> \<Longrightarrow> P b"
   by (induct rule: trancl.induct, blast+)
   
 lemma my_trancl_step_induct [consumes 1, case_names base step]:
   "\<lbrakk>(a, b) \<in> r\<^sup>+; 
    \<And>x y. (x, y) \<in> r \<Longrightarrow> P x y;
    \<And>x y z. P x y \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> P x z\<rbrakk> \<Longrightarrow> P a b"
   by (induct rule: trancl_induct, blast+)
   
 lemma my_trancl_big_step_induct [consumes 1, case_names base step]:
   "\<lbrakk>(a, b) \<in> r\<^sup>+; 
    \<And>x y. (x, y) \<in> r \<Longrightarrow> P x y;
    \<And>x y z. (x, y) \<in> r\<^sup>+ \<Longrightarrow> P x y \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> P y z \<Longrightarrow> P x z\<rbrakk> \<Longrightarrow> P a b"
   by (induct rule: trancl.induct, blast+)
   
 lemmas my_trancl_step_induct3 = 
   my_trancl_step_induct[of "((ax,ay), az)" "((bx,by), bz)", split_format (complete),
                  consumes 1, case_names step]
   
 lemmas my_trancl_big_step_induct3 = 
   my_trancl_big_step_induct[of "((ax,ay), az)" "((bx,by), bz)", split_format (complete),
                  consumes 1, case_names base step]
 
 end
diff --git a/thys/Free-Boolean-Algebra/Free_Boolean_Algebra.thy b/thys/Free-Boolean-Algebra/Free_Boolean_Algebra.thy
--- a/thys/Free-Boolean-Algebra/Free_Boolean_Algebra.thy
+++ b/thys/Free-Boolean-Algebra/Free_Boolean_Algebra.thy
@@ -1,753 +1,748 @@
 (*  Title:      Free_Boolean_Algebra.thy
     Author:     Brian Huffman, Portland State University
 *)
 
 section \<open>Free Boolean algebras\<close>
 
 theory Free_Boolean_Algebra
 imports Main
 begin
 
 (*<*)
 notation
   bot ("\<bottom>") and
   top ("\<top>") and
   inf  (infixl "\<sqinter>" 70) and
   sup  (infixl "\<squnion>" 65)
 
 lemma sup_conv_inf:
   fixes x y :: "'a::boolean_algebra"
   shows "x \<squnion> y = - (- x \<sqinter> - y)"
 by simp
 (*>*)
 
 subsection \<open>Free boolean algebra as a set\<close>
 
 text \<open>
   We start by defining the free boolean algebra over type @{typ 'a} as
   an inductive set.  Here \<open>i :: 'a\<close> represents a variable;
   \<open>A :: 'a set\<close> represents a valuation, assigning a truth
   value to each variable; and \<open>S :: 'a set set\<close> represents a
   formula, as the set of valuations that make the formula true.  The
   set \<open>fba\<close> contains representatives of formulas built from
   finite combinations of variables with negation and conjunction.
 \<close>
 
 inductive_set
   fba :: "'a set set set"
 where
   var: "{A. i \<in> A} \<in> fba"
 | Compl: "S \<in> fba \<Longrightarrow> - S \<in> fba"
 | inter: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S \<inter> T \<in> fba"
 
 lemma fba_Diff: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S - T \<in> fba"
 unfolding Diff_eq by (intro fba.inter fba.Compl)
 
 lemma fba_union: "S \<in> fba \<Longrightarrow> T \<in> fba \<Longrightarrow> S \<union> T \<in> fba"
 proof -
   assume "S \<in> fba" and "T \<in> fba"
   hence "- (- S \<inter> - T) \<in> fba" by (intro fba.intros)
   thus "S \<union> T \<in> fba" by simp
 qed
 
 lemma fba_empty: "({} :: 'a set set) \<in> fba"
 proof -
   obtain S :: "'a set set" where "S \<in> fba"
     by (fast intro: fba.var)
   hence "S \<inter> - S \<in> fba"
     by (intro fba.intros)
   thus ?thesis by simp
 qed
 
 lemma fba_UNIV: "(UNIV :: 'a set set) \<in> fba"
 proof -
   have "- {} \<in> fba" using fba_empty by (rule fba.Compl)
   thus "UNIV \<in> fba" by simp
 qed
 
 
 subsection \<open>Free boolean algebra as a type\<close>
 
 text \<open>
   The next step is to use \<open>typedef\<close> to define a type isomorphic
   to the set @{const fba}.  We also define a constructor \<open>var\<close>
   that corresponds with the similarly-named introduction rule for
   @{const fba}.
 \<close>
 
 typedef 'a formula = "fba :: 'a set set set"
   by (auto intro: fba_empty)
 
 definition var :: "'a \<Rightarrow> 'a formula"
 where "var i = Abs_formula {A. i \<in> A}"
 
 lemma Rep_formula_var: "Rep_formula (var i) = {A. i \<in> A}"
 unfolding var_def using fba.var by (rule Abs_formula_inverse)
 
 text \<open>
   \medskip
   Now we make type @{typ "'a formula"} into a Boolean algebra.  This
   involves defining the various operations (ordering relations, binary
   infimum and supremum, complement, difference, top and bottom
   elements) and proving that they satisfy the appropriate laws.
 \<close>
 
 instantiation formula :: (type) boolean_algebra
 begin
 
 definition
   "x \<sqinter> y = Abs_formula (Rep_formula x \<inter> Rep_formula y)"
 
 definition
   "x \<squnion> y = Abs_formula (Rep_formula x \<union> Rep_formula y)"
 
 definition
   "\<top> = Abs_formula UNIV"
 
 definition
   "\<bottom> = Abs_formula {}"
 
 definition
   "x \<le> y \<longleftrightarrow> Rep_formula x \<subseteq> Rep_formula y"
 
 definition
   "x < y \<longleftrightarrow> Rep_formula x \<subset> Rep_formula y"
 
 definition
   "- x = Abs_formula (- Rep_formula x)"
 
 definition
   "x - y = Abs_formula (Rep_formula x - Rep_formula y)"
 
 lemma Rep_formula_inf:
   "Rep_formula (x \<sqinter> y) = Rep_formula x \<inter> Rep_formula y"
 unfolding inf_formula_def
 by (intro Abs_formula_inverse fba.inter Rep_formula)
 
 lemma Rep_formula_sup:
   "Rep_formula (x \<squnion> y) = Rep_formula x \<union> Rep_formula y"
 unfolding sup_formula_def
 by (intro Abs_formula_inverse fba_union Rep_formula)
 
 lemma Rep_formula_top: "Rep_formula \<top> = UNIV"
 unfolding top_formula_def by (intro Abs_formula_inverse fba_UNIV)
 
 lemma Rep_formula_bot: "Rep_formula \<bottom> = {}"
 unfolding bot_formula_def by (intro Abs_formula_inverse fba_empty)
 
 lemma Rep_formula_compl: "Rep_formula (- x) = - Rep_formula x"
 unfolding uminus_formula_def
 by (intro Abs_formula_inverse fba.Compl Rep_formula)
 
 lemma Rep_formula_diff:
   "Rep_formula (x - y) = Rep_formula x - Rep_formula y"
 unfolding minus_formula_def
 by (intro Abs_formula_inverse fba_Diff Rep_formula)
 
 lemmas eq_formula_iff = Rep_formula_inject [symmetric]
 
 lemmas Rep_formula_simps =
   less_eq_formula_def less_formula_def eq_formula_iff
   Rep_formula_sup Rep_formula_inf Rep_formula_top Rep_formula_bot
   Rep_formula_compl Rep_formula_diff Rep_formula_var
 
 instance proof
 qed (unfold Rep_formula_simps, auto)
 
 end
 
 text \<open>
   \medskip
   The laws of a Boolean algebra do not require the top and bottom
   elements to be distinct, so the following rules must be proved
   separately:
 \<close>
 
 lemma bot_neq_top_formula [simp]: "(\<bottom> :: 'a formula) \<noteq> \<top>"
 unfolding Rep_formula_simps by auto
 
 lemma top_neq_bot_formula [simp]: "(\<top> :: 'a formula) \<noteq> \<bottom>"
 unfolding Rep_formula_simps by auto
 
 text \<open>
   \medskip
   Here we prove an essential property of a free Boolean algebra:
   all generators are independent.
 \<close>
 
 lemma var_le_var_simps [simp]:
   "var i \<le> var j \<longleftrightarrow> i = j"
   "\<not> var i \<le> - var j"
   "\<not> - var i \<le> var j"
 unfolding Rep_formula_simps by fast+
 
 lemma var_eq_var_simps [simp]:
   "var i = var j \<longleftrightarrow> i = j"
   "var i \<noteq> - var j"
   "- var i \<noteq> var j"
 unfolding Rep_formula_simps set_eq_subset by fast+
 
 text \<open>
   \medskip
   We conclude this section by proving an induction principle for
   formulas.  It mirrors the definition of the inductive set \<open>fba\<close>, with cases for variables, complements, and conjunction.
 \<close>
 
 lemma formula_induct [case_names var compl inf, induct type: formula]:
   fixes P :: "'a formula \<Rightarrow> bool"
   assumes 1: "\<And>i. P (var i)"
   assumes 2: "\<And>x. P x \<Longrightarrow> P (- x)"
   assumes 3: "\<And>x y. P x \<Longrightarrow> P y \<Longrightarrow> P (x \<sqinter> y)"
   shows "P x"
 proof (induct x rule: Abs_formula_induct)
   fix y :: "'a set set"
   assume "y \<in> fba" thus "P (Abs_formula y)"
   proof (induct rule: fba.induct)
     case (var i)
     have "P (var i)" by (rule 1)
     thus ?case unfolding var_def .
   next
     case (Compl S)
     from \<open>P (Abs_formula S)\<close> have "P (- Abs_formula S)" by (rule 2)
     with \<open>S \<in> fba\<close> show ?case
       unfolding uminus_formula_def by (simp add: Abs_formula_inverse)
   next
     case (inter S T)
     from \<open>P (Abs_formula S)\<close> and \<open>P (Abs_formula T)\<close>
     have "P (Abs_formula S \<sqinter> Abs_formula T)" by (rule 3)
     with \<open>S \<in> fba\<close> and \<open>T \<in> fba\<close> show ?case
       unfolding inf_formula_def by (simp add: Abs_formula_inverse)
   qed
 qed
 
 
 subsection \<open>If-then-else for Boolean algebras\<close>
 
 text \<open>
   This is a generic if-then-else operator for arbitrary Boolean
   algebras.
 \<close>
 
 definition
   ifte :: "'a::boolean_algebra \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
 where
   "ifte a x y = (a \<sqinter> x) \<squnion> (- a \<sqinter> y)"
 
 lemma ifte_top [simp]: "ifte \<top> x y = x"
 unfolding ifte_def by simp
 
 lemma ifte_bot [simp]: "ifte \<bottom> x y = y"
 unfolding ifte_def by simp
 
 lemma ifte_same: "ifte a x x = x"
 unfolding ifte_def
 by (simp add: inf_sup_distrib2 [symmetric] sup_compl_top)
 
 lemma compl_ifte: "- ifte a x y = ifte a (- x) (- y)"
 unfolding ifte_def
 apply (rule order_antisym)
 apply (simp add: inf_sup_distrib1 inf_sup_distrib2 compl_inf_bot)
 apply (simp add: sup_inf_distrib1 sup_inf_distrib2 sup_compl_top)
 apply (simp add: le_infI1 le_infI2 le_supI1 le_supI2)
 apply (simp add: le_infI1 le_infI2 le_supI1 le_supI2)
 done
 
 lemma inf_ifte_distrib:
   "ifte x a b \<sqinter> ifte x c d = ifte x (a \<sqinter> c) (b \<sqinter> d)"
 unfolding ifte_def
 apply (simp add: inf_sup_distrib1 inf_sup_distrib2)
 apply (simp add: inf_sup_aci inf_compl_bot)
 done
 
 lemma ifte_ifte_distrib:
   "ifte x (ifte y a b) (ifte y c d) = ifte y (ifte x a c) (ifte x b d)"
 unfolding ifte_def [of x] sup_conv_inf
 by (simp only: compl_ifte [symmetric] inf_ifte_distrib [symmetric] ifte_same)
 
 
 subsection \<open>Formulas over a set of generators\<close>
 
 text \<open>
   The set \<open>formulas S\<close> consists of those formulas that only
   depend on variables in the set \<open>S\<close>.  It is analogous to the
   @{const lists} operator for the list datatype.
 \<close>
 
 definition
   formulas :: "'a set \<Rightarrow> 'a formula set"
 where
   "formulas S =
     {x. \<forall>A B. (\<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B) \<longrightarrow>
       A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x}"
 
 lemma formulasI:
   assumes "\<And>A B. \<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B
     \<Longrightarrow> A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x"
   shows "x \<in> formulas S"
 using assms unfolding formulas_def by simp
 
 lemma formulasD:
   assumes "x \<in> formulas S"
   assumes "\<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B"
   shows "A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x"
 using assms unfolding formulas_def by simp
 
 lemma formulas_mono: "S \<subseteq> T \<Longrightarrow> formulas S \<subseteq> formulas T"
 by (fast intro!: formulasI elim!: formulasD)
 
 lemma formulas_insert: "x \<in> formulas S \<Longrightarrow> x \<in> formulas (insert a S)"
 unfolding formulas_def by simp
 
 lemma formulas_var: "i \<in> S \<Longrightarrow> var i \<in> formulas S"
 unfolding formulas_def by (simp add: Rep_formula_simps)
 
 lemma formulas_var_iff: "var i \<in> formulas S \<longleftrightarrow> i \<in> S"
 unfolding formulas_def by (simp add: Rep_formula_simps, fast)
 
 lemma formulas_bot: "\<bottom> \<in> formulas S"
 unfolding formulas_def by (simp add: Rep_formula_simps)
 
 lemma formulas_top: "\<top> \<in> formulas S"
 unfolding formulas_def by (simp add: Rep_formula_simps)
 
 lemma formulas_compl: "x \<in> formulas S \<Longrightarrow> - x \<in> formulas S"
 unfolding formulas_def by (simp add: Rep_formula_simps)
 
 lemma formulas_inf:
   "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x \<sqinter> y \<in> formulas S"
 unfolding formulas_def by (auto simp add: Rep_formula_simps)
 
 lemma formulas_sup:
   "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x \<squnion> y \<in> formulas S"
 unfolding formulas_def by (auto simp add: Rep_formula_simps)
 
 lemma formulas_diff:
   "x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow> x - y \<in> formulas S"
 unfolding formulas_def by (auto simp add: Rep_formula_simps)
 
 lemma formulas_ifte:
   "a \<in> formulas S \<Longrightarrow> x \<in> formulas S \<Longrightarrow> y \<in> formulas S \<Longrightarrow>
     ifte a x y \<in> formulas S"
 unfolding ifte_def
 by (intro formulas_sup formulas_inf formulas_compl)
 
 lemmas formulas_intros =
   formulas_var formulas_bot formulas_top formulas_compl
   formulas_inf formulas_sup formulas_diff formulas_ifte
 
 
 subsection \<open>Injectivity of if-then-else\<close>
 
 text \<open>
   The if-then-else operator is injective in some limited
   circumstances: when the scrutinee is a variable that is not
   mentioned in either branch.
 \<close>
 
 lemma ifte_inject:
   assumes "ifte (var i) x y = ifte (var i) x' y'" 
   assumes "i \<notin> S"
   assumes "x \<in> formulas S" and "x' \<in> formulas S"
   assumes "y \<in> formulas S" and "y' \<in> formulas S"
   shows "x = x' \<and> y = y'"
 proof
   have 1: "\<And>A. i \<in> A \<Longrightarrow> A \<in> Rep_formula x \<longleftrightarrow> A \<in> Rep_formula x'"
     using assms(1)
     by (simp add: Rep_formula_simps ifte_def set_eq_iff, fast)
   have 2: "\<And>A. i \<notin> A \<Longrightarrow> A \<in> Rep_formula y \<longleftrightarrow> A \<in> Rep_formula y'"
     using assms(1)
     by (simp add: Rep_formula_simps ifte_def set_eq_iff, fast)
 
   show "x = x'"
   unfolding Rep_formula_simps
   proof (rule set_eqI)
     fix A
     have "A \<in> Rep_formula x \<longleftrightarrow> insert i A \<in> Rep_formula x"
       using \<open>x \<in> formulas S\<close> by (rule formulasD, force simp add: \<open>i \<notin> S\<close>)
     also have "\<dots> \<longleftrightarrow> insert i A \<in> Rep_formula x'"
       by (rule 1, simp)
     also have "\<dots> \<longleftrightarrow> A \<in> Rep_formula x'"
       using \<open>x' \<in> formulas S\<close> by (rule formulasD, force simp add: \<open>i \<notin> S\<close>)
     finally show "A \<in> Rep_formula x \<longleftrightarrow> A \<in> Rep_formula x'" .
   qed
   show  "y = y'"
   unfolding Rep_formula_simps
   proof (rule set_eqI)
     fix A
     have "A \<in> Rep_formula y \<longleftrightarrow> A - {i} \<in> Rep_formula y"
       using \<open>y \<in> formulas S\<close> by (rule formulasD, force simp add: \<open>i \<notin> S\<close>)
     also have "\<dots> \<longleftrightarrow> A - {i} \<in> Rep_formula y'"
       by (rule 2, simp)
     also have "\<dots> \<longleftrightarrow> A \<in> Rep_formula y'"
       using \<open>y' \<in> formulas S\<close> by (rule formulasD, force simp add: \<open>i \<notin> S\<close>)
     finally show "A \<in> Rep_formula y \<longleftrightarrow> A \<in> Rep_formula y'" .
   qed
 qed
 
 
 subsection \<open>Specification of homomorphism operator\<close>
 
 text \<open>
   Our goal is to define a homomorphism operator \<open>hom\<close> such that
   for any function \<open>f\<close>, \<open>hom f\<close> is the unique Boolean
   algebra homomorphism satisfying \<open>hom f (var i) = f i\<close>
   for all \<open>i\<close>.
 
   Instead of defining \<open>hom\<close> directly, we will follow the
   approach used to define Isabelle's \<open>fold\<close> operator for finite
   sets.  First we define the graph of the \<open>hom\<close> function as a
   relation; later we will define the \<open>hom\<close> function itself using
   definite choice.
 
   The \<open>hom_graph\<close> relation is defined inductively, with
   introduction rules based on the if-then-else normal form of Boolean
   formulas.  The relation is also indexed by an extra set parameter
   \<open>S\<close>, to ensure that branches of each if-then-else do not use
   the same variable again.
 \<close>
 
 inductive
   hom_graph ::
     "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a set \<Rightarrow> 'a formula \<Rightarrow> 'b \<Rightarrow> bool"
   for f :: "'a \<Rightarrow> 'b::boolean_algebra"
 where
   bot: "hom_graph f {} bot bot"
 | top: "hom_graph f {} top top"
 | ifte: "i \<notin> S \<Longrightarrow> hom_graph f S x a \<Longrightarrow> hom_graph f S y b \<Longrightarrow>
   hom_graph f (insert i S) (ifte (var i) x y) (ifte (f i) a b)"
 
 text \<open>
   \medskip
   The next two lemmas establish a stronger elimination rule for
   assumptions of the form @{term "hom_graph f (insert i S) x a"}.
   Essentially, they say that we can arrange the top-level if-then-else
   to use the variable of our choice.  The proof makes use of the
   distributive properties of if-then-else.
 \<close>
 
 lemma hom_graph_dest:
   "hom_graph f S x a \<Longrightarrow> k \<in> S \<Longrightarrow> \<exists>y z b c.
     x = ifte (var k) y z \<and> a = ifte (f k) b c \<and>
     hom_graph f (S - {k}) y b \<and> hom_graph f (S - {k}) z c"
 proof (induct set: hom_graph)
   case (ifte i S x a y b) show ?case
   proof (cases "i = k")
     assume "i = k" with ifte(1,2,4) show ?case by auto
   next
     assume "i \<noteq> k"
     with \<open>k \<in> insert i S\<close> have k: "k \<in> S" by simp
     have *: "insert i S - {k} = insert i (S - {k})"
       using \<open>i \<noteq> k\<close> by (simp add: insert_Diff_if)
     have **: "i \<notin> S - {k}" using \<open>i \<notin> S\<close> by simp
     from ifte(1) ifte(3) [OF k] ifte(5) [OF k]
     show ?case
       unfolding *
       apply clarify
       apply (simp only: ifte_ifte_distrib [of "var i"])
       apply (simp only: ifte_ifte_distrib [of "f i"])
       apply (fast intro: hom_graph.ifte [OF **])
       done
   qed
 qed simp_all
 
 lemma hom_graph_insert_elim:
   assumes "hom_graph f (insert i S) x a" and "i \<notin> S"
   obtains y z b c
   where "x = ifte (var i) y z"
     and "a = ifte (f i) b c"
     and "hom_graph f S y b"
     and "hom_graph f S z c"
 using hom_graph_dest [OF assms(1) insertI1]
 by (clarify, simp add: assms(2))
 
 text \<open>
   \medskip
   Now we prove the first uniqueness property of the @{const hom_graph}
   relation.  This version of uniqueness says that for any particular
   value of \<open>S\<close>, the relation @{term "hom_graph f S"} maps each
   \<open>x\<close> to at most one \<open>a\<close>.  The proof uses the
   injectiveness of if-then-else, which we proved earlier.
 \<close>
 
 lemma hom_graph_imp_formulas:
   "hom_graph f S x a \<Longrightarrow> x \<in> formulas S"
 by (induct set: hom_graph, simp_all add: formulas_intros formulas_insert)
 
 lemma hom_graph_unique:
   "hom_graph f S x a \<Longrightarrow> hom_graph f S x a' \<Longrightarrow> a = a'"
 proof (induct arbitrary: a' set: hom_graph)
   case (ifte i S y b z c a')
   from ifte(6,1) obtain y' z' b' c'
     where 1: "ifte (var i) y z = ifte (var i) y' z'"
       and 2: "a' = ifte (f i) b' c'"
       and 3: "hom_graph f S y' b'"
       and 4: "hom_graph f S z' c'"
     by (rule hom_graph_insert_elim)
   from 1 3 4 ifte(1,2,4) have "y = y' \<and> z = z'"
     by (intro ifte_inject hom_graph_imp_formulas)
   with 2 3 4 ifte(3,5) show "ifte (f i) b c = a'"
     by simp
 qed (erule hom_graph.cases, simp_all)+
 
 text \<open>
   \medskip
   The next few lemmas will help to establish a stronger version of the
   uniqueness property of @{const hom_graph}.  They show that the @{const
   hom_graph} relation is preserved if we replace \<open>S\<close> with a
   larger finite set.
 \<close>
 
 lemma hom_graph_insert:
   assumes "hom_graph f S x a"
   shows "hom_graph f (insert i S) x a"
 proof (cases "i \<in> S")
   assume "i \<in> S" with assms show ?thesis by (simp add: insert_absorb)
 next
   assume "i \<notin> S"
   hence "hom_graph f (insert i S) (ifte (var i) x x) (ifte (f i) a a)"
     by (intro hom_graph.ifte assms)
   thus "hom_graph f (insert i S) x a"
     by (simp only: ifte_same)
 qed
 
 lemma hom_graph_finite_superset:
   assumes "hom_graph f S x a" and "finite T" and "S \<subseteq> T"
   shows "hom_graph f T x a"
 proof -
   from \<open>finite T\<close> have "hom_graph f (S \<union> T) x a"
     by (induct set: finite, simp add: assms, simp add: hom_graph_insert)
   with \<open>S \<subseteq> T\<close> show "hom_graph f T x a"
     by (simp only: subset_Un_eq)
 qed
 
 lemma hom_graph_imp_finite:
   "hom_graph f S x a \<Longrightarrow> finite S"
 by (induct set: hom_graph) simp_all
 
 text \<open>
   \medskip
   This stronger uniqueness property says that @{term "hom_graph f"}
   maps each \<open>x\<close> to at most one \<open>a\<close>, even for
   \emph{different} values of the set parameter.
 \<close>
 
 lemma hom_graph_unique':
   assumes "hom_graph f S x a" and "hom_graph f T x a'"
   shows "a = a'"
 proof (rule hom_graph_unique)
   have fin: "finite (S \<union> T)"
     using assms by (intro finite_UnI hom_graph_imp_finite)
   show "hom_graph f (S \<union> T) x a"
     using assms(1) fin Un_upper1 by (rule hom_graph_finite_superset)
   show "hom_graph f (S \<union> T) x a'"
     using assms(2) fin Un_upper2 by (rule hom_graph_finite_superset)
 qed
 
 text \<open>
   \medskip
   Finally, these last few lemmas establish that the @{term "hom_graph
   f"} relation is total: every \<open>x\<close> is mapped to some \<open>a\<close>.
 \<close>
 
 lemma hom_graph_var: "hom_graph f {i} (var i) (f i)"
 proof -
   have "hom_graph f {i} (ifte (var i) top bot) (ifte (f i) top bot)"
     by (simp add: hom_graph.intros)
   thus "hom_graph f {i} (var i) (f i)"
     unfolding ifte_def by simp
 qed
 
 lemma hom_graph_compl:
   "hom_graph f S x a \<Longrightarrow> hom_graph f S (- x) (- a)"
 by (induct set: hom_graph, simp_all add: hom_graph.intros compl_ifte)
 
 lemma hom_graph_inf:
   "hom_graph f S x a \<Longrightarrow> hom_graph f S y b \<Longrightarrow>
    hom_graph f S (x \<sqinter> y) (a \<sqinter> b)"
  apply (induct arbitrary: y b set: hom_graph)
    apply (simp add: hom_graph.bot)
   apply simp
  apply (erule (1) hom_graph_insert_elim)
  apply (auto simp add: inf_ifte_distrib hom_graph.ifte)
 done
 
 lemma hom_graph_union_inf:
   assumes "hom_graph f S x a" and "hom_graph f T y b"
   shows "hom_graph f (S \<union> T) (x \<sqinter> y) (a \<sqinter> b)"
 proof (rule hom_graph_inf)
   have fin: "finite (S \<union> T)"
     using assms by (intro finite_UnI hom_graph_imp_finite)
   show "hom_graph f (S \<union> T) x a"
     using assms(1) fin Un_upper1 by (rule hom_graph_finite_superset)
   show "hom_graph f (S \<union> T) y b"
     using assms(2) fin Un_upper2 by (rule hom_graph_finite_superset)
 qed
 
 lemma hom_graph_exists: "\<exists>a S. hom_graph f S x a"
 by (induct x)
    (auto intro: hom_graph_var hom_graph_compl hom_graph_union_inf)
 
 
 subsection \<open>Homomorphisms into other boolean algebras\<close>
 
 text \<open>
   Now that we have proved the necessary existence and uniqueness
   properties of @{const hom_graph}, we can define the function \<open>hom\<close> using definite choice.
 \<close>
 
 definition
   hom :: "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a formula \<Rightarrow> 'b"
 where
   "hom f x = (THE a. \<exists>S. hom_graph f S x a)"
 
 lemma hom_graph_hom: "\<exists>S. hom_graph f S x (hom f x)"
 unfolding hom_def
 apply (rule theI')
 apply (rule ex_ex1I)
 apply (rule hom_graph_exists)
 apply (fast elim: hom_graph_unique')
 done
 
 lemma hom_equality:
   "hom_graph f S x a \<Longrightarrow> hom f x = a"
 unfolding hom_def
 apply (rule the_equality)
 apply (erule exI)
 apply (erule exE)
 apply (erule (1) hom_graph_unique')
 done
 
 text \<open>
   \medskip
   The @{const hom} function correctly implements its specification:
 \<close>
 
 lemma hom_var [simp]: "hom f (var i) = f i"
 by (rule hom_equality, rule hom_graph_var)
 
 lemma hom_bot [simp]: "hom f \<bottom> = \<bottom>"
 by (rule hom_equality, rule hom_graph.bot)
 
 lemma hom_top [simp]: "hom f \<top> = \<top>"
 by (rule hom_equality, rule hom_graph.top)
 
 lemma hom_compl [simp]: "hom f (- x) = - hom f x"
 proof -
   obtain S where "hom_graph f S x (hom f x)"
     using hom_graph_hom ..
   hence "hom_graph f S (- x) (- hom f x)"
     by (rule hom_graph_compl)
   thus "hom f (- x) = - hom f x"
     by (rule hom_equality)
 qed
 
 lemma hom_inf [simp]: "hom f (x \<sqinter> y) = hom f x \<sqinter> hom f y"
 proof -
   obtain S where S: "hom_graph f S x (hom f x)"
     using hom_graph_hom ..
   obtain T where T: "hom_graph f T y (hom f y)"
     using hom_graph_hom ..
   have "hom_graph f (S \<union> T) (x \<sqinter> y) (hom f x \<sqinter> hom f y)"
     using S T by (rule hom_graph_union_inf)
   thus ?thesis by (rule hom_equality)
 qed
 
 lemma hom_sup [simp]: "hom f (x \<squnion> y) = hom f x \<squnion> hom f y"
 unfolding sup_conv_inf by (simp only: hom_compl hom_inf)
 
 lemma hom_diff [simp]: "hom f (x - y) = hom f x - hom f y"
 unfolding diff_eq by (simp only: hom_compl hom_inf)
 
 lemma hom_ifte [simp]:
   "hom f (ifte x y z) = ifte (hom f x) (hom f y) (hom f z)"
 unfolding ifte_def by (simp only: hom_compl hom_inf hom_sup)
 
 lemmas hom_simps =
   hom_var hom_bot hom_top hom_compl
   hom_inf hom_sup hom_diff hom_ifte
 
 text \<open>
   \medskip
   The type @{typ "'a formula"} can be viewed as a monad, with @{const
   var} as the unit, and @{const hom} as the bind operator.  We can
   prove the standard monad laws with simple proofs by induction.
 \<close>
 
 lemma hom_var_eq_id: "hom var x = x"
 by (induct x) simp_all
 
 lemma hom_hom: "hom f (hom g x) = hom (\<lambda>i. hom f (g i)) x"
 by (induct x) simp_all
 
 
 subsection \<open>Map operation on Boolean formulas\<close>
 
 text \<open>
   We can define a map functional in terms of @{const hom} and @{const
   var}.  The properties of \<open>fmap\<close> follow directly from the
   lemmas we have already proved about @{const hom}.
 \<close>
 
 definition
   fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a formula \<Rightarrow> 'b formula"
 where
   "fmap f = hom (\<lambda>i. var (f i))"
 
 lemma fmap_var [simp]: "fmap f (var i) = var (f i)"
 unfolding fmap_def by simp
 
 lemma fmap_bot [simp]: "fmap f \<bottom> = \<bottom>"
 unfolding fmap_def by simp
 
 lemma fmap_top [simp]: "fmap f \<top> = \<top>"
 unfolding fmap_def by simp
 
 lemma fmap_compl [simp]: "fmap f (- x) = - fmap f x"
 unfolding fmap_def by simp
 
 lemma fmap_inf [simp]: "fmap f (x \<sqinter> y) = fmap f x \<sqinter> fmap f y"
 unfolding fmap_def by simp
 
 lemma fmap_sup [simp]: "fmap f (x \<squnion> y) = fmap f x \<squnion> fmap f y"
 unfolding fmap_def by simp
 
 lemma fmap_diff [simp]: "fmap f (x - y) = fmap f x - fmap f y"
 unfolding fmap_def by simp
 
 lemma fmap_ifte [simp]:
   "fmap f (ifte x y z) = ifte (fmap f x) (fmap f y) (fmap f z)"
 unfolding fmap_def by simp
 
 lemmas fmap_simps =
   fmap_var fmap_bot fmap_top fmap_compl
   fmap_inf fmap_sup fmap_diff fmap_ifte
 
 text \<open>
   \medskip
   The map functional satisfies the functor laws: it preserves identity
   and function composition.
 \<close>
 
 lemma fmap_ident: "fmap (\<lambda>i. i) x = x"
 by (induct x) simp_all
 
 lemma fmap_fmap: "fmap f (fmap g x) = fmap (f \<circ> g) x"
 by (induct x) simp_all
 
 
 subsection \<open>Hiding lattice syntax\<close>
 
 text \<open>
   The following command hides the lattice syntax, to avoid potential
   conflicts with other theories that import this one.  To re-enable
-  the syntax, users should import theory \<open>Lattice_Syntax\<close> from
-  the Isabelle library.
+  the syntax, users should unbundle \<open>lattice_syntax\<close>.
 \<close>
 
-no_notation
-  top ("\<top>") and
-  bot ("\<bottom>") and
-  inf  (infixl "\<sqinter>" 70) and
-  sup  (infixl "\<squnion>" 65)
+unbundle no_lattice_syntax
 
 end
diff --git a/thys/MFODL_Monitor_Optimized/Regex.thy b/thys/MFODL_Monitor_Optimized/Regex.thy
--- a/thys/MFODL_Monitor_Optimized/Regex.thy
+++ b/thys/MFODL_Monitor_Optimized/Regex.thy
@@ -1,372 +1,373 @@
 (*<*)
 theory Regex
   imports
     "MFOTL_Monitor.Trace"
-    "HOL-Library.Lattice_Syntax"
     "HOL-Library.Extended_Nat"
 begin
+
+unbundle lattice_syntax
 (*>*)
 
 section \<open>Regular expressions\<close>
 
 context begin
 
 qualified datatype (atms: 'a) regex = Skip nat | Test 'a
   | Plus "'a regex" "'a regex" | Times "'a regex" "'a regex"  | Star "'a regex"
 
 lemma finite_atms[simp]: "finite (atms r)"
   by (induct r) auto
 
 definition "Wild = Skip 1"
 
 lemma size_regex_estimation[termination_simp]: "x \<in> atms r \<Longrightarrow> y < f x \<Longrightarrow> y < size_regex f r"
   by (induct r) auto
 
 lemma size_regex_estimation'[termination_simp]: "x \<in> atms r \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_regex f r"
   by (induct r) auto
 
 qualified definition "TimesL r S = Times r ` S"
 qualified definition "TimesR R s = (\<lambda>r. Times r s) ` R"
 
 qualified primrec fv_regex where
   "fv_regex fv (Skip n) = {}"
 | "fv_regex fv (Test \<phi>) = fv \<phi>"
 | "fv_regex fv (Plus r s) = fv_regex fv r \<union> fv_regex fv s"
 | "fv_regex fv (Times r s) = fv_regex fv r \<union> fv_regex fv s"
 | "fv_regex fv (Star r) = fv_regex fv r"
 
 lemma fv_regex_cong[fundef_cong]:
   "r = r' \<Longrightarrow> (\<And>z. z \<in> atms r \<Longrightarrow> fv z = fv' z) \<Longrightarrow> fv_regex fv r = fv_regex fv' r'"
   by (induct r arbitrary: r') auto
 
 lemma finite_fv_regex[simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z)) \<Longrightarrow> finite (fv_regex fv r)"
   by (induct r) auto
 
 lemma fv_regex_commute:
   "(\<And>z. z \<in> atms r \<Longrightarrow> x \<in> fv z \<longleftrightarrow> g x \<in> fv' z) \<Longrightarrow> x \<in> fv_regex fv r \<longleftrightarrow> g x \<in> fv_regex fv' r"
   by (induct r) auto
 
 lemma fv_regex_alt: "fv_regex fv r = (\<Union>z \<in> atms r. fv z)"
   by (induct r) auto
 
 qualified definition nfv_regex where
   "nfv_regex fv r = Max (insert 0 (Suc ` fv_regex fv r))"
 
 lemma insert_Un: "insert x (A \<union> B) = insert x A \<union> insert x B"
   by auto
 
 lemma nfv_regex_simps[simp]:
   assumes [simp]: "(\<And>z. z \<in> atms r \<Longrightarrow> finite (fv z))" "(\<And>z. z \<in> atms s \<Longrightarrow> finite (fv z))"
   shows
   "nfv_regex fv (Skip n) = 0"
   "nfv_regex fv (Test \<phi>) = Max (insert 0 (Suc ` fv \<phi>))"
   "nfv_regex fv (Plus r s) = max (nfv_regex fv r) (nfv_regex fv s)"
   "nfv_regex fv (Times r s) = max (nfv_regex fv r) (nfv_regex fv s)"
   "nfv_regex fv (Star r) = nfv_regex fv r"
   unfolding nfv_regex_def
   by (auto simp add: image_Un Max_Un insert_Un simp del: Un_insert_right Un_insert_left)
 
 abbreviation "min_regex_default f r j \<equiv> (if atms r = {} then j else Min ((\<lambda>z. f z j) ` atms r))"
 
 qualified primrec match :: "(nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a regex \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "match test (Skip n) = (\<lambda>i j. j = i + n)"
 | "match test (Test \<phi>) = (\<lambda>i j. i = j \<and> test i \<phi>)"
 | "match test (Plus r s) = match test r \<squnion> match test s"
 | "match test (Times r s) = match test r OO match test s"
 | "match test (Star r) = (match test r)\<^sup>*\<^sup>*"
 
 lemma match_cong[fundef_cong]:
   "r = r' \<Longrightarrow> (\<And>i z. z \<in> atms r \<Longrightarrow> t i z = t' i z) \<Longrightarrow> match t r = match t' r'"
   by (induct r arbitrary: r') auto
 
 qualified primrec eps where
   "eps test i (Skip n) = (n = 0)"
 | "eps test i (Test \<phi>) = test i \<phi>"
 | "eps test i (Plus r s) = (eps test i r \<or> eps test i s)"
 | "eps test i (Times r s) = (eps test i r \<and> eps test i s)"
 | "eps test i (Star r) = True"
 
 qualified primrec lpd where
   "lpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
 | "lpd test i (Test \<phi>) = {}"
 | "lpd test i (Plus r s) = (lpd test i r \<union> lpd test i s)"
 | "lpd test i (Times r s) = TimesR (lpd test i r) s \<union> (if eps test i r then lpd test i s else {})"
 | "lpd test i (Star r) = TimesR (lpd test i r) (Star r)"
 
 qualified primrec lpd\<kappa> where
   "lpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
 | "lpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
 | "lpd\<kappa> \<kappa> test i (Plus r s) = lpd\<kappa> \<kappa> test i r \<union> lpd\<kappa> \<kappa> test i s"
 | "lpd\<kappa> \<kappa> test i (Times r s) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t s)) test i r \<union> (if eps test i r then lpd\<kappa> \<kappa> test i s else {})"
 | "lpd\<kappa> \<kappa> test i (Star r) = lpd\<kappa> (\<lambda>t. \<kappa> (Times t (Star r))) test i r"
 
 qualified primrec rpd where
   "rpd test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {Skip m})"
 | "rpd test i (Test \<phi>) = {}"
 | "rpd test i (Plus r s) = (rpd test i r \<union> rpd test i s)"
 | "rpd test i (Times r s) = TimesL r (rpd test i s) \<union> (if eps test i s then rpd test i r else {})"
 | "rpd test i (Star r) = TimesL (Star r) (rpd test i r)"
 
 qualified primrec rpd\<kappa> where
   "rpd\<kappa> \<kappa> test i (Skip n) = (case n of 0 \<Rightarrow> {} | Suc m \<Rightarrow> {\<kappa> (Skip m)})"
 | "rpd\<kappa> \<kappa> test i (Test \<phi>) = {}"
 | "rpd\<kappa> \<kappa> test i (Plus r s) = rpd\<kappa> \<kappa> test i r \<union> rpd\<kappa> \<kappa> test i s"
 | "rpd\<kappa> \<kappa> test i (Times r s) = rpd\<kappa> (\<lambda>t. \<kappa> (Times r t)) test i s \<union> (if eps test i s then rpd\<kappa> \<kappa> test i r else {})"
 | "rpd\<kappa> \<kappa> test i (Star r) = rpd\<kappa> (\<lambda>t. \<kappa> (Times (Star r) t)) test i r"
 
 lemma lpd\<kappa>_lpd: "lpd\<kappa> \<kappa> test i r = \<kappa> ` lpd test i r"
   by (induct r arbitrary: \<kappa>) (auto simp: TimesR_def split: nat.splits)
 
 lemma rpd\<kappa>_rpd: "rpd\<kappa> \<kappa> test i r = \<kappa> ` rpd test i r"
   by (induct r arbitrary: \<kappa>) (auto simp: TimesL_def split: nat.splits)
 
 lemma match_le: "match test r i j \<Longrightarrow> i \<le> j"
 proof (induction r arbitrary: i j)
   case (Times r s)
   then show ?case using order.trans by fastforce
 next
   case (Star r)
   from Star.prems show ?case
     unfolding match.simps by (induct i j rule: rtranclp.induct) (force dest: Star.IH)+
 qed auto
 
 lemma match_rtranclp_le: "(match test r)\<^sup>*\<^sup>* i j \<Longrightarrow> i \<le> j"
   by (metis match.simps(5) match_le)
 
 lemma eps_match: "eps test i r \<longleftrightarrow> match test r i i"
   by (induction r) (auto dest: antisym[OF match_le match_le])
 
 lemma lpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> lpd test i r. match test s) (i + 1) j"
 proof (induction r arbitrary: i j)
   case (Times r s)
   have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
     by auto
   also have "\<dots> \<longleftrightarrow> match test r i i \<and> match test s i j \<or>
     (\<exists>k>i. match test r i k \<and> match test s k j)"
     using match_le[of test r i] nat_less_le by auto
   also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
     (\<exists>k>i. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
     using Times.IH(1) Times.IH(2)[OF Times.prems] by metis
   also have "\<dots> \<longleftrightarrow> match test r i i \<and> (\<Squnion>t \<in> lpd test i s. match test t) (i + 1) j \<or>
     (\<exists>k. (\<Squnion>t \<in> lpd test i r. match test t) (i + 1) k \<and> match test s k j)"
     using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
   also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` lpd test i (Times r s))) (i + 1) j"
     by (force simp: TimesL_def TimesR_def eps_match)
   finally show ?case .
 next
   case (Star r)
   have "\<exists>s\<in>lpd test i r. (match test s OO (match test r)\<^sup>*\<^sup>*) (i + 1) j" if "(match test r)\<^sup>*\<^sup>* i j"
     using that Star.prems match_le[of test _ "i + 1"]
   proof (induct rule: converse_rtranclp_induct)
     case (step i k)
     then show ?case
       by (cases "i < k") (auto simp: not_less Star.IH dest: match_le)
   qed simp
   with Star.prems show ?case using match_le[of test _  "i + 1"]
     by (auto simp: TimesL_def TimesR_def Suc_le_eq Star.IH[of i]
       elim!: converse_rtranclp_into_rtranclp[rotated])
 qed (auto split: nat.splits)
 
 lemma rpd_match: "i < j \<Longrightarrow> match test r i j \<longleftrightarrow> (\<Squnion>s \<in> rpd test j r. match test s) i (j - 1)"
 proof (induction r arbitrary: i j)
   case (Times r s)
   have "match test (Times r s) i j \<longleftrightarrow> (\<exists>k. match test r i k \<and> match test s k j)"
     by auto
   also have "\<dots> \<longleftrightarrow> match test r i j \<and> match test s j j \<or>
     (\<exists>k<j. match test r i k \<and> match test s k j)"
     using match_le[of test s _ j] nat_less_le by auto
   also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
     (\<exists>k<j. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
     using Times.IH(1)[OF Times.prems] Times.IH(2) by metis
   also have "\<dots> \<longleftrightarrow> (\<Squnion>t \<in> rpd test j r. match test t) i (j - 1) \<and> match test s j j  \<or>
     (\<exists>k. match test r i k \<and> (\<Squnion>t \<in> rpd test j s. match test t) k (j - 1))"
     using Times.prems by (intro disj_cong[OF refl] iff_exI) (auto dest: match_le)
   also have "\<dots> \<longleftrightarrow> (\<Squnion> (match test ` rpd test j (Times r s))) i (j - 1)"
     by (force simp: TimesL_def TimesR_def eps_match)
   finally show ?case .
 next
   case (Star r)
   have "\<exists>s\<in>rpd test j r. ((match test r)\<^sup>*\<^sup>* OO match test s) i (j - 1)" if "(match test r)\<^sup>*\<^sup>* i j"
     using that Star.prems match_le[of test _ _ "j - 1"]
   proof (induct rule: rtranclp_induct)
     case (step k j)
     then show ?case
       by (cases "k < j") (auto simp: not_less Star.IH dest: match_le)
   qed simp
   with Star.prems show ?case
     by (auto 0 3 simp: TimesL_def TimesR_def intro: Star.IH[of _ j, THEN iffD2]
       elim!: rtranclp.rtrancl_into_rtrancl dest: match_le[of test _ _ "j - 1", unfolded One_nat_def])
 qed (auto split: nat.splits)
 
 lemma lpd_fv_regex: "s \<in> lpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
   by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+
 
 lemma rpd_fv_regex: "s \<in> rpd test i r \<Longrightarrow> fv_regex fv s \<subseteq> fv_regex fv r"
   by (induct r arbitrary: s) (auto simp: TimesR_def TimesL_def split: if_splits nat.splits)+
 
 lemma match_fv_cong:
   "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> match test r = match test' r"
   by (induct r) auto
 
 lemma eps_fv_cong:
   "(\<And>i x. x \<in> atms r \<Longrightarrow> test i x = test' i x) \<Longrightarrow> eps test i r = eps test' i r"
   by (induct r) auto
 
 datatype modality = Past | Futu
 datatype safety = Strict | Lax
 
 context
   fixes fv :: "'a \<Rightarrow> 'b set"
   and safe :: "safety \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 qualified fun safe_regex :: "modality \<Rightarrow> safety \<Rightarrow> 'a regex \<Rightarrow> bool" where
   "safe_regex m _ (Skip n) = True"
 | "safe_regex m g (Test \<phi>) = safe g \<phi>"
 | "safe_regex m g (Plus r s) = ((g = Lax \<or> fv_regex fv r = fv_regex fv s) \<and> safe_regex m g r \<and> safe_regex m g s)"
 | "safe_regex Futu g (Times r s) =
     ((g = Lax \<or> fv_regex fv r \<subseteq> fv_regex fv s) \<and> safe_regex Futu g s \<and> safe_regex Futu Lax r)"
 | "safe_regex Past g (Times r s) =
     ((g = Lax \<or> fv_regex fv s \<subseteq> fv_regex fv r) \<and> safe_regex Past g r \<and> safe_regex Past Lax s)"
 | "safe_regex m g (Star r) = ((g = Lax \<or> fv_regex fv r = {}) \<and> safe_regex m g r)"
 
 lemmas safe_regex_induct = safe_regex.induct[case_names Skip Test Plus TimesF TimesP Star]
 
 lemma safe_cosafe:
   "(\<And>x. x \<in> atms r \<Longrightarrow> safe Strict x \<Longrightarrow> safe Lax x) \<Longrightarrow> safe_regex m Strict r \<Longrightarrow> safe_regex m Lax r"
   by (induct r; cases m) auto
 
 lemma safe_lpd_fv_regex_le: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
   by (induct r) (auto simp: TimesR_def split: if_splits)
 
 lemma safe_lpd_fv_regex: "safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
   by (simp add: eq_iff lpd_fv_regex safe_lpd_fv_regex_le)
 
 lemma cosafe_lpd: "safe_regex Futu Lax r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Lax s"
 proof (induct r arbitrary: s)
   case (Plus r1 r2)
   from Plus(3,4) show ?case
     by (auto elim: Plus(1,2))
 next
   case (Times r1 r2)
   from Times(3,4) show ?case
     by (auto simp: TimesR_def elim: Times(1,2) split: if_splits)
 qed (auto simp: TimesR_def split: nat.splits)
 
 lemma safe_lpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
   safe_regex Futu Strict r \<Longrightarrow> s \<in> lpd test i r \<Longrightarrow> safe_regex Futu Strict s"
 proof (induct r arbitrary: s)
   case (Plus r1 r2)
   from Plus(3,4,5) show ?case
     by (auto elim: Plus(1,2) simp: ball_Un)
 next
   case (Times r1 r2)
   from Times(3,4,5) show ?case
     by (force simp: TimesR_def ball_Un elim: Times(1,2) cosafe_lpd dest: lpd_fv_regex split: if_splits)
 next
   case (Star r)
   from Star(2,3,4) show ?case
     by (force simp: TimesR_def elim: Star(1) cosafe_lpd
       dest: safe_cosafe[rotated] lpd_fv_regex[where fv=fv] split: if_splits)
 qed (auto split: nat.splits)
 
 lemma safe_rpd_fv_regex_le: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv r \<subseteq> fv_regex fv s"
   by (induct r) (auto simp: TimesL_def split: if_splits)
 
 lemma safe_rpd_fv_regex: "safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> fv_regex fv s = fv_regex fv r"
   by (simp add: eq_iff rpd_fv_regex safe_rpd_fv_regex_le)
 
 lemma cosafe_rpd: "safe_regex Past Lax r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Lax s"
 proof (induct r arbitrary: s)
   case (Plus r1 r2)
   from Plus(3,4) show ?case
     by (auto elim: Plus(1,2))
 next
   case (Times r1 r2)
   from Times(3,4) show ?case
     by (auto simp: TimesL_def elim: Times(1,2) split: if_splits)
 qed (auto simp: TimesL_def split: nat.splits)
 
 lemma safe_rpd: "(\<forall>x \<in> atms r. safe Strict x \<longrightarrow> safe Lax x) \<Longrightarrow>
   safe_regex Past Strict r \<Longrightarrow> s \<in> rpd test i r \<Longrightarrow> safe_regex Past Strict s"
 proof (induct r arbitrary: s)
   case (Plus r1 r2)
   from Plus(3,4,5) show ?case
     by (auto elim: Plus(1,2) simp: ball_Un)
 next
   case (Times r1 r2)
   from Times(3,4,5) show ?case
     by (force simp: TimesL_def ball_Un elim: Times(1,2) cosafe_rpd dest: rpd_fv_regex split: if_splits)
 next
   case (Star r)
   from Star(2,3,4) show ?case
     by (force simp: TimesL_def elim: Star(1) cosafe_rpd
       dest: safe_cosafe[rotated] rpd_fv_regex[where fv=fv] split: if_splits)
 qed (auto split: nat.splits)
 
 lemma safe_regex_safe: "(\<And>g r. safe g r \<Longrightarrow> safe Lax r) \<Longrightarrow>
   safe_regex m g r \<Longrightarrow> x \<in> atms r \<Longrightarrow> safe Lax x"
   by (induct m g r rule: safe_regex.induct) auto
 
 lemma safe_regex_map_regex:
   "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow>  safe g (f x)) \<Longrightarrow> (\<And>x. x \<in> atms r \<Longrightarrow> fv (f x) = fv x) \<Longrightarrow>
    safe_regex m g r \<Longrightarrow> safe_regex m g (map_regex f r)"
   by (induct m g r rule: safe_regex.induct) (auto simp: fv_regex_alt regex.set_map)
 
 end
 
 lemma safe_regex_cong[fundef_cong]:
   "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x = safe' g x) \<Longrightarrow>
   Regex.safe_regex fv safe m g r = Regex.safe_regex fv safe' m g r"
   by (induct m g r rule: safe_regex.induct) auto
 
 lemma safe_regex_mono:
   "(\<And>g x. x \<in> atms r \<Longrightarrow> safe g x \<Longrightarrow> safe' g x) \<Longrightarrow>
   Regex.safe_regex fv safe m g r \<Longrightarrow> Regex.safe_regex fv safe' m g r"
   by (induct m g r rule: safe_regex.induct) auto
 
 lemma match_map_regex: "match t (map_regex f r) = match (\<lambda>k z. t k (f z)) r"
   by (induct r) auto
 
 lemma match_cong_strong:
   "(\<And>k z. k \<in> {i ..< j + 1} \<Longrightarrow> z \<in> atms r \<Longrightarrow> t k z = t' k z) \<Longrightarrow> match t r i j = match t' r i j"
 proof (induction r arbitrary: i j)
   case (Times r s)
   from Times.prems show ?case
     by (auto 0 4 simp: relcompp_apply intro: le_less_trans match_le less_Suc_eq_le
       dest: Times.IH[THEN iffD1, rotated -1] Times.IH[THEN iffD2, rotated -1] match_le)
 next
   case (Star r)
   show ?case unfolding match.simps
   proof (rule iffI)
     assume *: "(match t r)\<^sup>*\<^sup>* i j"
     then have "i \<le> j" unfolding match.simps(5)[symmetric]
       by (rule match_le)
     with * show "(match t' r)\<^sup>*\<^sup>* i j" using Star.prems
     proof (induction i j rule: rtranclp.induct)
       case (rtrancl_into_rtrancl a b c)
       from rtrancl_into_rtrancl(1,2,4,5) show ?case
         by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
           (auto dest!: Star.IH[THEN iffD1, rotated -1]
             dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
     qed simp
   next
     assume *: "(match t' r)\<^sup>*\<^sup>* i j"
     then have "i \<le> j" unfolding match.simps(5)[symmetric]
       by (rule match_le)
     with * show "(match t r)\<^sup>*\<^sup>* i j" using Star.prems
     proof (induction i j rule: rtranclp.induct)
       case (rtrancl_into_rtrancl a b c)
       from rtrancl_into_rtrancl(1,2,4,5) show ?case
         by (intro rtranclp.rtrancl_into_rtrancl[OF rtrancl_into_rtrancl.IH])
           (auto dest!: Star.IH[THEN iffD2, rotated -1]
             dest: match_le match_rtranclp_le simp: less_Suc_eq_le)
     qed simp
   qed
 qed auto
 
 end
 
 (*<*)
 end
 (*>*)
diff --git a/thys/MonoBoolTranAlgebra/Mono_Bool_Tran.thy b/thys/MonoBoolTranAlgebra/Mono_Bool_Tran.thy
--- a/thys/MonoBoolTranAlgebra/Mono_Bool_Tran.thy
+++ b/thys/MonoBoolTranAlgebra/Mono_Bool_Tran.thy
@@ -1,500 +1,488 @@
 section \<open>Monotonic Boolean Transformers\<close>
 
 theory Mono_Bool_Tran
 imports
   LatticeProperties.Complete_Lattice_Prop
   LatticeProperties.Conj_Disj
 begin
 
 text\<open>
 The type of monotonic transformers is the type associated to the set of monotonic
 functions from a partially ordered set (poset) to itself. The type of monotonic
 transformers with the pointwise extended order is also a poset. 
 The monotonic transformers with composition and identity 
 form a monoid, and the monoid operation is compatible with the order.
 
 Gradually we extend the algebraic structure of monotonic transformers to
 lattices, and complete lattices. We also introduce a dual operator 
 ($(\mathsf{dual}\;f) p = - f (-p)$) on monotonic transformers over
 a boolean algebra. However the monotonic transformers over a boolean
 algebra are not closed to the pointwise extended negation operator.
 
 Finally we introduce an iteration operator on monotonic transformers
 over a complete lattice.
 \<close>
 
-notation
-  bot  ("\<bottom>") and
-  top  ("\<top>") and
-  inf  (infixl "\<sqinter>" 70) and
-  sup  (infixl "\<squnion>" 65) and
-  Inf  ("\<Sqinter>_" [900] 900) and
-  Sup  ("\<Squnion>_" [900] 900)
-
-syntax
-  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
-  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
-  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
-  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
+unbundle lattice_syntax
 
 lemma Inf_comp_fun:
   "\<Sqinter>M \<circ> f = (\<Sqinter>m\<in>M. m \<circ> f)"
   by (simp add: fun_eq_iff image_comp)
 
 lemma INF_comp_fun:
   "(\<Sqinter>a\<in>A. g a) \<circ> f = (\<Sqinter>a\<in>A. g a \<circ> f)"
   by (simp add: fun_eq_iff image_comp)
 
 lemma Sup_comp_fun:
   "\<Squnion>M \<circ> f = (\<Squnion>m\<in>M. m \<circ> f)"
   by (simp add: fun_eq_iff image_comp)
 
 lemma SUP_comp_fun:
   "(\<Squnion>a\<in>A. g a) \<circ> f = (\<Squnion>a\<in>A. g a \<circ> f)"
   by (simp add: fun_eq_iff image_comp)
 
 lemma (in order) mono_const [simp]:
   "mono (\<lambda>_. c)"
   by (auto intro: monoI)
 
 lemma (in order) mono_id [simp]:
   "mono id"
   by (auto intro: order_class.monoI)
 
 lemma (in order) mono_comp [simp]:
   "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (f \<circ> g)"
   by (auto intro!: monoI elim!: monoE order_class.monoE)
 
 lemma (in bot) mono_bot [simp]:
   "mono \<bottom>"
   by (auto intro: monoI)
 
 lemma (in top) mono_top [simp]:
   "mono \<top>"
   by (auto intro: monoI)
 
 lemma (in semilattice_inf) mono_inf [simp]:
   assumes "mono f" and "mono g"
   shows "mono (f \<sqinter> g)"
 proof
   fix a b
   assume "a \<le> b"
   have "f a \<sqinter> g a \<le> f a" by simp
   also from \<open>mono f\<close> \<open>a \<le> b\<close> have "\<dots> \<le> f b" by (auto elim: monoE)
   finally have *: "f a \<sqinter> g a \<le> f b" .
   have "f a \<sqinter> g a \<le> g a" by simp
   also from \<open>mono g\<close> \<open>a \<le> b\<close> have "\<dots> \<le> g b" by (auto elim: monoE)
   finally have **: "f a \<sqinter> g a \<le> g b" .
   from * ** show "(f \<sqinter> g) a \<le> (f \<sqinter> g) b" by auto
 qed
 
 lemma (in semilattice_sup) mono_sup [simp]:
   assumes "mono f" and "mono g"
   shows "mono (f \<squnion> g)"
 proof
   fix a b
   assume "a \<le> b"
   from \<open>mono f\<close> \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
   also have "f b \<le> f b \<squnion> g b" by simp
   finally have *: "f a \<le> f b \<squnion> g b" .
   from \<open>mono g\<close> \<open>a \<le> b\<close> have "g a \<le> g b" by (auto elim: monoE)
   also have "g b \<le> f b \<squnion> g b" by simp
   finally have **: "g a \<le> f b \<squnion> g b" .
   from * ** show "(f \<squnion> g) a \<le> (f \<squnion> g) b" by auto
 qed
 
 lemma (in complete_lattice) mono_Inf [simp]:
   assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
   shows "mono (\<Sqinter>A)"
 proof
   fix a b
   assume "a \<le> b"
   { fix f
     assume "f \<in> A"
     with assms have "mono f" by auto
     with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
   }
   then have "(\<Sqinter>f\<in>A. f a) \<le> (\<Sqinter>f\<in>A. f b)"
     by (auto intro: complete_lattice_class.INF_greatest complete_lattice_class.INF_lower2)
   then show "(\<Sqinter>A) a \<le> (\<Sqinter>A) b" by simp
 qed
 
 lemma (in complete_lattice) mono_Sup [simp]:
   assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
   shows "mono (\<Squnion>A)"
 proof
   fix a b
   assume "a \<le> b"
   { fix f
     assume "f \<in> A"
     with assms have "mono f" by auto
     with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
   }
   then have "(\<Squnion>f\<in>A. f a) \<le> (\<Squnion>f\<in>A. f b)"
     by (auto intro: complete_lattice_class.SUP_least complete_lattice_class.SUP_upper2)
   then show "(\<Squnion>A) a \<le> (\<Squnion>A) b" by simp
 qed
 
 typedef (overloaded) 'a MonoTran = "{f::'a::order \<Rightarrow> 'a . mono f}"
 proof
   show "id \<in> ?MonoTran" by simp
 qed
 
 lemma [simp]:
   "mono (Rep_MonoTran f)"
   using Rep_MonoTran [of f] by simp
 
 setup_lifting type_definition_MonoTran
 
 instantiation MonoTran :: (order) order
 begin
 
 lift_definition less_eq_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
   is less_eq .
 
 lift_definition less_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
   is less .
 
 instance
   by intro_classes (transfer, auto intro: order_antisym)+
 
 end
 
 instantiation MonoTran :: (order) monoid_mult
 begin
 
 lift_definition one_MonoTran :: "'a MonoTran"
   is id
   by (fact mono_id)
 
 lift_definition times_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
   is comp
   by (fact mono_comp)
 
 instance
   by intro_classes (transfer, auto)+
 
 end
 
 instantiation MonoTran :: (order_bot) order_bot
 begin
 
 lift_definition bot_MonoTran :: "'a MonoTran"
   is \<bottom>
   by (fact mono_bot)
 
 instance
   by intro_classes (transfer, simp)
 
 end
 
 instantiation MonoTran :: (order_top) order_top
 begin
 
 lift_definition top_MonoTran :: "'a MonoTran"
   is \<top>
   by (fact mono_top)
 
 instance
   by intro_classes (transfer, simp)
 
 end
 
 instantiation MonoTran :: (lattice) lattice
 begin
 
 lift_definition inf_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
   is inf
   by (fact mono_inf)
 
 lift_definition sup_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
   is sup
   by (fact mono_sup)
 
 instance
   by intro_classes (transfer, simp)+
 
 end
 
 instance MonoTran :: (distrib_lattice) distrib_lattice
   by intro_classes (transfer, rule sup_inf_distrib1)
 
 instantiation MonoTran :: (complete_lattice) complete_lattice
 begin
 
 lift_definition Inf_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
   is Inf
   by (rule mono_Inf) auto
 
 lift_definition Sup_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
   is Sup
   by (rule mono_Sup) auto
 
 instance
   by intro_classes (transfer, simp add: Inf_lower Sup_upper Inf_greatest Sup_least)+
 
 end
 
 context includes lifting_syntax
 begin
 
 lemma [transfer_rule]:
   "(rel_set A ===> (A ===> pcr_MonoTran HOL.eq) ===> pcr_MonoTran HOL.eq) (\<lambda>A f. \<Sqinter>(f ` A)) (\<lambda>A f. \<Sqinter>(f ` A))"
   by transfer_prover
 
 lemma [transfer_rule]:
   "(rel_set A ===> (A ===> pcr_MonoTran HOL.eq) ===> pcr_MonoTran HOL.eq) (\<lambda>A f. \<Squnion>(f ` A)) (\<lambda>A f. \<Squnion>(f ` A))"
   by transfer_prover
 
 end
 
 instance MonoTran :: (complete_distrib_lattice) complete_distrib_lattice
 proof (intro_classes, transfer)
   fix A :: "('a \<Rightarrow> 'a) set set"
   assume " \<forall>A\<in>A. Ball A mono"
   from this have [simp]: "{f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {x. (\<exists>f. (\<forall>x. (\<forall>x\<in>x. mono x) \<longrightarrow> mono (f x)) \<and> x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> (\<forall>x\<in>x. mono x)}"
     apply safe
       apply (rule_tac x = "\<lambda> x . if x \<in> A then f x else \<bottom>" in exI)
       apply (simp add: if_split image_def)
     by blast+
 
   show " \<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {x. (\<exists>f\<in>Collect (pred_fun (\<lambda>A. Ball A mono) mono). x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> Ball x mono})"
     by (simp add: Inf_Sup)
 qed
 
 
 
 definition
   "dual_fun (f::'a::boolean_algebra \<Rightarrow> 'a) = uminus \<circ> f \<circ> uminus"
 
 lemma dual_fun_apply [simp]:
   "dual_fun f p = - f (- p)"
   by (simp add: dual_fun_def)
 
 lemma mono_dual_fun [simp]:
   "mono f \<Longrightarrow> mono (dual_fun f)"
   apply (rule monoI)
   apply (erule monoE)
   apply auto
   done
 
 lemma (in order) mono_inf_fun [simp]:
   fixes x :: "'b::semilattice_inf"
   shows "mono (inf x)"
   by (auto intro!: order_class.monoI semilattice_inf_class.inf_mono)
 
 lemma (in order) mono_sup_fun [simp]:
   fixes x :: "'b::semilattice_sup"
   shows "mono (sup x)"
   by (auto intro!: order_class.monoI semilattice_sup_class.sup_mono)
 
 lemma mono_comp_fun:
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   shows "mono f \<Longrightarrow> mono ((\<circ>) f)"
   by (rule monoI) (auto simp add: le_fun_def elim: monoE)
 
 definition
   "Omega_fun f g = inf g \<circ> comp f"
 
 lemma Omega_fun_apply [simp]:
   "Omega_fun f g h p = (g p \<sqinter> f (h p))"
   by (simp add: Omega_fun_def)
 
 lemma mono_Omega_fun [simp]:
   "mono f \<Longrightarrow> mono (Omega_fun f g)"
   unfolding Omega_fun_def
   by (auto intro: mono_comp mono_comp_fun)
 
 lemma mono_mono_Omega_fun [simp]:
   fixes f :: "'b::order \<Rightarrow> 'a::semilattice_inf" and g :: "'c::semilattice_inf \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> mono g \<Longrightarrow> mono_mono (Omega_fun f g)"
   apply (auto simp add: mono_mono_def Omega_fun_def)
   apply (rule mono_comp)
   apply (rule mono_inf_fun)
   apply (rule mono_comp_fun)
   apply assumption
   done
 
 definition 
   "omega_fun f = lfp (Omega_fun f id)"
 
 definition
   "star_fun f = gfp (Omega_fun f id)"
 
 lemma mono_omega_fun [simp]:
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   assumes "mono f"
   shows "mono (omega_fun f)"
 proof
   fix a b :: 'a
   assume "a \<le> b"
   from assms have "mono (lfp (Omega_fun f id))"
     by (auto intro: mono_mono_Omega_fun)
   with \<open>a \<le> b\<close> show "omega_fun f a \<le> omega_fun f b"
     by (auto simp add: omega_fun_def elim: monoE)
 qed
 
 lemma mono_star_fun [simp]:
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   assumes "mono f"
   shows "mono (star_fun f)"
 proof
   fix a b :: 'a
   assume "a \<le> b"
   from assms have "mono (gfp (Omega_fun f id))"
     by (auto intro: mono_mono_Omega_fun)
   with \<open>a \<le> b\<close> show "star_fun f a \<le> star_fun f b"
     by (auto simp add: star_fun_def elim: monoE)
 qed
 
 lemma lfp_omega_lowerbound:
   "mono f \<Longrightarrow> Omega_fun f g A \<le> A \<Longrightarrow> omega_fun f \<circ> g \<le> A"
   apply (simp add: omega_fun_def)
   apply (rule_tac P = "\<lambda> x . x \<circ> g \<le> A" and f = "Omega_fun f id" in lfp_ordinal_induct)
   apply simp_all
   apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
   apply auto
   apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
   apply simp_all
   apply (rule_tac y = "f (S (g x))" in order_trans)
   apply simp_all
   apply (simp add: mono_def) apply (auto simp add: ac_simps)
   apply (unfold Sup_comp_fun)
   apply (rule SUP_least)
   by auto
 
 lemma gfp_omega_upperbound:
   "mono f \<Longrightarrow> A \<le> Omega_fun f g A \<Longrightarrow> A \<le> star_fun f \<circ> g"
   apply (simp add: star_fun_def)
   apply (rule_tac P = "\<lambda> x . A \<le> x \<circ> g" and f = "Omega_fun f id" in gfp_ordinal_induct)
   apply simp_all
   apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
   apply auto
   apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
   apply simp_all
   apply (rule_tac y = "f (A x)" in order_trans)
   apply simp_all
   apply (simp add: mono_def)
   apply (unfold Inf_comp_fun)
   apply (rule INF_greatest)
   by auto
 
 lemma lfp_omega_greatest:
   assumes "\<And>u. Omega_fun f g u \<le> u \<Longrightarrow> A \<le> u"
   shows "A \<le> omega_fun f \<circ> g"
   apply (unfold omega_fun_def)
   apply (simp add: lfp_def)
   apply (unfold Inf_comp_fun)
   apply (rule INF_greatest)
   apply simp
   apply (rule assms)
   apply (simp add: le_fun_def)
   done
 
 lemma gfp_star_least:
   assumes "\<And>u. u \<le> Omega_fun f g u \<Longrightarrow> u \<le> A"
   shows "star_fun f \<circ> g \<le> A"
   apply (unfold star_fun_def)
   apply (simp add: gfp_def)
   apply (unfold Sup_comp_fun)
   apply (rule SUP_least)
   apply simp
   apply (rule assms)
   apply (simp add: le_fun_def)
   done
 
 lemma lfp_omega:
   "mono f \<Longrightarrow> omega_fun f \<circ> g = lfp (Omega_fun f g)"
   apply (rule antisym)
   apply (rule lfp_omega_lowerbound)
   apply simp_all
   apply (simp add: lfp_def)
   apply (rule Inf_greatest)
   apply safe
   apply (rule_tac y = "Omega_fun f g x" in order_trans)
   apply simp_all
   apply (rule_tac f = " Omega_fun f g" in monoD)
   apply simp_all
   apply (rule Inf_lower)
   apply simp
   apply (rule lfp_omega_greatest)
   apply (simp add: lfp_def)
   apply (rule Inf_lower)
   by simp
 
 lemma gfp_star:
   "mono f \<Longrightarrow> star_fun f \<circ> g = gfp (Omega_fun f g)"
   apply (rule antisym)
   apply (rule gfp_star_least)
   apply (simp add: gfp_def)
   apply (rule Sup_upper, simp)
   apply (rule gfp_omega_upperbound)
   apply simp_all
   apply (simp add: gfp_def)
   apply (rule Sup_least)
   apply safe
   apply (rule_tac y = "Omega_fun f g x" in order_trans)
   apply simp_all
   apply (rule_tac f = " Omega_fun f g" in monoD)
   apply simp_all
   apply (rule Sup_upper)
   by simp
 
 definition
   "assert_fun p q = (p \<sqinter> q :: 'a::semilattice_inf)"
 
 lemma mono_assert_fun [simp]:
   "mono (assert_fun p)"
   apply (simp add: assert_fun_def mono_def, safe)
   by (rule_tac y = x in order_trans, simp_all)
 
 lemma assert_fun_le_id [simp]: "assert_fun p \<le> id"
   by (simp add: assert_fun_def id_def le_fun_def)
 
 lemma assert_fun_disjunctive [simp]: "assert_fun (p::'a::distrib_lattice) \<in> Apply.disjunctive"
   by (simp add: assert_fun_def Apply.disjunctive_def inf_sup_distrib)
 
 definition
   "assertion_fun = range assert_fun"
   
 lemma assert_cont:
   "(x :: 'a::boolean_algebra \<Rightarrow> 'a)  \<le> id \<Longrightarrow> x \<in> Apply.disjunctive \<Longrightarrow> x = assert_fun (x \<top>)"
   apply (rule antisym)
   apply (simp_all add: le_fun_def assert_fun_def, safe)
   apply (rule_tac f = x in  monoD, simp_all)
   apply (subgoal_tac "x top = sup (x xa) (x (-xa))")
   apply simp
   apply (subst inf_sup_distrib)
   apply simp
   apply (rule_tac y = "inf (- xa) xa" in order_trans)
   supply [[simproc del: boolean_algebra_cancel_inf]]
   apply (simp del: compl_inf_bot)
   apply (rule_tac y = "x (- xa)" in order_trans)
   apply simp
   apply simp
   apply simp
   apply (cut_tac x = x and y = xa and z = "-xa" in Apply.disjunctiveD, simp)
   apply (subst (asm) sup_commute)
   apply (subst (asm) compl_sup_top)
   by simp
 
 lemma assertion_fun_disj_less_one: "assertion_fun = Apply.disjunctive \<inter> {x::'a::boolean_algebra \<Rightarrow> 'a . x \<le> id}"
   apply safe
   apply (simp_all add: assertion_fun_def, auto simp add: image_def)
   apply (rule_tac x = "x \<top>" in exI)
   by (rule assert_cont, simp_all)
 
 lemma assert_fun_dual: "((assert_fun p) o \<top>) \<sqinter> (dual_fun (assert_fun p)) = assert_fun p"
   by (simp add: fun_eq_iff inf_fun_def dual_fun_def o_def assert_fun_def top_fun_def inf_sup_distrib)
 
 lemma assertion_fun_dual: "x \<in> assertion_fun \<Longrightarrow> (x o \<top>) \<sqinter> (dual_fun x) = x"
   by (simp add: assertion_fun_def, safe, simp add: assert_fun_dual)
 
 lemma assertion_fun_MonoTran [simp]: "x \<in> assertion_fun \<Longrightarrow> mono x"
   by (unfold assertion_fun_def, auto)
 
 lemma assertion_fun_le_one [simp]: "x \<in> assertion_fun \<Longrightarrow> x \<le> id"
   by (unfold assertion_fun_def, auto)
 
 end
 
diff --git a/thys/MonoBoolTranAlgebra/Statements.thy b/thys/MonoBoolTranAlgebra/Statements.thy
--- a/thys/MonoBoolTranAlgebra/Statements.thy
+++ b/thys/MonoBoolTranAlgebra/Statements.thy
@@ -1,437 +1,425 @@
 section \<open>Program statements, Hoare and refinement rules\<close>
 
 theory Statements
 imports Assertion_Algebra
 begin
 
 text \<open>In this section we introduce assume, if, and while program statements
 as well as Hoare triples, and data refienment. We prove Hoare correctness
 rules for the program statements and we prove some theorems linking Hoare
 correctness statement to (data) refinement. Most of the theorems assume
 a monotonic boolean transformers algebra. The theorem stating the 
 equivalence between a Hoare
 correctness triple and a refinement statement holds under the
 assumption that we have a monotonic boolean transformers algebra with
 post condition statement.\<close>
 
 definition
   "assume" :: "'a::mbt_algebra Assertion \<Rightarrow> 'a"  ("[\<cdot> _ ]" [0] 1000) where
   "[\<cdot>p] =  {\<cdot>p} ^ o"
 
 lemma [simp]: "{\<cdot>p} * \<top> \<sqinter> [\<cdot>p] = {\<cdot>p}"
   apply (subgoal_tac "{\<cdot>p} \<in> assertion")
   apply (subst (asm) assertion_def, simp add: assume_def)
   by simp
 
 lemma [simp]: "[\<cdot>p] * x \<squnion> {\<cdot>-p} * \<top> = [\<cdot>p] * x"
   by (simp add: assume_def  uminus_Assertion_def)
 
 lemma [simp]: "{\<cdot>p} * \<top> \<squnion> [\<cdot>-p] * x = [\<cdot>-p] * x"
   by (simp add: assume_def  uminus_Assertion_def)
 
 lemma assert_sup: "{\<cdot>p \<squnion> q} = {\<cdot>p} \<squnion> {\<cdot>q}"
   by (simp add: sup_Assertion_def)
 
 lemma assert_inf: "{\<cdot>p \<sqinter> q} = {\<cdot>p} \<sqinter> {\<cdot>q}"
   by (simp add: inf_Assertion_def)
 
 lemma assert_neg: "{\<cdot>-p} = neg_assert {\<cdot>p}"
   by (simp add: uminus_Assertion_def)
 
 lemma assert_false [simp]: "{\<cdot>\<bottom>} = \<bottom>"
   by (simp add: bot_Assertion_def)
 
 lemma if_Assertion_assumption: "({\<cdot>p} * x) \<squnion> ({\<cdot>-p} * y) = ([\<cdot>p] * x) \<sqinter> ([\<cdot>-p] * y)"
 proof -
     have "({\<cdot>p} * x) \<squnion> {\<cdot>-p} * y = ({\<cdot>p} * \<top> \<sqinter> [\<cdot>p]) * x \<squnion> ({\<cdot>-p} * \<top> \<sqinter> [\<cdot>-p]) * y" by simp
     also have "\<dots> = ({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top> \<sqinter> ([\<cdot>-p] * y))" by (unfold inf_comp, simp)
     also have "\<dots> = (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (({\<cdot>p} * \<top> \<sqinter> ([\<cdot>p] * x)) \<squnion> ([\<cdot>-p] * y))" by (simp add: sup_inf_distrib)
     also have "\<dots> = (({\<cdot>p} * \<top>  \<squnion> ({\<cdot>-p} * \<top>)) \<sqinter> (([\<cdot>p] * x))) \<sqinter> (([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y)))"
       by (simp add: sup_inf_distrib2)
     also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y) \<sqinter> (([\<cdot>p] * x) \<squnion> ([\<cdot>-p] * y))"
       apply (simp add: sup_comp [THEN sym] )
       by (simp add: assert_sup [THEN sym] inf_assoc)
     also have "\<dots> = ([\<cdot>p] * x) \<sqinter>  ([\<cdot>-p] * y)"
       by (rule antisym, simp_all add: inf_assoc)
     finally show ?thesis .
   qed
 
 definition
   "wp x p = abs_wpt (x * {\<cdot>p})"
 
 lemma wp_assume: "wp [\<cdot>p] q = -p \<squnion> q"
   apply (simp add: wp_def abs_wpt_def)
   apply (rule assert_injective)
   apply simp
   by (simp add: assert_sup assert_neg assume_def wpt_dual_assertion_comp)
 
 lemma assert_commute: "y \<in> conjunctive \<Longrightarrow> y * {\<cdot>p} = {\<cdot> wp y p } * y"
   apply (simp add: wp_def abs_wpt_def)
   by (rule assertion_commute, simp_all)
 
 lemma wp_assert: "wp {\<cdot>p} q = p \<sqinter> q"
   by (simp add: wp_def assertion_inf_comp_eq [THEN sym] assert_inf [THEN sym])
 
 lemma wp_mono [simp]: "mono (wp x)"
   apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
   apply (simp add: wpt_def, safe)
   apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
   apply (rule le_comp_right)
   by (rule le_comp, simp)
 
 lemma wp_mono2: "p \<le> q \<Longrightarrow> wp x p \<le> wp x q"
   apply (cut_tac x = x in wp_mono)
   apply (unfold mono_def)
   by blast
 
 lemma wp_fun_mono [simp]: "mono wp"
   apply (simp add: le_fun_def wp_def abs_wpt_def less_eq_Assertion_def mono_def)
   apply (simp add: wpt_def, safe)
   apply (rule_tac y = " x * {\<cdot> xa } * \<top>" in order_trans, simp_all)
   apply (rule le_comp_right)
   by (rule le_comp_right, simp) 
 
 
 lemma wp_fun_mono2: "x \<le> y \<Longrightarrow> wp x p \<le> wp y p"
   apply (cut_tac wp_fun_mono)
   apply (unfold mono_def)
   apply (simp add: le_fun_def)
   by blast
 
 
 lemma wp_comp: "wp (x * y) p = wp x (wp y p)"
   apply (simp add: wp_def abs_wpt_def)
   by (unfold wpt_comp_2 [THEN sym] mult.assoc, simp)
 
 lemma wp_choice: "wp (x \<sqinter> y) = wp x \<sqinter> wp y"
   apply (simp add: fun_eq_iff wp_def inf_fun_def inf_comp inf_Assertion_def abs_wpt_def)
   by (simp add: wpt_choice)
 
 lemma [simp]: "wp 1 = id"
   apply (unfold fun_eq_iff, safe)
   apply (rule assert_injective)
   by (simp add: wp_def abs_wpt_def)
 
 lemma wp_omega_fix: "wp (x ^ \<omega>) p = wp x (wp (x ^ \<omega>) p) \<sqinter> p"
   apply (subst omega_fix)
   by (simp add: wp_choice wp_comp)
 
 lemma wp_omega_least: "(wp x r) \<sqinter> p \<le> r \<Longrightarrow> wp (x ^ \<omega>) p \<le> r"
   apply (simp add: wp_def abs_wpt_def inf_Assertion_def less_eq_Assertion_def)
   apply (simp add: wpt_def)
   apply (rule_tac y = "{\<cdot>r} * \<top> \<sqinter> 1" in order_trans)
   apply simp
   apply (rule_tac y = "x ^ \<omega> * {\<cdot> p } * \<top>" in order_trans, simp)
   apply (simp add: mult.assoc)
   apply (rule omega_least)
   apply (drule_tac z = \<top> in le_comp_right)
   apply (simp add: inf_comp mult.assoc [THEN sym])
   by (simp add: assertion_prop)
 
 lemma Assertion_wp: "{\<cdot>wp x p} = (x * {\<cdot>p} * \<top>) \<sqinter> 1"
   apply (simp add: wp_def abs_wpt_def)
   by (simp add: wpt_def)
 
 definition
   "hoare p S q = (p \<le> wp S q)"
 
 definition
   "grd x = - (wp x \<bottom>)"
 
 lemma grd_comp: "[\<cdot>grd x] * x = x"
   apply (simp add: grd_def wp_def uminus_Assertion_def assume_def neg_assert_def abs_wpt_def dual_sup sup_comp)
   apply (simp add: wpt_def dual_inf sup_comp dual_comp bot_Assertion_def)
   by (rule antisym, simp_all)
 
 lemma assert_assume: "{\<cdot>p} * [\<cdot>p] = {\<cdot> p}"
   by (simp add: assume_def)
 
 lemma dual_assume: "[\<cdot>p] ^ o = {\<cdot>p}"
   by (simp add: assume_def)
 
 lemma assume_prop: "([\<cdot>p] * \<bottom>) \<squnion> 1 = [\<cdot>p]"
   by (simp add: assume_def dual_assertion_prop)
 
 text\<open>An alternative definition of a Hoare triple\<close>
 
 definition "hoare1 p S q = ([\<cdot> p ] * S * [\<cdot> -q ] = \<top>)"
 
 lemma "hoare1  p S q = hoare p S q"
   apply (simp add: hoare1_def dual_inf dual_comp)
   apply (simp add: hoare_def wp_def less_eq_Assertion_def abs_wpt_def)
   apply (simp add: wpt_def)
   apply safe
   proof -
     assume A: "[\<cdot> p ] * S * [\<cdot> - q ] = \<top>"
     have "{\<cdot>p} \<le> {\<cdot>p} * \<top>" by simp
     also have "... \<le> {\<cdot>p} * \<top> * \<bottom>" by (unfold mult.assoc, simp)
     also have "... = {\<cdot>p} * [\<cdot> p ] * S * [\<cdot> - q ] * \<bottom>" by (subst A [THEN sym], simp add: mult.assoc)
     also have "... = {\<cdot>p} * S * [\<cdot> - q ] * \<bottom>" by (simp add: assert_assume)
     also have "... \<le> {\<cdot>p} * S * {\<cdot> q } * \<top>"
       apply (simp add: mult.assoc)
       apply (rule le_comp, rule le_comp)
       apply (simp add: assume_def uminus_Assertion_def)
       by (simp add: neg_assert_def dual_inf dual_comp sup_comp)
     also have "... \<le> S * {\<cdot> q } * \<top>" by (simp add: mult.assoc)
     finally show "{\<cdot>p} \<le> S * {\<cdot> q } * \<top>" .
   next
     assume A: "{\<cdot> p } \<le> S * {\<cdot> q } * \<top>"
     have "\<top> = ((S * {\<cdot>q}) ^ o) * \<bottom> \<squnion> S * {\<cdot>q} * \<top>" by simp
     also have "\<dots> \<le> [\<cdot>p] * \<bottom> \<squnion> S * {\<cdot>q} * \<top>"
       apply (simp del: dual_neg_top)
       apply (rule_tac y = "[\<cdot>p] * \<bottom>" in order_trans, simp_all)
       apply (subst dual_le)
       apply (simp add: dual_comp dual_assume)
       apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
       apply (rule A)
       by (simp add: mult.assoc)
     also have "\<dots> = [\<cdot>p] * S * ({\<cdot>q} * \<top>)"
       apply (subst (2) assume_prop [THEN sym])
       by (simp_all add: sup_comp mult.assoc)
     also have "\<dots> \<le> [\<cdot>p] * S * ({\<cdot>q} * \<top> \<squnion> 1)"
       by (rule le_comp, simp)
     also have "\<dots> = [\<cdot>p] * S * [\<cdot>-q]"
       apply (simp add: assume_def uminus_Assertion_def)
       by (simp add: neg_assert_def dual_inf dual_comp)
     finally show "[\<cdot>p] * S * [\<cdot> - q] = \<top>"
       by (rule_tac antisym, simp_all)
   qed
 
 lemma hoare_choice: "hoare p (x \<sqinter> y) q = ((hoare p) x q & (hoare p y q))"
   apply (unfold hoare_def wp_choice inf_fun_def)
   by auto
 
 definition
   if_stm:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(If (_)/ then (_)/ else (_))" [0, 0, 10] 10) where
   "if_stm b x y = (([\<cdot> b ] * x) \<sqinter> ([\<cdot> -b ] * y))"
 
 lemma if_assertion: "(If p then x else y) = {\<cdot>p} * x \<squnion> {\<cdot> -p} * y"
   by (simp add: if_stm_def if_Assertion_assumption)
 
 lemma hoare_if: "hoare p (If b then x else y) q = (hoare (p \<sqinter> b) x q \<and> hoare (p \<sqinter> -b) y q)"
   by (simp add: hoare_def if_stm_def wp_choice inf_fun_def wp_comp wp_assume sup_neg_inf)
 
 lemma hoare_comp: "hoare p (x * y) q = (\<exists> r . (hoare p x r) \<and> (hoare r y q))"
    apply (simp add: hoare_def wp_comp)
    apply safe
    apply (rule_tac x = "wp y q" in exI, simp)
    apply (rule_tac y = "wp x r" in order_trans, simp)
    apply (rule_tac f = "wp x" in monoD)
    by simp_all
 
 lemma hoare_refinement: "hoare p S q = ({\<cdot>p} * (post {\<cdot>q}) \<le> S)"
   apply (simp add: hoare_def less_eq_Assertion_def Assertion_wp)
   proof
     assume A: "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>"
     have "{\<cdot>p} * post {\<cdot>q} = ({\<cdot>p} * \<top> \<sqinter> 1) * post {\<cdot>q}" by (simp add: assertion_prop)
     also have "\<dots> = {\<cdot>p} * \<top> \<sqinter> post {\<cdot>q}" by (simp add: inf_comp)
     also have "\<dots> \<le> S * {\<cdot>q} * \<top> \<sqinter> post {\<cdot>q}" apply simp
       apply (rule_tac y = "{\<cdot>p} * \<top>" in order_trans, simp_all)
       apply (cut_tac x = "{\<cdot>p}" and y = "S * {\<cdot>q} * \<top>" and z = \<top> in le_comp_right)
       by (rule A, simp)
     also have "\<dots> \<le> S" by (simp add: post_2)
     finally show "{\<cdot>p} * post {\<cdot>q} \<le> S".
   next
     assume A: "{\<cdot>p} * post {\<cdot>q} \<le> S"
     have "{\<cdot>p} = {\<cdot>p} * \<top> \<sqinter> 1" by (simp add: assertion_prop)
     also have "\<dots> = {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>) \<sqinter> 1" by (simp add: post_1)
     also have "\<dots> \<le> {\<cdot>p} * ((post {\<cdot>q}) * {\<cdot>q} * \<top>)" by simp
     also have "\<dots> \<le> S * {\<cdot>q} * \<top>" 
       apply (cut_tac x = "{\<cdot>p} * post {\<cdot>q}" and y = S and z = "{\<cdot>q} * \<top>" in le_comp_right)
       apply (simp add: A)
       by (simp add: mult.assoc)
     finally show "{\<cdot>p} \<le> S * {\<cdot>q} * \<top>" .
   qed
 
  theorem hoare_fixpoint_mbt:
   "F x = x
      \<Longrightarrow> (!! (w::'a::well_founded) f . (\<And>v. v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q) 
      \<Longrightarrow> hoare (p u) x q"
   apply (rule less_induct1)
   proof -
     fix xa
     assume A: "\<And> w f. (\<And> v . v < w \<Longrightarrow> hoare (p v) f q) \<Longrightarrow> hoare (p w) (F f) q"
     assume B: "F x  = x"
     assume C: "\<And>y . y < xa \<Longrightarrow> hoare (p y) x q"
     have D: "hoare (p xa) (F x) q"
       apply (rule A)
       by (rule C, simp)
     show "hoare (p xa) x q"
       by (cut_tac D, simp add: B)
     qed
 
 lemma hoare_Sup: "hoare (Sup P) x q = (\<forall> p \<in> P . hoare p x q)" 
   apply (simp add: hoare_def)
   apply auto
   apply (rule_tac y = "Sup P" in order_trans, simp_all add: Sup_upper)
   apply (rule Sup_least)
   by simp
 
 theorem hoare_fixpoint_complete_mbt:
   "F x = x
      \<Longrightarrow> (!! w f . hoare (Sup_less p w) f q \<Longrightarrow> hoare (p w) (F f) q) 
      \<Longrightarrow> hoare (Sup (range p)) x q"
   apply (simp add: hoare_Sup Sup_less_def, safe)
   apply (rule_tac F = F in hoare_fixpoint_mbt)
   by auto
 
 definition
   while:: "'a::mbt_algebra Assertion \<Rightarrow> 'a \<Rightarrow> 'a" ("(While (_)/ do (_))" [0, 10] 10) where
   "while p x = ([\<cdot> p] * x) ^ \<omega> * [\<cdot> -p ]"
 
 lemma while_false: "(While \<bottom> do x) = 1"
   apply (unfold while_def)
   apply (subst omega_fix)
   by (simp_all add: assume_def)
 
 lemma while_true: "(While \<top> do 1) = \<bottom>"
   apply (unfold while_def)
   by (rule antisym, simp_all add: assume_def)
 
 lemma hoare_wp [simp]: "hoare (wp x q) x q"
   by (simp add: hoare_def)
 
 lemma hoare_comp_wp: "hoare p (x * y) q = hoare p x (wp y q)"
   apply (unfold hoare_comp, safe)
   apply (simp add: hoare_def)
   apply (rule_tac y = "wp x r" in order_trans, simp)
   apply (rule wp_mono2, simp)
   by (rule_tac x = "wp y q" in exI, simp)
 
 lemma (in mbt_algebra) hoare_assume: "hoare p [\<cdot>b] q = (p \<sqinter> b \<le> q)"
   by (simp add: hoare_def wp_assume sup_neg_inf)
 
 lemma (in mbt_algebra) hoare_assume_comp: "hoare p ([\<cdot>b] * x) q = hoare (p \<sqinter> b) x q"
   apply (simp add: hoare_comp_wp hoare_assume)
   by (simp add: hoare_def)
 
 lemma hoare_while_mbt:
   "(\<forall> (w::'b::well_founded) r . (\<forall> v . v < w \<longrightarrow> p v \<le> r) \<longrightarrow> hoare ((p w) \<sqinter> b) x r) \<Longrightarrow> 
        (\<forall> u . p u \<le> q) \<Longrightarrow> hoare  (p w) (While b do x) (q \<sqinter> -b)"
   apply (unfold while_def)
   apply (rule_tac F = "\<lambda>z. [\<cdot> b ] * x * z \<sqinter> [\<cdot> - b ]" in hoare_fixpoint_mbt)
   apply (simp add: mult.assoc [THEN sym])
   apply (simp add: omega_comp_fix)
   apply (unfold hoare_choice)
   apply safe
   apply (subst hoare_comp_wp)
   apply (subst hoare_assume_comp)
   apply (drule_tac x = w in spec)
   apply (drule_tac x = "wp f (q \<sqinter> - b)" in spec)
   apply (auto simp add: hoare_def) [1]
   apply (auto simp add: hoare_assume)
   apply (rule_tac y = "p w" in order_trans)
   by simp_all
 
 lemma hoare_while_complete_mbt:
   "(\<forall> w::'b::well_founded . hoare ((p w) \<sqinter> b) x (Sup_less p w)) \<Longrightarrow> 
        hoare  (Sup (range p)) (While b do x) ((Sup (range p)) \<sqinter> -b)"
   apply (simp add: hoare_Sup, safe)
   apply (rule hoare_while_mbt)
   apply safe
   apply (drule_tac x = w in spec)
   apply (simp add: hoare_def)
   apply (rule_tac y = "wp x (Sup_less p w)" in order_trans, simp_all)
   apply (rule wp_mono2)
   apply (simp add: Sup_less_def)
   apply (rule Sup_least, auto)
   by (rule SUP_upper, simp)
 
 definition 
   "datarefin S S1 D D1 = (D * S \<le> S1 * D1)"
 
 lemma "hoare p S q \<Longrightarrow> datarefin S S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
   apply (simp add: hoare_def datarefin_def)
   apply (simp add: wp_comp [THEN sym] mult.assoc [THEN sym])
   apply (rule_tac y = "wp (D * S) q" in order_trans)
   apply (subst wp_comp)
   apply (rule monoD, simp_all)
   by (rule wp_fun_mono2, simp_all)
 
 lemma "hoare p S q \<Longrightarrow> datarefin ({\<cdot>p} * S) S1 D D1 \<Longrightarrow> hoare (wp D p) S1 (wp D1 q)"
   apply (simp add: hoare_def datarefin_def)
   apply (rule_tac y = "wp (D * {\<cdot>p} * S) q" in order_trans)
   apply (simp add: mult.assoc)
   apply (subst wp_comp)
   apply (rule monoD, simp_all)
   apply (subst wp_comp)
   apply (unfold wp_assert, simp)
   apply (unfold wp_comp [THEN sym])
   apply (rule wp_fun_mono2)
   by (simp add: mult.assoc)
 
 lemma inf_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x \<sqinter> y \<in> conjunctive"
   apply (subst conjunctive_def, safe)
   apply (simp add: inf_comp conjunctiveD)
   by (metis (opaque_lifting, no_types) inf_assoc inf_left_commute)
 
 lemma sup_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x \<squnion> y \<in> disjunctive"
   apply (subst disjunctive_def, safe)
   apply (simp add: sup_comp disjunctiveD)
   by (metis (opaque_lifting, no_types) sup_assoc sup_left_commute)
 
 lemma assumption_conjuncive [simp]: "[\<cdot>p] \<in> conjunctive"
   by (simp add: assume_def dual_disjunctive assertion_disjunctive)
 
 lemma assumption_disjuncive [simp]: "[\<cdot>p] \<in> disjunctive"
   by (simp add: assume_def dual_conjunctive assertion_conjunctive)
 
 lemma if_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> (If p then x else y) \<in> conjunctive"
   apply (unfold if_stm_def)
   by (simp add: inf_pres_conj comp_pres_conj)
 
 lemma if_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> (If p then x else y) \<in> disjunctive"
   apply (unfold if_assertion)
   by (simp add: sup_pres_disj comp_pres_disj assertion_disjunctive)
 
 lemma while_dual_star: "(While p do (x::'a::mbt_algebra)) = (({\<cdot> p} * x)^\<otimes> * {\<cdot> -p })"
   apply (simp add: while_def)
   apply (rule antisym)
   apply (rule omega_least)
    proof -
      have "([\<cdot> p] * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}) \<sqinter> [\<cdot>-p]) = ({\<cdot> p} * x * (({\<cdot> p} * x)^\<otimes> * {\<cdot>-p})) \<squnion> {\<cdot>-p}"
         apply (unfold mult.assoc)
         by (cut_tac p = p and x = "(x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> -p }))" and y = 1 in if_Assertion_assumption, simp)
      also have "\<dots> = ({\<cdot> p} * x)^\<otimes> * {\<cdot>-p}"
         by (simp add: mult.assoc [THEN sym], simp add: dual_star_comp_fix [THEN sym])
      finally show "[\<cdot> p ] * x * (({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }) \<sqinter> [\<cdot> - p ] \<le> ({\<cdot> p } * x)^\<otimes> * {\<cdot> - p }" by simp
    next
      show "({\<cdot> p } * x)^\<otimes> * {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
        apply (rule dual_star_least)
        proof -
         have "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } = [\<cdot> p ] * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<sqinter> [\<cdot> - p ]"
         apply (unfold mult.assoc)
         by (cut_tac p = p and x = "(x * (([\<cdot>p] * x)^\<omega> * [\<cdot>-p]))" and y = 1 in if_Assertion_assumption, simp)
         also have "... = ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]"
           apply (simp add: mult.assoc [THEN sym])
           by (metis omega_comp_fix)
         finally show "{\<cdot> p } * x * (([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ]) \<squnion> {\<cdot> - p } \<le> ([\<cdot> p ] * x) ^ \<omega> * [\<cdot> - p ] " by simp
      qed
    qed
 
 lemma while_pres_disj: "(x::'a::mbt_algebra) \<in> disjunctive \<Longrightarrow> (While p do x) \<in> disjunctive"
   apply (unfold while_dual_star)
   apply (rule comp_pres_disj)
   apply (rule dual_star_pres_disj)
   by (rule comp_pres_disj, simp_all add: assertion_disjunctive)
 
 lemma while_pres_conj: "(x::'a::mbt_algebra_fusion) \<in> conjunctive \<Longrightarrow> (While p do x) \<in> conjunctive"
   apply(unfold while_def)
   by (simp add: comp_pres_conj omega_pres_conj)
 
-no_notation
-  bot  ("\<bottom>") and
-  top  ("\<top>") and
-  inf  (infixl "\<sqinter>" 70) and
-  sup  (infixl "\<squnion>" 65) and
-  Inf  ("\<Sqinter>_" [900] 900) and
-  Sup  ("\<Squnion>_" [900] 900)
-
-no_syntax
-  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
-  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
-  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
-  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
+unbundle no_lattice_syntax
 
 end
 
diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
--- a/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
+++ b/thys/Order_Lattice_Props/Order_Lattice_Props_Loc.thy
@@ -1,575 +1,575 @@
 (* 
   Title: Locale-Based Duality
   Author: Georg Struth 
   Maintainer:Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Locale-Based Duality\<close>
 
 theory Order_Lattice_Props_Loc
   imports Main 
-          "HOL-Library.Lattice_Syntax"
+begin
 
-begin
+unbundle lattice_syntax
 
 text \<open>This section explores order and lattice duality based on locales. Used within the context of a class or locale, 
 this is very effective, though more opaque than the previous approach. Outside of such a context, however, it apparently
 cannot be used for dualising theorems. Examples are properties of  functions between orderings or lattices.\<close>
 
 definition Fix :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set" where 
   "Fix f = {x. f x = x}"
 
 context ord
 begin
 
 definition min_set :: "'a set \<Rightarrow> 'a set" where 
  "min_set X = {y \<in> X. \<forall>x \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 definition max_set :: "'a set \<Rightarrow> 'a set" where 
  "max_set X = {x \<in> X. \<forall>y \<in> X. x \<le> y \<longrightarrow> x = y}"
 
 definition directed :: "'a set \<Rightarrow> bool" where
  "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"
 
 definition filtered :: "'a set \<Rightarrow> bool" where
  "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"
 
 definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
   "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"
 
 definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
  "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"
 
 definition downset :: "'a \<Rightarrow> 'a set" ("\<down>") where 
   "\<down> = \<Down> \<circ> (\<lambda>x. {x})"
 
 definition upset :: "'a \<Rightarrow> 'a set" ("\<up>") where 
   "\<up> = \<Up> \<circ> (\<lambda>x. {x})"
 
 definition downsets :: "'a set set" where  
   "downsets = Fix \<Down>"
  
 definition upsets :: "'a set set" where
   "upsets = Fix \<Up>"
 
 abbreviation "downset_setp X \<equiv> X \<in> downsets"
 
 abbreviation "upset_setp X \<equiv> X \<in> upsets"
 
 definition ideals :: "'a set set" where
   "ideals = {X. X \<noteq> {} \<and> downset_setp X \<and> directed X}"
 
 definition filters :: "'a  set set" where
   "filters = {X. X \<noteq> {} \<and> upset_setp X \<and> filtered X}"
 
 abbreviation "idealp X \<equiv> X \<in> ideals"
 
 abbreviation "filterp X \<equiv> X \<in> filters"
 
 end
 
 abbreviation Sup_pres :: "('a::Sup \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Sup_pres f \<equiv> f \<circ> Sup = Sup \<circ> (`) f"
 
 abbreviation Inf_pres :: "('a::Inf \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Inf_pres f \<equiv> f \<circ> Inf = Inf \<circ> (`) f"
 
 abbreviation sup_pres :: "('a::sup \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
   "sup_pres f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<squnion> f y)"
 
 abbreviation inf_pres :: "('a::inf \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
  "inf_pres f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<sqinter> f y)"
 
 abbreviation bot_pres :: "('a::bot \<Rightarrow> 'b::bot) \<Rightarrow> bool" where
   "bot_pres f \<equiv> f \<bottom> = \<bottom>"
 
 abbreviation top_pres :: "('a::top \<Rightarrow> 'b::top) \<Rightarrow> bool" where
   "top_pres f \<equiv> f \<top> = \<top>"
 
 abbreviation Sup_dual :: "('a::Sup \<Rightarrow> 'b::Inf) \<Rightarrow> bool" where
   "Sup_dual f \<equiv> f \<circ> Sup = Inf \<circ> (`) f"
 
 abbreviation Inf_dual :: "('a::Inf \<Rightarrow> 'b::Sup) \<Rightarrow> bool" where
   "Inf_dual f \<equiv> f \<circ> Inf = Sup \<circ> (`) f"
 
 abbreviation sup_dual :: "('a::sup \<Rightarrow> 'b::inf) \<Rightarrow> bool" where
   "sup_dual f \<equiv> (\<forall>x y. f (x \<squnion> y) = f x \<sqinter> f y)"
 
 abbreviation inf_dual :: "('a::inf \<Rightarrow> 'b::sup) \<Rightarrow> bool" where
  "inf_dual f \<equiv> (\<forall>x y. f (x \<sqinter> y) = f x \<squnion> f y)"
 
 abbreviation bot_dual :: "('a::bot \<Rightarrow> 'b::top) \<Rightarrow> bool" where 
  "bot_dual f \<equiv> f \<bottom> = \<top>"
 
 abbreviation top_dual :: "('a::top \<Rightarrow> 'b::bot) \<Rightarrow> bool" where 
   "top_dual f \<equiv> f \<top> = \<bottom>"
 
 
 subsection \<open>Duality via Locales\<close>
 
 sublocale ord \<subseteq> dual_ord: ord "(\<ge>)" "(>)"
   rewrites dual_max_set: "max_set = dual_ord.min_set"
   and dual_filtered: "filtered = dual_ord.directed"
   and dual_upset_set: "upset_set = dual_ord.downset_set"
   and dual_upset: "upset = dual_ord.downset"
   and dual_upsets: "upsets = dual_ord.downsets"
   and dual_filters: "filters = dual_ord.ideals"
        apply unfold_locales
   unfolding max_set_def ord.min_set_def fun_eq_iff apply blast
   unfolding filtered_def ord.directed_def apply simp 
   unfolding upset_set_def ord.downset_set_def apply simp
   apply (simp add: ord.downset_def ord.downset_set_def ord.upset_def ord.upset_set_def)
   unfolding upsets_def ord.downsets_def apply (metis ord.downset_set_def upset_set_def)
   unfolding filters_def ord.ideals_def Fix_def ord.downsets_def upsets_def ord.downset_set_def upset_set_def ord.directed_def filtered_def
   by simp
 
 sublocale preorder \<subseteq> dual_preorder: preorder "(\<ge>)" "(>)"
   apply unfold_locales
   apply (simp add: less_le_not_le)
   apply simp
   using order_trans by blast
 
 sublocale order \<subseteq> dual_order: order "(\<ge>)" "(>)"
   by (unfold_locales, simp)
 
 sublocale lattice \<subseteq> dual_lattice: lattice sup "(\<ge>)" "(>)" inf
   by (unfold_locales, simp_all)
 
 sublocale bounded_lattice \<subseteq> dual_bounded_lattice: bounded_lattice sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   by (unfold_locales, simp_all)
 
 sublocale boolean_algebra \<subseteq> dual_boolean_algebra: boolean_algebra "\<lambda>x y. x \<squnion> -y" uminus sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   by (unfold_locales, simp_all add: inf_sup_distrib1)
 
 sublocale complete_lattice \<subseteq> dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>
   rewrites dual_gfp: "gfp = dual_complete_lattice.lfp"  
 proof-
   show "class.complete_lattice Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
     by (unfold_locales, simp_all add: Sup_upper Sup_least Inf_lower Inf_greatest)
   then interpret dual_complete_lattice: complete_lattice Sup Inf sup "(\<ge>)" "(>)" inf \<top> \<bottom>.
   show "gfp = dual_complete_lattice.lfp"  
     unfolding gfp_def dual_complete_lattice.lfp_def fun_eq_iff by simp
 qed
 
 context ord
 begin
 
 lemma dual_min_set: "min_set = dual_ord.max_set"
   by (simp add: dual_ord.dual_max_set)
 
 lemma dual_directed: "directed = dual_ord.filtered"
   by (simp add:dual_ord.dual_filtered)
 
 lemma dual_downset: "downset = dual_ord.upset"
   by (simp add: dual_ord.dual_upset)
 
 lemma dual_downset_set: "downset_set = dual_ord.upset_set"
   by (simp add: dual_ord.dual_upset_set)
 
 lemma dual_downsets: "downsets = dual_ord.upsets"
   by (simp add: dual_ord.dual_upsets)
 
 lemma dual_ideals: "ideals = dual_ord.filters"
   by (simp add: dual_ord.dual_filters)
 
 end
 
 context complete_lattice
 begin
 
 lemma dual_lfp: "lfp = dual_complete_lattice.gfp"
   by (simp add: dual_complete_lattice.dual_gfp)
 
 end
 
 subsection \<open>Properties of Orderings, Again\<close>
 
 context ord
 begin
 
 lemma directed_nonempty: "directed X \<Longrightarrow> X \<noteq> {}"
   unfolding directed_def by fastforce
 
 lemma directed_ub: "directed X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z)"
   by (meson empty_subsetI directed_def finite.emptyI finite_insert insert_subset order_refl)
 
 lemma downset_set_prop: "\<Down> = Union \<circ> (`) \<down>"
   unfolding downset_set_def downset_def fun_eq_iff by fastforce
 
 lemma downset_set_prop_var: "\<Down>X = (\<Union>x \<in> X. \<down>x)"
   by (simp add: downset_set_prop)
 
 lemma downset_prop: "\<down>x = {y. y \<le> x}"
   unfolding downset_def downset_set_def fun_eq_iff comp_def by fastforce
 
 end
 
 context preorder
 begin
 
 lemma directed_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z) \<Longrightarrow> directed X"
 proof-
   assume h1: "X \<noteq> {}"
   and h2: "\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z"
   {fix Y
   have "finite Y \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x)"
   proof (induct rule: finite_induct)
     case empty
     then show ?case
       using h1 by blast 
   next
     case (insert x F)
     then show ?case
       by (metis h2 insert_iff insert_subset order_trans) 
   qed}
   thus ?thesis
     by (simp add: directed_def)
 qed
 
 lemma directed_alt: "directed X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. x \<le> z \<and> y \<le> z))"
   by (metis directed_prop directed_nonempty directed_ub)
 
 lemma downset_set_ext: "id \<le> \<Down>"
   unfolding le_fun_def id_def downset_set_def by auto 
 
 lemma downset_set_iso: "mono \<Down>"
   unfolding mono_def downset_set_def by blast
 
 lemma downset_set_idem [simp]: "\<Down> \<circ> \<Down> = \<Down>"
   unfolding fun_eq_iff downset_set_def comp_def using order_trans by auto
 
 lemma downset_faithful: "\<down>x \<subseteq> \<down>y \<Longrightarrow> x \<le> y"
   by (simp add: downset_prop subset_eq)
 
 lemma downset_iso_iff: "(\<down>x \<subseteq> \<down>y) = (x \<le> y)"
   using atMost_iff downset_prop order_trans by blast
 
 lemma downset_directed_downset_var [simp]: "directed (\<Down>X) = directed X"
 proof
   assume h1: "directed X"
   {fix Y
   assume h2: "finite Y" and h3: "Y \<subseteq> \<Down>X"
   hence "\<forall>y. \<exists>x. y \<in> Y \<longrightarrow> x \<in> X \<and>  y \<le> x"
     by (force simp: downset_set_def)
   hence "\<exists>f. \<forall>y. y \<in> Y \<longrightarrow>  f y \<in> X \<and> y \<le> f y"
     by (rule choice)
   hence "\<exists>f. finite (f ` Y) \<and> f ` Y \<subseteq> X \<and> (\<forall>y \<in> Y. y \<le> f y)"
     by (metis finite_imageI h2 image_subsetI)
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z)"
     by fastforce
   hence "\<exists>Z. finite Z \<and> Z \<subseteq> X \<and> (\<forall>y \<in> Y. \<exists> z \<in> Z. y \<le> z) \<and> (\<exists>x \<in> X. \<forall> z \<in> Z. z \<le> x)"
     by (metis directed_def h1)
   hence "\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x"
     by (meson order_trans)}
   thus "directed (\<Down>X)"
     unfolding directed_def downset_set_def by fastforce
 next 
   assume "directed (\<Down>X)"
   thus "directed X"
     unfolding directed_def downset_set_def 
     apply clarsimp
     by (smt Ball_Collect order_refl order_trans subsetCE)
 qed
 
 lemma downset_directed_downset [simp]: "directed \<circ> \<Down> = directed"
   unfolding fun_eq_iff comp_def by simp
 
 lemma directed_downset_ideals: "directed (\<Down>X) = (\<Down>X \<in> ideals)"
   by (metis (mono_tags, lifting) Fix_def comp_apply directed_alt downset_set_idem downsets_def ideals_def mem_Collect_eq)
 
 end
 
 lemma downset_iso: "mono (\<down>::'a::order \<Rightarrow> 'a set)"
   by (simp add: downset_iso_iff mono_def)
 
 context order
 begin
 
 lemma downset_inj: "inj \<down>"
   by (metis injI downset_iso_iff order.eq_iff)
 
 end
 
 context lattice
 begin
 
 lemma lat_ideals: "X \<in> ideals = (X \<noteq> {} \<and> X \<in> downsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<squnion> y \<in> X))"
   unfolding ideals_def directed_alt downsets_def Fix_def downset_set_def 
   by (clarsimp, smt sup.cobounded1 sup.orderE sup.orderI sup_absorb2 sup_left_commute mem_Collect_eq)
 
 end
 
 context bounded_lattice
 begin
 
 lemma bot_ideal: "X \<in> ideals \<Longrightarrow> \<bottom> \<in> X"
   unfolding ideals_def downsets_def Fix_def downset_set_def by fastforce
 
 end
 
 context complete_lattice
 begin
 
 lemma Sup_downset_id [simp]: "Sup \<circ> \<down> = id"
   using Sup_atMost atMost_def downset_prop by fastforce
 
 lemma downset_Sup_id: "id \<le> \<down> \<circ> Sup"
   by (simp add: Sup_upper downset_prop le_funI subsetI)
 
 lemma Inf_Sup_var: "\<Squnion>(\<Inter>x \<in> X. \<down>x) = \<Sqinter>X"
   unfolding downset_prop by (simp add: Collect_ball_eq Inf_eq_Sup)
 
 lemma Inf_pres_downset_var: "(\<Inter>x \<in> X. \<down>x) = \<down>(\<Sqinter>X)"
   unfolding downset_prop by (safe, simp_all add: le_Inf_iff)
 
 end
 
 lemma lfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> lfp f \<in> Fix f"
   using Fix_def lfp_unfold by fastforce
 
 lemma gfp_in_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> gfp f \<in> Fix f"
   using Fix_def gfp_unfold by fastforce
 
 lemma nonempty_Fix: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
   shows "mono f \<Longrightarrow> Fix f \<noteq> {}"
   using lfp_in_Fix by fastforce
 
 
 subsection \<open>Dual Properties of Orderings from Locales\<close>
 
 text \<open>These properties can be proved very smoothly overall. But only within the context of a class
 or locale!\<close>
 
 context ord
 begin
 
 lemma filtered_nonempty: "filtered X \<Longrightarrow> X \<noteq> {}"
   by (simp add: dual_filtered dual_ord.directed_nonempty)
 
 lemma filtered_lb: "filtered X \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y)"
   by (simp add: dual_filtered dual_ord.directed_ub)
 
 lemma upset_set_prop: "\<Up> = Union \<circ> (`) \<up>"
   by (simp add: dual_ord.downset_set_prop dual_upset dual_upset_set)
 
 lemma upset_set_prop_var: "\<Up>X = (\<Union>x \<in> X. \<up>x)"
   by (simp add: dual_ord.downset_set_prop_var dual_upset dual_upset_set)
 
 lemma upset_prop: "\<up>x = {y. x \<le> y}"
   by (simp add: dual_ord.downset_prop dual_upset)
 
 end
 
 context preorder
 begin
 
 lemma filtered_prop: "X \<noteq> {} \<Longrightarrow> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y) \<Longrightarrow> filtered X"
   by (simp add: dual_filtered dual_preorder.directed_prop)
 
 lemma filtered_alt: "filtered X = (X \<noteq> {} \<and> (\<forall>x \<in> X. \<forall>y \<in> X. \<exists>z \<in> X. z \<le> x \<and> z \<le> y))"
   by (simp add: dual_filtered dual_preorder.directed_alt)
 
 lemma upset_set_ext: "id \<le> \<Up>"
   by (simp add: dual_preorder.downset_set_ext dual_upset_set)
 
 lemma upset_set_anti: "mono \<Up>"
   by (simp add: dual_preorder.downset_set_iso dual_upset_set) 
 
 lemma up_set_idem [simp]: "\<Up> \<circ> \<Up> = \<Up>"
   by (simp add: dual_upset_set)
 
 lemma upset_faithful: "\<up>x \<subseteq> \<up>y \<Longrightarrow> y \<le> x"
   by (metis dual_preorder.downset_faithful dual_upset)
 
 lemma upset_anti_iff: "(\<up>y \<subseteq> \<up>x) = (x \<le> y)"
   by (simp add: dual_preorder.downset_iso_iff dual_upset)
 
 lemma upset_filtered_upset [simp]: "filtered \<circ> \<Up> = filtered"
   by (simp add: dual_filtered dual_upset_set)
 
 lemma filtered_upset_filters: "filtered (\<Up>X) = (\<Up>X \<in> filters)"
   using dual_filtered dual_preorder.directed_downset_ideals dual_upset_set ord.dual_filters by fastforce
 
 end
 
 context order
 begin
 
 lemma upset_inj: "inj \<up>"
   by (simp add: dual_order.downset_inj dual_upset)
 
 end
 
 context lattice
 begin
 
 lemma lat_filters: "X \<in> filters = (X \<noteq> {} \<and> X \<in> upsets \<and> (\<forall>x \<in> X. \<forall> y \<in> X. x \<sqinter> y \<in> X))"
   by (simp add: dual_filters dual_lattice.lat_ideals dual_ord.downsets_def dual_upset_set upsets_def)
 
 end
 
 context bounded_lattice
 begin
 
 lemma top_filter: "X \<in> filters \<Longrightarrow> \<top> \<in> X"
   by (simp add: dual_bounded_lattice.bot_ideal dual_filters)
 
 end
 
 context complete_lattice
 begin
 
 lemma Inf_upset_id [simp]: "Inf \<circ> \<up> = id"
   by (simp add:  dual_upset)
 
 lemma upset_Inf_id: "id \<le> \<up> \<circ> Inf"
   by (simp add: dual_complete_lattice.downset_Sup_id dual_upset)
 
 lemma Sup_Inf_var: " \<Sqinter>(\<Inter>x \<in> X. \<up>x) = \<Squnion>X"
   by (simp add: dual_complete_lattice.Inf_Sup_var dual_upset)
 
 lemma Sup_dual_upset_var: "(\<Inter>x \<in> X. \<up>x) = \<up>(\<Squnion>X)"
   by (simp add: dual_complete_lattice.Inf_pres_downset_var dual_upset)
 
 end
 
 subsection \<open>Examples that Do Not Dualise\<close>
 
 lemma upset_anti: "antimono (\<up>::'a::order \<Rightarrow> 'a set)"
   by (simp add: antimono_def upset_anti_iff)
 
 context complete_lattice 
 begin
 
 lemma fSup_unfold: "(f::nat \<Rightarrow> 'a) 0 \<squnion> (\<Squnion>n. f (Suc n)) = (\<Squnion>n. f n)"
   apply (intro order.antisym sup_least)
     apply (rule Sup_upper, force)
    apply (rule Sup_mono, force)
   apply (safe intro!: Sup_least)
  by (case_tac n, simp_all add: Sup_upper le_supI2)
 
 
 lemma fInf_unfold: "(f::nat \<Rightarrow> 'a) 0 \<sqinter> (\<Sqinter>n. f (Suc n)) = (\<Sqinter>n. f n)"
   apply (intro order.antisym inf_greatest)
   apply (rule Inf_greatest, safe)
   apply (case_tac n)
    apply simp_all
   using Inf_lower inf.coboundedI2 apply force
    apply (simp add: Inf_lower)
   by (auto intro: Inf_mono)
 
 end
 
 lemma fun_isol: "mono f \<Longrightarrow> mono ((\<circ>) f)"
   by (simp add: le_fun_def mono_def)
 
 lemma fun_isor: "mono f \<Longrightarrow> mono (\<lambda>x. x \<circ> f)"
   by (simp add: le_fun_def mono_def)
 
 lemma Sup_sup_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> sup_pres f"
   by (metis (no_types, opaque_lifting) Sup_empty Sup_insert comp_apply image_insert sup_bot.right_neutral)
 
 lemma Inf_inf_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows"Inf_pres f \<Longrightarrow> inf_pres f"
   by (smt INF_insert comp_eq_elim dual_complete_lattice.Sup_empty dual_complete_lattice.Sup_insert inf_top.right_neutral)
 
 lemma Sup_bot_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Sup_pres f \<Longrightarrow> bot_pres f"
   by (metis SUP_empty Sup_empty comp_eq_elim)
 
 lemma Inf_top_pres: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "Inf_pres f \<Longrightarrow> top_pres f"
   by (metis INF_empty comp_eq_elim dual_complete_lattice.Sup_empty)
 
 context complete_lattice
 begin
 
 lemma iso_Inf_subdistl: 
   assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
   shows "f \<circ> Inf \<le> Inf \<circ> (`) f"
   by (simp add: assms complete_lattice_class.le_Inf_iff le_funI Inf_lower monoD)
 
 lemma iso_Sup_supdistl: 
   assumes "mono (f::'a \<Rightarrow> 'b::complete_lattice)"
   shows "Sup \<circ> (`) f \<le> f \<circ> Sup"
   by (simp add: assms complete_lattice_class.SUP_le_iff le_funI dual_complete_lattice.Inf_lower monoD)
 
 lemma Inf_subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "f \<circ> Inf \<le> Inf \<circ> (`) f \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.le_INF_iff Inf_atLeast atLeast_iff)
 
 lemma Sup_supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "Sup \<circ> (`) f \<le> f \<circ> Sup \<Longrightarrow> mono f"
   unfolding mono_def le_fun_def comp_def by (metis complete_lattice_class.SUP_le_iff Sup_atMost atMost_iff)
 
 lemma supdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(Sup \<circ> (`) f \<le> f \<circ> Sup) = mono f"
   using Sup_supdistl_iso iso_Sup_supdistl by force
 
 lemma subdistl_iso: 
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   shows "(f \<circ> Inf \<le> Inf \<circ> (`) f) = mono f"
   using Inf_subdistl_iso iso_Inf_subdistl by force
 
 end
 
 lemma fSup_distr: "Sup_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff comp_def
   by (smt Inf.INF_cong SUP_apply Sup_apply)
 
 lemma fSup_distr_var: "\<Squnion>F \<circ> g = (\<Squnion>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff comp_def
   by (smt Inf.INF_cong SUP_apply Sup_apply)
 
 lemma fInf_distr: "Inf_pres (\<lambda>x. x \<circ> f)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply Inf.INF_cong Inf_apply)
 
 lemma fInf_distr_var: "\<Sqinter>F \<circ> g = (\<Sqinter>f \<in> F. f \<circ> g)"
   unfolding fun_eq_iff comp_def
   by (smt INF_apply Inf.INF_cong Inf_apply)
 
 lemma fSup_subdistl: 
   assumes "mono (f::'a::complete_lattice \<Rightarrow> 'b::complete_lattice)"
   shows "Sup \<circ> (`) ((\<circ>) f) \<le> (\<circ>) f \<circ> Sup"
   using assms by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)
 
 lemma fSup_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<Squnion>g \<in> G. f \<circ> g) \<le> f \<circ> \<Squnion>G"
   by (simp add: SUP_least Sup_upper le_fun_def monoD image_comp)
 
 lemma fInf_subdistl: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows  "mono f \<Longrightarrow> (\<circ>) f \<circ> Inf \<le> Inf \<circ> (`) ((\<circ>) f)"
   by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)
 
 lemma fInf_subdistl_var: 
   fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
   shows "mono f \<Longrightarrow> f \<circ> \<Sqinter>G \<le> (\<Sqinter>g \<in> G. f \<circ> g)"
   by (simp add: INF_greatest Inf_lower le_fun_def monoD image_comp)
 
 lemma Inf_pres_downset: "Inf_pres (\<down>::'a::complete_lattice \<Rightarrow> 'a set)"
   unfolding downset_prop fun_eq_iff comp_def
   by (safe, simp_all add: le_Inf_iff)
  
 lemma Sup_dual_upset: "Sup_dual (\<up>::'a::complete_lattice \<Rightarrow> 'a set)"
   unfolding upset_prop fun_eq_iff comp_def
   by (safe, simp_all add: Sup_le_iff)
 
 text \<open>This approach could probably be combined with the explicit functor-based one. This may be good for proofs, but seems conceptually rather ugly.\<close>
 
 end
\ No newline at end of file
diff --git a/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy b/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
--- a/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
+++ b/thys/Order_Lattice_Props/Order_Lattice_Props_Wenzel.thy
@@ -1,280 +1,280 @@
 (* 
   Title: Duality Based on a Data Type
   Author: Georg Struth 
   Maintainer:Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Duality Based on a Data Type\<close>
 
 theory Order_Lattice_Props_Wenzel
   imports Main 
-          "HOL-Library.Lattice_Syntax"
+begin
 
-begin
+unbundle lattice_syntax
 
 subsection \<open>Wenzel's Approach Revisited\<close>
 
 text \<open>This approach is similar to, but inferior to the explicit class-based one. The main caveat is that duality is not involutive 
 with this approach, and this allows dualising less theorems.\<close>
 
 text \<open>I copy Wenzel's development \cite{Wenzel} in this subsection and extend it with additional properties. I show only the most important properties.\<close>
 
 datatype 'a dual = dual (un_dual: 'a) ("\<partial>")
 
 notation un_dual ("\<partial>\<^sup>-")
 
 lemma dual_inj: "inj \<partial>"
   using injI by fastforce
 
 lemma dual_surj: "surj \<partial>"
   using dual.exhaust_sel by blast
 
 lemma dual_bij: "bij \<partial>"
   by (simp add: bijI dual_inj dual_surj)
 
 text \<open>Dual is not idempotent, and I see no way of imposing this condition. Yet at least an inverse exists --- namely un-dual..\<close>
 
 lemma dual_inv1 [simp]: "\<partial>\<^sup>- \<circ> \<partial> = id"
   by fastforce
 
 lemma dual_inv2 [simp]: "\<partial> \<circ> \<partial>\<^sup>- = id"
   by fastforce
 
 lemma dual_inv_inj: "inj \<partial>\<^sup>-"
   by (simp add: dual.expand injI)
 
 lemma dual_inv_surj: "surj \<partial>\<^sup>-"
   by (metis dual.sel surj_def)
 
 lemma dual_inv_bij: "bij \<partial>\<^sup>-"
   by (simp add: bij_def dual_inv_inj dual_inv_surj)
 
 lemma dual_iff: "(\<partial> x = y) \<longleftrightarrow> (x = \<partial>\<^sup>- y)"
   by fastforce
 
 text \<open>Isabelle data types come with a number of generic functions.\<close>
 
 text \<open>The functor map-dual lifts functions to dual types. Isabelle's generic definition is not straightforward to 
 understand and use. Yet conceptually it can be explained as follows.\<close>
 
 lemma map_dual_def_var [simp]: "(map_dual::('a \<Rightarrow> 'b) \<Rightarrow> 'a dual \<Rightarrow> 'b dual) f = \<partial> \<circ> f \<circ> \<partial>\<^sup>-"  
   unfolding fun_eq_iff comp_def by (metis dual.map_sel dual_iff)
 
 lemma map_dual_def_var2: "\<partial>\<^sup>- \<circ> map_dual f = f \<circ> \<partial>\<^sup>-"
   by (simp add: rewriteL_comp_comp)
 
 lemma map_dual_func1: "map_dual (f \<circ> g) = map_dual f \<circ> map_dual g"
   unfolding fun_eq_iff comp_def by (metis dual.exhaust dual.map) 
 
 lemma map_dual_func2 : "map_dual id = id"
   by simp
 
 text \<open>The functor map-dual has an inverse functor as well.\<close>
 
 definition map_dual_inv :: "('a dual \<Rightarrow> 'b dual) => ('a => 'b)" where
   "map_dual_inv f = \<partial>\<^sup>- \<circ> f \<circ> \<partial>"
 
 lemma map_dual_inv_func1: "map_dual_inv id = id"
   by (simp add: map_dual_inv_def)
 
 lemma map_dual_inv_func2: "map_dual_inv (f \<circ> g) = map_dual_inv f \<circ> map_dual_inv g"
   unfolding fun_eq_iff comp_def map_dual_inv_def by (metis dual_iff)
 
 lemma map_dual_inv1: "map_dual \<circ> map_dual_inv = id"
   unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
   by (metis dual_iff) 
 
 lemma map_dual_inv2: "map_dual_inv \<circ> map_dual = id"
   unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
   by (metis dual_iff) 
 
 text \<open>Hence dual is an isomorphism between categories.\<close>
 
 lemma subset_dual: "(\<partial> ` X = Y) \<longleftrightarrow> (X = \<partial>\<^sup>- ` Y)"
   by (metis dual_inj image_comp image_inv_f_f inv_o_cancel dual_inv2)
 
 lemma subset_dual1: "(X \<subseteq> Y) \<longleftrightarrow> (\<partial> ` X \<subseteq> \<partial> ` Y)"
   by (simp add: dual_inj inj_image_subset_iff) 
 
 lemma dual_ball: "(\<forall>x \<in> X. P (\<partial> x)) \<longleftrightarrow> (\<forall>y \<in> \<partial> ` X. P y)"
   by simp
 
 lemma dual_inv_ball: "(\<forall>x \<in> X. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y \<in> \<partial>\<^sup>- ` X. P y)"
   by simp
 
 lemma dual_all: "(\<forall>x. P (\<partial> x)) \<longleftrightarrow> (\<forall>y. P y)"
   by (metis dual.collapse)
 
 lemma dual_inv_all: "(\<forall>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y. P y)"
   by (metis dual_inv_surj surj_def)
 
 lemma dual_ex: "(\<exists>x. P (\<partial> x)) \<longleftrightarrow> (\<exists>y. P y)"  
   by (metis UNIV_I bex_imageD dual_surj)
 
 lemma dual_inv_ex: "(\<exists>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<exists>y. P y)"
   by (metis dual.sel)
 
 lemma dual_Collect: "{\<partial> x |x. P (\<partial> x)} = {y. P y}"
   by (metis dual.exhaust)
 
 lemma dual_inv_Collect: "{\<partial>\<^sup>- x |x. P (\<partial>\<^sup>- x)} = {y. P y}"
   by (metis dual.collapse dual.inject)
 
 lemma fun_dual1: "(f \<circ> \<partial> = g) \<longleftrightarrow> (f = g \<circ> \<partial>\<^sup>-)"
   by auto
 
 lemma fun_dual2: "(\<partial> \<circ> f = g) \<longleftrightarrow> (f = \<partial>\<^sup>- \<circ> g)"
   by auto
 
 lemma fun_dual3: "(f \<circ> (`) \<partial> = g) \<longleftrightarrow> (f = g \<circ> (`) \<partial>\<^sup>-)"
   unfolding fun_eq_iff comp_def by (metis subset_dual)
 
 lemma fun_dual4: "(f = \<partial>\<^sup>- \<circ> g \<circ> (`) \<partial>) \<longleftrightarrow> (\<partial> \<circ> f \<circ> (`) \<partial>\<^sup>- = g)"
   by (metis fun_dual2 fun_dual3 o_assoc)
 
 text \<open>The next facts show incrementally that the dual of a complete lattice is a complete lattice.
 This follows once again Wenzel.\<close>
 
 instantiation dual :: (ord) ord
 begin  
 
 definition less_eq_dual_def: "(\<le>) = rel_dual (\<ge>)"
 
 definition less_dual_def: "(<) = rel_dual (>)"
 
 instance..
 
 end
 
 lemma less_eq_dual_def_var: "(x \<le> y) = (\<partial>\<^sup>- y \<le> \<partial>\<^sup>- x)"
   apply (rule antisym)
   apply (simp add: dual.rel_sel less_eq_dual_def)
   by (simp add: dual.rel_sel less_eq_dual_def)
 
 lemma less_dual_def_var: "(x < y) = (\<partial>\<^sup>- y < \<partial>\<^sup>- x)"
   by (simp add: dual.rel_sel less_dual_def) 
 
 instance dual :: (preorder) preorder
   apply standard
   apply (simp add: less_dual_def_var less_eq_dual_def_var less_le_not_le)
   apply (simp add: less_eq_dual_def_var)
   by (meson less_eq_dual_def_var order_trans)
  
 instance dual :: (order) order
   by (standard, simp add: dual.expand less_eq_dual_def_var)
 
 lemma dual_anti: "x \<le> y \<Longrightarrow> \<partial> y \<le> \<partial> x" 
   by (simp add: dual_inj less_eq_dual_def the_inv_f_f)
 
 lemma dual_anti_iff: "(x \<le> y) = (\<partial> y \<le> \<partial> x)"
   by (simp add: dual_inj less_eq_dual_def the_inv_f_f)
 
 text \<open>map-dual does not map isotone functions to antitone ones. It simply lifts the type!\<close>
 
 lemma "mono f \<Longrightarrow> mono (map_dual f)"
   unfolding map_dual_def_var mono_def by (metis comp_apply dual_anti less_eq_dual_def_var)
 
 instantiation dual :: (lattice) lattice
 begin
 
 definition inf_dual_def: "x \<sqinter> y = \<partial> (\<partial>\<^sup>- x \<squnion> \<partial>\<^sup>- y)"
 
 definition sup_dual_def: "x \<squnion> y = \<partial> (\<partial>\<^sup>- x \<sqinter> \<partial>\<^sup>- y)"
 
 instance
   by (standard, simp_all add: dual_inj inf_dual_def sup_dual_def less_eq_dual_def_var the_inv_f_f)
 
 end
 
 instantiation dual :: (complete_lattice) complete_lattice
 begin
 
 definition Inf_dual_def: "Inf = \<partial> \<circ> Sup \<circ> (`) \<partial>\<^sup>-"
 
 definition Sup_dual_def: "Sup = \<partial> \<circ> Inf \<circ> (`) \<partial>\<^sup>-"
 
 definition bot_dual_def: "\<bottom> = \<partial> \<top>"
 
 definition top_dual_def: "\<top> = \<partial> \<bottom>"
 
 instance
    by (standard, simp_all add: Inf_dual_def top_dual_def Sup_dual_def bot_dual_def dual_inj le_INF_iff SUP_le_iff INF_lower SUP_upper less_eq_dual_def_var the_inv_f_f)
 
 end
 
 text \<open>Next, directed and filtered sets, upsets, downsets, filters and ideals in posets are defined.\<close>
 
 context ord
 begin
 
 definition directed :: "'a set \<Rightarrow> bool" where
  "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"
 
 definition filtered :: "'a set \<Rightarrow> bool" where
  "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"
 
 definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
   "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"
 
 definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
  "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"
 
 end
 
 subsection \<open>Examples that Do Not Dualise\<close>
 
 text \<open>Filtered and directed sets are dual.\<close>
 
 text \<open>Proofs could be simplified if dual was idempotent.\<close>
 
 lemma filtered_directed_dual: "filtered \<circ> (`) \<partial> = directed"
 proof-
   {fix X::"'a set"
     have "(filtered \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> x \<le> \<partial> y))"
       unfolding filtered_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
     also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. y \<le> x))"
       by (metis dual_anti_iff dual_inv_surj finite_subset_image top.extremum)
     finally have "(filtered \<circ> (`) \<partial>) X = directed X"
       using directed_def by auto}
   thus ?thesis
     unfolding fun_eq_iff by simp 
 qed
 
 lemma directed_filtered_dual: "directed \<circ> (`) \<partial> = filtered"
 proof-
   {fix X::"'a set"
     have "(directed \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> y \<le> \<partial> x))"
       unfolding directed_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
   also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. x \<le> y))"
     unfolding dual_anti_iff[symmetric] by (metis dual_inv_surj finite_subset_image top_greatest)
   finally have "(directed \<circ> (`) \<partial>) X = filtered X"
     using filtered_def by auto}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 text \<open>This example illustrates the deficiency of the approach. In the class-based approach the second proof is trivial.\<close>
 
 text \<open>The next example shows that this is a systematic problem.\<close>
 
 lemma downset_set_upset_set_dual: "(`) \<partial> \<circ> \<Down> = \<Up> \<circ> (`) \<partial>"
   proof-
     {fix X::"'a set"
   have "((`) \<partial> \<circ> \<Down>) X = {\<partial> y |y. \<exists>x \<in> X. y \<le> x}"
     by (simp add: downset_set_def setcompr_eq_image)
   also have "... = {\<partial> y |y. \<exists>x \<in> X. \<partial> x \<le> \<partial> y}"
     by (meson dual_anti_iff)
   also have "... = {y. \<exists>x \<in> \<partial> ` X. x \<le> y}"
     by (metis (mono_tags, opaque_lifting) dual.exhaust image_iff)
   finally have "((`) \<partial> \<circ> \<Down>) X = (\<Up> \<circ> (`) \<partial>) X"
     by (simp add: upset_set_def)}
   thus ?thesis
     unfolding fun_eq_iff by simp
 qed
 
 lemma upset_set_downset_set_dual: "(`) \<partial> \<circ> \<Up> = \<Down> \<circ> (`) \<partial>"
   unfolding downset_set_def upset_set_def fun_eq_iff comp_def
   apply (safe, force simp: dual_anti)
   by (metis (mono_tags, lifting) dual.exhaust dual_anti_iff mem_Collect_eq rev_image_eqI)
 
 end
diff --git a/thys/Order_Lattice_Props/Sup_Lattice.thy b/thys/Order_Lattice_Props/Sup_Lattice.thy
--- a/thys/Order_Lattice_Props/Sup_Lattice.thy
+++ b/thys/Order_Lattice_Props/Sup_Lattice.thy
@@ -1,162 +1,162 @@
 (* 
   Title: Sup-Lattices and Other Simplifications
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Sup-Lattices and Other Simplifications\<close>
 
 theory Sup_Lattice
-  imports  Main 
-           "HOL-Library.Lattice_Syntax"
+  imports Main
+begin
 
-begin
+unbundle lattice_syntax
 
 text \<open>Some definitions for orderings and lattices in Isabelle could be simpler. The strict order in 
 in ord could be defined instead of being axiomatised. The function mono could have been defined on ord
 and not on order---even on a general (di)graph it serves as a morphism. In complete lattices, the 
 supremum---and dually the infimum---suffices to define the other operations (in the Isabelle/HOL-definition
 infimum, binary supremum and infimum, bottom and top element are axiomatised). This not only increases
 the number of proof obligations in subclass or sublocale statements, instantiations or interpretations,
 it also complicates situations where suprema are presented faithfully, e.g. mapped onto suprema in 
 some subalgebra, whereas infima in the subalgebra are different from those in the super-structure.\<close>
 
 
 text \<open>It would be even nicer to use a class less-eq which dispenses with the strict order symbol
 in ord. Then one would not have to redefine this symbol in all instantiations or interpretations.
 At least, it does not carry any proof obligations.\<close>
 
 context ord
 begin
 
 text \<open>ub-set yields the set of all upper bounds of a set; lb-set the set of all lower bounds.\<close>
 
 definition ub_set :: "'a set \<Rightarrow> 'a set" where
   "ub_set X = {y. \<forall>x \<in> X. x \<le> y}"
 
 definition lb_set :: "'a set \<Rightarrow> 'a set" where
   "lb_set X = {y. \<forall>x \<in> X. y \<le> x}"
 
 end
 
 definition ord_pres :: "('a::ord \<Rightarrow> 'b::ord) \<Rightarrow> bool" where
  "ord_pres f = (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"
 
 lemma ord_pres_mono: 
   fixes f :: "'a::order \<Rightarrow> 'b::order"
   shows "mono f = ord_pres f"
   by (simp add: mono_def ord_pres_def)
 
 class preorder_lean = ord +
   assumes preorder_refl: "x \<le> x"
   and preorder_trans: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
 
 begin
 
 definition le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
   "le x y = (x \<le> y \<and> \<not> (x \<ge> y))"
 
 end
 
 sublocale preorder_lean \<subseteq> prel: preorder "(\<le>)" le
   by (unfold_locales, auto simp add: le_def preorder_refl preorder_trans)
  
 class order_lean = preorder_lean +
   assumes order_antisym: "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"
 
 sublocale order_lean \<subseteq> posl: order "(\<le>)" le
   by (unfold_locales, simp add: order_antisym)
 
 class Sup_lattice = order_lean + Sup +
   assumes Sups_upper: "x \<in> X \<Longrightarrow> x \<le> \<Squnion>X"
   and Sups_least: "(\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>X \<le> z"
 
 begin
 
 definition Infs :: "'a set \<Rightarrow> 'a" where
   "Infs X =  \<Squnion>{y. \<forall>x \<in> X. y \<le> x}"
 
 definition sups :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "sups x y = \<Squnion>{x,y}"
 
 definition infs :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "infs x y = Infs{x,y}"
 
 definition bots :: 'a where 
   "bots = \<Squnion>{}"
 
 definition tops :: 'a where
   "tops = Infs{}"
 
 lemma Infs_prop: "Infs = Sup \<circ> lb_set"
   unfolding fun_eq_iff by (simp add: Infs_def prel.lb_set_def)
 
 end
 
 class Inf_lattice = order_lean + Inf +
   assumes Infi_lower: "x \<in> X \<Longrightarrow> \<Sqinter>X \<le> x"
   and Infi_greatest: "(\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> \<Sqinter>X"
 
 begin
 
 definition Supi :: "'a set \<Rightarrow> 'a" where
   "Supi X = \<Sqinter>{y. \<forall>x \<in> X. x \<le> y}"
 
 definition supi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "supi x y = Supi{x,y}"
 
 definition infi :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "infi x y = \<Sqinter>{x,y}"
 
 definition boti :: 'a where 
   "boti = Supi{}"
 
 definition topi :: 'a where
   "topi = \<Sqinter>{}"
 
 lemma Supi_prop: "Supi = Inf \<circ> ub_set"
   unfolding fun_eq_iff by (simp add: Supi_def prel.ub_set_def)
 
 end
 
 sublocale Inf_lattice \<subseteq> ldual: Sup_lattice Inf "(\<ge>)"
   rewrites "ldual.Infs = Supi"
   and "ldual.infs = supi"
   and "ldual.sups = infi"
   and "ldual.tops = boti"
   and "ldual.bots = topi"
 proof-
   show "class.Sup_lattice Inf (\<ge>)"
     by (unfold_locales, simp_all add: Infi_lower Infi_greatest preorder_trans)
   then interpret ldual: Sup_lattice Inf "(\<ge>)".
   show a: "ldual.Infs = Supi"
     unfolding fun_eq_iff by (simp add: ldual.Infs_def Supi_def)
   show "ldual.infs = supi"
     unfolding fun_eq_iff by (simp add: a ldual.infs_def supi_def)
   show "ldual.sups = infi"
     unfolding fun_eq_iff by (simp add: ldual.sups_def infi_def) 
   show "ldual.tops = boti"
     by (simp add: a ldual.tops_def boti_def)
   show "ldual.bots = topi"
     by (simp add: ldual.bots_def topi_def)
 qed
 
 sublocale Sup_lattice \<subseteq> supclat: complete_lattice Infs Sup_class.Sup infs "(\<le>)" le sups bots tops
   apply unfold_locales
   unfolding Infs_def infs_def sups_def bots_def tops_def
   by (simp_all, auto intro: Sups_least, simp_all add: Sups_upper)
        
  sublocale Inf_lattice \<subseteq> infclat: complete_lattice Inf_class.Inf Supi infi "(\<le>)" le supi boti topi
   by (unfold_locales, simp_all add: ldual.Sups_upper ldual.Sups_least ldual.supclat.Inf_lower ldual.supclat.Inf_greatest)
 
 end
 
 
 
 
 
 
 
 
 
 
diff --git a/thys/Polynomial_Factorization/ROOT b/thys/Polynomial_Factorization/ROOT
--- a/thys/Polynomial_Factorization/ROOT
+++ b/thys/Polynomial_Factorization/ROOT
@@ -1,72 +1,71 @@
 chapter AFP
 
 session "JNF-AFP-Lib" (AFP) in "Lib" = "HOL-Algebra" +
   description "Theories from HOL-Library and the Archive of Formal Proofs that are used by this entry"
   options [timeout = 600]
   sessions
     Containers
     "Abstract-Rewriting"
     Gauss_Jordan Matrix
     Polynomial_Interpolation
     Show
     VectorSpace
     "HOL-Cardinals"
   theories
     Containers.Set_Impl
     Matrix.Utility
     Matrix.Ordered_Semiring
     "Abstract-Rewriting.SN_Order_Carrier"
     "Abstract-Rewriting.Relative_Rewriting"
     Show.Show_Instances
     VectorSpace.VectorSpace
     Polynomial_Interpolation.Missing_Polynomial
     Polynomial_Interpolation.Ring_Hom_Poly
     "HOL-Library.AList"
     "HOL-Library.Cardinality"
     "HOL-Library.Char_ord"
     "HOL-Library.Code_Binary_Nat"
     "HOL-Library.Code_Target_Numeral"
     "HOL-Library.DAList"
     "HOL-Library.DAList_Multiset"
     "HOL-Library.Infinite_Set"
-    "HOL-Library.Lattice_Syntax"
     "HOL-Library.Mapping"
     "HOL-Library.Monad_Syntax"
     "HOL-Library.More_List"
     "HOL-Library.Multiset"
     "HOL-Library.IArray"
     "HOL-Library.Phantom_Type"
     "HOL-Library.Ramsey"
     "HOL-Library.RBT_Impl"
     "HOL-Library.Simps_Case_Conv"
     "HOL-Library.While_Combinator"
     "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
     "HOL-Computational_Algebra.Fraction_Field"
     "HOL-Computational_Algebra.Polynomial"
     "HOL-Computational_Algebra.Primes"
     "HOL-Cardinals.Order_Union"
     "HOL-Cardinals.Wellorder_Extension"
 
 
 session Polynomial_Factorization (AFP) = "JNF-AFP-Lib" + 
   description "Algebraic Numbers"
   options [timeout = 600]
   sessions
     Partial_Function_MR
     Polynomial_Interpolation
     Show
     Sqrt_Babylonian
   theories
     Missing_Multiset
     Missing_List
     Precomputation
     Order_Polynomial
     Explicit_Roots
     Dvd_Int_Poly
     Rational_Root_Test
     Kronecker_Factorization
     Square_Free_Factorization
     Rational_Factorization
   document_files
     "root.bib"
     "root.tex"
diff --git a/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy b/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
--- a/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
+++ b/thys/Residuated_Lattices/Residuated_Boolean_Algebras.thy
@@ -1,665 +1,667 @@
 (* Title:      Residuated Boolean Algebras
    Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
    Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 section \<open>Residuated Boolean Algebras\<close>
 
 theory Residuated_Boolean_Algebras
   imports Residuated_Lattices
 begin
 
+unbundle lattice_syntax
+
 subsection \<open>Conjugation on Boolean Algebras\<close>
 
 text \<open>
   Similarly, as in the previous section, we define the conjugation for
   arbitrary residuated functions on boolean algebras.
 \<close>
 
 context boolean_algebra
 begin
 
 lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
   by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)
 
 lemma le_iff_inf_bot: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = \<bottom>"
   by (metis inf_bot_iff_le compl_le_compl_iff inf_commute)
   
 lemma indirect_eq: "(\<And>z. x \<le> z \<longleftrightarrow> y \<le> z) \<Longrightarrow> x = y"
   by (metis order.eq_iff)
 
 text \<open>
   Let $B$ be a boolean algebra. The maps $f$ and $g$ on $B$ are
   a pair of conjugates if and only if for all $x, y \in B$,
   $f(x) \sqcap y = \bot \Leftrightarrow x \sqcap g(t) = \bot$.
 \<close>
   
 definition conjugation_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "conjugation_pair f g \<equiv> \<forall>x y. f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> g(y) = \<bottom>"
 
 lemma conjugation_pair_commute: "conjugation_pair f g \<Longrightarrow> conjugation_pair g f"
   by (auto simp: conjugation_pair_def inf_commute)
   
 lemma conjugate_iff_residuated: "conjugation_pair f g = residuated_pair f (\<lambda>x. -g(-x))"
   apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
   by (metis double_compl)
 
 lemma conjugate_residuated: "conjugation_pair f g \<Longrightarrow> residuated_pair f (\<lambda>x. -g(-x))"
   by (metis conjugate_iff_residuated)
   
 lemma residuated_iff_conjugate: "residuated_pair f g = conjugation_pair f (\<lambda>x. -g(-x))"
   apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
   by (metis double_compl)
 
 text \<open>
   A map $f$ has a conjugate pair if and only if it is residuated.
 \<close>
   
 lemma conj_residuatedI1: "\<exists>g. conjugation_pair f g \<Longrightarrow> residuated f"
   by (metis conjugate_iff_residuated residuated_def)
   
 lemma conj_residuatedI2: "\<exists>g. conjugation_pair g f \<Longrightarrow> residuated f"
   by (metis conj_residuatedI1 conjugation_pair_commute)
   
 lemma exist_conjugateI[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair f g"
   by (metis residuated_def residuated_iff_conjugate)
   
 lemma exist_conjugateI2[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair g f"
   by (metis exist_conjugateI conjugation_pair_commute)
 
 text \<open>
   The conjugate of a residuated function $f$ is unique.
 \<close>
 
 lemma unique_conjugate[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair f g"
 proof - 
   {
     fix g h x assume "conjugation_pair f g" and "conjugation_pair f h"
     hence "g = h"
       apply (unfold conjugation_pair_def)
       apply (rule ext)
       apply (rule order.antisym)
       by (metis le_iff_inf_bot inf_commute inf_compl_bot)+
   } 
   moreover assume "residuated f"
   ultimately show ?thesis by force
 qed
   
 lemma unique_conjugate2[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair g f"
   by (metis unique_conjugate conjugation_pair_commute)
 
 text \<open>
   Since the conjugate of a residuated map is unique, we define a
   conjugate operation.
 \<close>
   
 definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
   "conjugate f \<equiv> THE g. conjugation_pair g f"
 
 lemma conjugate_iff_def: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> conjugate f y = \<bottom>"
   apply (clarsimp simp: conjugate_def dest!: unique_conjugate)
   apply (subgoal_tac "(THE g. conjugation_pair g f) = g")
   apply (clarsimp simp add: conjugation_pair_def)
   apply (rule the1_equality)
   by (auto intro: conjugation_pair_commute)
     
 lemma conjugateI1: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom>"
   by (metis conjugate_iff_def)
   
 lemma conjugateI2: "residuated f \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom> \<Longrightarrow> f(x) \<sqinter> y = \<bottom>"
   by (metis conjugate_iff_def)
 
 text \<open>
   Few more lemmas about conjugation follow.
 \<close>
   
 lemma residuated_conj1: "residuated f \<Longrightarrow> conjugation_pair f (conjugate f)"
   using conjugateI1 conjugateI2 conjugation_pair_def by auto
   
 lemma residuated_conj2: "residuated f \<Longrightarrow> conjugation_pair (conjugate f) f"
   using conjugateI1 conjugateI2 conjugation_pair_def inf_commute by auto
   
 lemma conj_residuated: "residuated f \<Longrightarrow> residuated (conjugate f)"
   by (force dest!: residuated_conj2 intro: conj_residuatedI1)
   
 lemma conj_involution: "residuated f \<Longrightarrow> conjugate (conjugate f) = f"
   by (metis conj_residuated residuated_conj1 residuated_conj2 unique_conjugate)
   
 lemma residual_conj_eq: "residuated f \<Longrightarrow> residual (conjugate f) = (\<lambda>x. -f(-x))"
   apply (unfold residual_def)
   apply (rule the1_equality)
   apply (rule residual_unique)
   apply (auto intro: conj_residuated conjugate_residuated residuated_conj2)
 done
   
 lemma residual_conj_eq_ext: "residuated f \<Longrightarrow> residual (conjugate f) x = -f(-x)"
   by (metis residual_conj_eq)
   
 lemma conj_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> conjugate f x \<le> conjugate f y"
   by (metis conj_residuated res_iso)
   
 lemma conjugate_strict: "residuated f \<Longrightarrow> conjugate f \<bottom> = \<bottom>"
   by (metis conj_residuated residuated_strict)
 
 lemma conjugate_sup: "residuated f \<Longrightarrow> conjugate f (x \<squnion> y) = conjugate f x \<squnion> conjugate f y"
   by (metis conj_residuated residuated_sup)
 
 lemma conjugate_subinf: "residuated f \<Longrightarrow> conjugate f (x \<sqinter> y) \<le> conjugate f x \<sqinter> conjugate f y"
   by (auto simp: conj_iso)
  
 text \<open>
   Next we prove some lemmas from Maddux's article. Similar lemmas have been proved in AFP entry
   for relation algebras. They should be consolidated in the future.
 \<close>
 
 lemma maddux1: "residuated f \<Longrightarrow> f(x \<sqinter> - conjugate f(y)) \<le> f(x) \<sqinter> -y"
 proof -
   assume assm: "residuated f"
   hence "f(x \<sqinter> - conjugate f(y)) \<le> f x"
     by (metis inf_le1 res_iso)
   moreover have "f(x \<sqinter> - conjugate f (y)) \<sqinter> y = \<bottom>"
     by (metis assm conjugateI2 inf_bot_iff_le inf_le2)
   ultimately show ?thesis
     by (metis inf_bot_iff_le le_inf_iff)
 qed
 
 lemma maddux1': "residuated f \<Longrightarrow> conjugate f(x \<sqinter> -f(y)) \<le> conjugate f(x) \<sqinter> -y"
   by (metis conj_involution conj_residuated maddux1)
   
 lemma maddux2: "residuated f \<Longrightarrow> f(x) \<sqinter> y \<le> f(x \<sqinter> conjugate f y)"
 proof -
   assume resf: "residuated f"
   obtain z where z_def: "z = f(x \<sqinter> conjugate f y)" by auto
   hence "f(x \<sqinter> conjugate f y) \<sqinter> -z = \<bottom>"
     by (metis inf_compl_bot)
   hence "x \<sqinter> conjugate f y \<sqinter> conjugate f (-z) = \<bottom>"
     by (metis conjugate_iff_def resf)
   hence "x \<sqinter> conjugate f (y \<sqinter> -z) = \<bottom>"
     apply (subgoal_tac "conjugate f (y \<sqinter> -z) \<le> conjugate f y \<sqinter> conjugate f (-z)")
     apply (metis (no_types, opaque_lifting) dual_order.trans inf.commute inf_bot_iff_le inf_left_commute)
     by (metis conj_iso inf_le2 inf_top.left_neutral le_inf_iff resf)
   hence "f(x) \<sqinter> y \<sqinter> -z = \<bottom>"
     by (metis conjugateI2 inf.assoc resf)
   thus ?thesis
     by (metis double_compl inf_bot_iff_le z_def)
 qed
 
 lemma maddux2': "residuated f \<Longrightarrow> conjugate f(x) \<sqinter> y \<le> conjugate f(x \<sqinter> f y)"
   by (metis conj_involution conj_residuated maddux2)
   
 lemma residuated_conjugate_ineq: "residuated f \<Longrightarrow> conjugate f x \<le> y \<longleftrightarrow> x \<le> -f(-y)"
   by (metis conj_residuated residual_galois residual_conj_eq)
 
 lemma residuated_comp_closed: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> residuated (f o g)"
   by (auto simp add: residuated_def residuated_pair_def)
   
 lemma conjugate_comp: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (f o g) = conjugate g o conjugate f"
 proof (rule ext, rule indirect_eq)
   fix x y
   assume assms: "residuated f" "residuated g" 
   have "conjugate (f o g) x \<le> y \<longleftrightarrow> x \<le> -f(g(-y))"
     apply (subst residuated_conjugate_ineq)
     using assms by (auto intro!: residuated_comp_closed)
   also have "... \<longleftrightarrow> conjugate g (conjugate f x) \<le> y"
     using assms by (simp add: residuated_conjugate_ineq)
   finally show "(conjugate (f \<circ> g) x \<le> y) = ((conjugate g \<circ> conjugate f) x \<le> y)"   
     by auto
 qed 
 
 lemma conjugate_comp_ext: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (\<lambda>x. f (g x)) x = conjugate g (conjugate f x)"
   using conjugate_comp by (simp add: comp_def)
   
 end (* boolean_algebra *)
 
 context complete_boolean_algebra begin
 
 text \<open>
   On a complete boolean algebra, it is possible to give an explicit
   definition of conjugation.
 \<close>
 
 lemma conjugate_eq: "residuated f \<Longrightarrow> conjugate f y = \<Sqinter>{x. y \<le> -f(-x)}"
 proof -
   assume assm: "residuated f" obtain g where g_def: "g = conjugate f" by auto
   have "g y = \<Sqinter>{x. x \<ge> g y}"
     by (auto intro!: order.antisym Inf_lower Inf_greatest)
   also have "... = \<Sqinter>{x. -x \<sqinter> g y = \<bottom>}"
     by (simp add: inf_bot_iff_le)
   also have "... = \<Sqinter>{x. f(-x) \<sqinter> y = \<bottom>}"
     by (metis conjugate_iff_def assm g_def)
   finally show ?thesis
     by (simp add: g_def le_iff_inf_bot inf_commute)
 qed
 
 end (* complete_boolean_algebra *)
 
 subsection \<open>Residuated Boolean Structures\<close>
 
 text \<open>
   In this section, we present various residuated structures based on
   boolean algebras.
   The left and right conjugation of the multiplicative operation is
   defined, and a number of facts is derived.
 \<close>
 
 class residuated_boolean_algebra = boolean_algebra + residuated_pogroupoid
 begin
 
 subclass residuated_lgroupoid ..
 
 definition conjugate_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<lhd>" 60) where
   "x \<lhd> y \<equiv> -(-x \<leftarrow> y)"
 
 definition conjugate_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<rhd>" 60) where
   "x \<rhd> y \<equiv> -(x \<rightarrow> -y)"
   
 lemma residual_conjugate_r: "x \<rightarrow> y = -(x \<rhd> -y)"
   by (metis conjugate_r_def double_compl)
   
 lemma residual_conjugate_l: "x \<leftarrow> y = -(-x \<lhd> y)"
   by (metis conjugate_l_def double_compl)
   
 lemma conjugation_multl: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> x \<sqinter> (z \<lhd> y) = \<bottom>"
   by (metis conjugate_l_def double_compl le_iff_inf_bot resl_galois)
 
 lemma conjugation_multr: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (x \<rhd> z) = \<bottom>"
   by (metis conjugate_r_def inf_bot_iff_le le_iff_inf_bot resr_galois)
   
 lemma conjugation_conj: "(x \<lhd> y) \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (z \<rhd> x) = \<bottom>"
   by (metis inf_commute conjugation_multr conjugation_multl)
 
 lemma conjugation_pair_multl [simp]: "conjugation_pair (\<lambda>x. x\<cdot>y) (\<lambda>x. x \<lhd> y)"
   by (simp add: conjugation_pair_def conjugation_multl)
   
 lemma conjugation_pair_multr [simp]: "conjugation_pair (\<lambda>x. y\<cdot>x) (\<lambda>x. y \<rhd> x)"
   by (simp add: conjugation_pair_def conjugation_multr)
   
 lemma conjugation_pair_conj [simp]: "conjugation_pair (\<lambda>x. y \<lhd> x) (\<lambda>x. x \<rhd> y)"
   by (simp add: conjugation_pair_def conjugation_conj)
   
 lemma residuated_conjl1 [simp]: "residuated (\<lambda>x. x \<lhd> y)" 
   by (metis conj_residuatedI2 conjugation_pair_multl)
   
 lemma residuated_conjl2 [simp]: "residuated (\<lambda>x. y \<lhd> x)" 
   by (metis conj_residuatedI1 conjugation_pair_conj)
   
 lemma residuated_conjr1 [simp]: "residuated (\<lambda>x. y \<rhd> x)" 
   by (metis conj_residuatedI2 conjugation_pair_multr)
   
 lemma residuated_conjr2 [simp]: "residuated (\<lambda>x. x \<rhd> y)" 
   by (metis conj_residuatedI2 conjugation_pair_conj)
   
 lemma conjugate_multr [simp]: "conjugate (\<lambda>x. y\<cdot>x) = (\<lambda>x. y \<rhd> x)"
   by (metis conjugation_pair_multr residuated_conj1 residuated_multr unique_conjugate)
   
 lemma conjugate_conjr1 [simp]: "conjugate (\<lambda>x. y \<rhd> x) = (\<lambda>x. y\<cdot>x)"
   by (metis conjugate_multr conj_involution residuated_multr)
   
 lemma conjugate_multl [simp]: "conjugate (\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> y)"
   by (metis conjugation_pair_multl residuated_conj1 residuated_multl unique_conjugate)
  
 lemma conjugate_conjl1 [simp]: "conjugate (\<lambda>x. x \<lhd> y) = (\<lambda>x. x\<cdot>y)"
 proof -
   have "conjugate (conjugate (\<lambda>x. x\<cdot>y)) = conjugate (\<lambda>x. x \<lhd> y)" by simp
   thus ?thesis
     by (metis conj_involution[OF residuated_multl])
 qed
 
 lemma conjugate_conjl2[simp]: "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x \<rhd> y)"
   by (metis conjugation_pair_conj unique_conjugate residuated_conj1 residuated_conjl2)
 
 lemma conjugate_conjr2[simp]: "conjugate (\<lambda>x. x \<rhd> y) = (\<lambda>x. y \<lhd> x)"
 proof -
   have "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate (\<lambda>x. x \<rhd> y)" by simp
   thus ?thesis
     by (metis conj_involution[OF residuated_conjl2])
 qed
 
 lemma conjl1_iso: "x \<le> y \<Longrightarrow> x \<lhd> z \<le> y \<lhd> z"
   by (metis conjugate_l_def compl_mono resl_iso)
 
 lemma conjl2_iso: "x \<le> y \<Longrightarrow> z \<lhd> x \<le> z \<lhd> y"
   by (metis res_iso residuated_conjl2)
 
 lemma conjr1_iso: "x \<le> y \<Longrightarrow> z \<rhd> x \<le> z \<rhd> y"
   by (metis res_iso residuated_conjr1)
 
 lemma conjr2_iso: "x \<le> y \<Longrightarrow> x \<rhd> z \<le> y \<rhd> z"
   by (metis conjugate_r_def compl_mono resr_antitonel)
 
 lemma conjl1_sup: "z \<lhd> (x \<squnion> y) = (z \<lhd> x) \<squnion> (z \<lhd> y)"
   by (metis conjugate_l_def compl_inf resl_distr)
 
 lemma conjl2_sup: "(x \<squnion> y) \<lhd> z = (x \<lhd> z) \<squnion> (y \<lhd> z)"
   by (metis (poly_guards_query) residuated_sup residuated_conjl1)
 
 lemma conjr1_sup: "z \<rhd> (x \<squnion> y) = (z \<rhd> x) \<squnion> (z \<rhd> y)"
   by (metis residuated_sup residuated_conjr1)
 
 lemma conjr2_sup: "(x \<squnion> y) \<rhd> z = (x \<rhd> z) \<squnion> (y \<rhd> z)"
   by (metis conjugate_r_def compl_inf resr_distl)
 
 lemma conjl1_strict: "\<bottom> \<lhd> x = \<bottom>"
   by (metis residuated_strict residuated_conjl1)
 
 lemma conjl2_strict: "x \<lhd> \<bottom> = \<bottom>"
   by (metis residuated_strict residuated_conjl2)
 
 lemma conjr1_strict: "\<bottom> \<rhd> x = \<bottom>"
   by (metis residuated_strict residuated_conjr2)
 
 lemma conjr2_strict: "x \<rhd> \<bottom> = \<bottom>"
   by (metis residuated_strict residuated_conjr1)
 
 lemma conjl1_iff: "x \<lhd> y \<le> z \<longleftrightarrow> x \<le> -(-z\<cdot>y)"
   by (metis conjugate_l_def compl_le_swap1 compl_le_swap2 resl_galois)
 
 lemma conjl2_iff: "x \<lhd> y \<le> z \<longleftrightarrow> y \<le> -(-z \<rhd> x)"
   by (metis conjl1_iff conjugate_r_def compl_le_swap2 double_compl resr_galois)
 
 lemma conjr1_iff: "x \<rhd> y \<le> z \<longleftrightarrow> y \<le> -(x\<cdot>-z)"
   by (metis conjugate_r_def compl_le_swap1 double_compl resr_galois)
 
 lemma conjr2_iff: "x \<rhd> y \<le> z \<longleftrightarrow> x \<le> -(y \<lhd> -z)"
   by (metis conjugation_conj double_compl inf.commute le_iff_inf_bot)
 
 text \<open>
   We apply Maddux's lemmas regarding conjugation of an arbitrary residuated function 
   for each of the 6 functions.
 \<close>
   
 lemma maddux1a: "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> a\<cdot>x"
   by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux1a': "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux1b: "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> x\<cdot>a"
   by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux1b': "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux1c: " a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> a \<lhd> x"
   by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp
   
 lemma maddux1c': "a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp
   
 lemma maddux1d: "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> a \<rhd> x"
   by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp
   
 lemma maddux1d': "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> -y"
   by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp
 
 lemma maddux1e: "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> x \<lhd> a"
   by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux1e': "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux1f: "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> x \<rhd> a"
   by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp
   
 lemma maddux1f': "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> -y"
   by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp
 
 lemma maddux2a: "a\<cdot>x \<sqinter> y \<le> a\<cdot>(x \<sqinter> (a \<rhd> y))"
   by (insert maddux2 [of "\<lambda>x. a\<cdot>x"]) simp
   
 lemma maddux2b: "x\<cdot>a \<sqinter> y \<le> (x \<sqinter> (y \<lhd> a))\<cdot>a"
   by (insert maddux2 [of "\<lambda>x. x\<cdot>a"]) simp
   
 lemma maddux2c: "(a \<lhd> x) \<sqinter> y \<le> a \<lhd> (x \<sqinter> (y \<rhd> a))"
   by (insert maddux2 [of "\<lambda>x. a \<lhd> x"]) simp
   
-lemma maddux2d: "(a \<rhd> x) \<sqinter> y \<le> a \<rhd> (x \<sqinter> a\<cdot>y)"
+lemma maddux2d: "(a \<rhd> x) \<sqinter> y \<le> a \<rhd> (x \<sqinter> (a\<cdot>y))"
   by (insert maddux2 [of "\<lambda>x. a \<rhd> x"]) simp
 
-lemma maddux2e: "(x \<lhd> a) \<sqinter> y \<le> (x \<sqinter> y\<cdot>a) \<lhd> a"
+lemma maddux2e: "(x \<lhd> a) \<sqinter> y \<le> (x \<sqinter> (y\<cdot>a)) \<lhd> a"
   by (insert maddux2 [of "\<lambda>x. x \<lhd> a"]) simp
   
 lemma maddux2f: "(x \<rhd> a) \<sqinter> y \<le> (x \<sqinter> (a \<lhd> y)) \<rhd> a"
   by (insert maddux2 [of "\<lambda>x. x \<rhd> a"]) simp
   
 text \<open>
   The multiplicative operation $\cdot$ on a residuated boolean algebra is generally not
   associative. We prove some equivalences related to associativity.
 \<close>
 
 lemma res_assoc_iff1: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z)"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   thus "x \<rhd> (y \<rhd> z) = y \<cdot> x \<rhd> z"
     using conjugate_comp_ext[of "\<lambda>z. y\<cdot>z" "\<lambda>z. x\<cdot>z"] by auto
 next
   fix x y z assume "\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
     using conjugate_comp_ext[of "\<lambda>z. y \<rhd> z" "\<lambda>z. x \<rhd> z"] by auto
 qed
 
 lemma res_assoc_iff2: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y)"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   hence "\<forall>x y z. (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)" by simp
   thus "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
     using conjugate_comp_ext[of "\<lambda>x. x\<cdot>z" "\<lambda>x. x\<cdot>y"] by auto
 next
   fix x y z assume "\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
   hence "\<forall>x y z. (x \<lhd> z) \<lhd> y = x \<lhd> (y \<cdot> z)" by simp
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z" 
     using conjugate_comp_ext[of "\<lambda>z. z \<lhd> y" "\<lambda>x. x \<lhd> z"] by auto
 qed
   
 lemma res_assoc_iff3: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z))"
 proof safe
   fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
   thus "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
     using conjugate_comp_ext[of "\<lambda>u. x\<cdot>u" "\<lambda>u. u\<cdot>z"] and
     conjugate_comp_ext[of "\<lambda>u. u\<cdot>z" "\<lambda>u. x\<cdot>u", symmetric]
     by auto
 next
   fix x y z assume "\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
   thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
     using conjugate_comp_ext[of "\<lambda>u. x \<rhd> u" "\<lambda>u. u \<lhd> z"] and
     conjugate_comp_ext[of "\<lambda>u. u \<lhd> z" "\<lambda>u. x \<rhd> u", symmetric]
     by auto
 qed
 
 end (* residuated_boolean_algebra *)
 
 class unital_residuated_boolean = residuated_boolean_algebra + one +
   assumes mult_onel [simp]: "x\<cdot>1 = x"
   and mult_oner [simp]: "1\<cdot>x = x"
 begin
 
 text \<open>
   The following equivalences are taken from J{\'o}sson and Tsinakis.
 \<close>
 
 lemma jonsson1a: "(\<exists>f. \<forall>x y. x \<rhd> y = f(x)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
   apply standard
   apply force
   apply (rule_tac x="\<lambda>x. x \<rhd> 1" in exI)
   apply force
   done
   
 lemma jonsson1b: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = (x \<rhd> 1) \<rhd> y)"
 proof safe
   fix x y
   assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   hence "conjugate (\<lambda>y. x \<rhd> y) = conjugate (\<lambda>y. (x \<rhd> 1)\<cdot>y)" by metis
   thus "x\<cdot>y = (x \<rhd> 1) \<rhd> y" by simp
 next
   fix x y
   assume "\<forall>x y. x \<cdot> y = x \<rhd> 1 \<rhd> y"
   thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y"
     by (metis mult_onel)
 qed
 
 lemma jonsson1c: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y))"
 proof safe
   fix x y
   assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1)\<cdot>y)" by metis
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by force
   hence "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x)" by simp
   hence "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
   hence "(\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
   also have "... = conjugate (conjugate (\<lambda>x. 1 \<lhd> x)) o conjugate (\<lambda>x. x\<cdot>y)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally show "y \<lhd> x = 1 \<lhd> (x \<lhd> y)" by simp
 next
   fix x y
   assume "\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
   hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> (x \<lhd> y))" by metis
   hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y)" by force
   hence "conjugate (\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y))" by metis
   also have "... = conjugate (conjugate (\<lambda>x. x\<cdot>y)) o conjugate (\<lambda>x. 1 \<lhd> x)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by simp
   hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1) \<cdot> y)" by (simp add: comp_def)
   thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y" by metis
 qed
 
 lemma jonsson2a: "(\<exists>g. \<forall>x y. x \<lhd> y = x\<cdot>g(y)) \<longleftrightarrow> (\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y))"
   apply standard
   apply force
   apply (rule_tac x="\<lambda>x. 1 \<lhd> x" in exI)
   apply force
   done
   
 lemma jonsson2b: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y))"
 proof safe
   fix x y
   assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   hence "conjugate (\<lambda>x. x \<lhd> y) = conjugate (\<lambda>x. x\<cdot>(1 \<lhd> y))" by metis
   thus "x\<cdot>y = x \<lhd> (1 \<lhd> y)" by simp metis
 next
   fix x y
   assume "\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y)"
   hence "(\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
   hence "conjugate (\<lambda>x. x\<cdot>y) = conjugate (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
   thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by simp metis
 qed
 
 lemma jonsson2c: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. y \<rhd> x = (x \<rhd> y) \<rhd> 1)"
 proof safe
   fix x y
   assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>(1 \<lhd> y))" by metis
   hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)" by force
   hence "conjugate (\<lambda>y. y \<rhd> x) = (\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1)" by force
   hence "conjugate (conjugate (\<lambda>y. y \<rhd> x)) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by metis
   hence "(\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by simp
   also have "... = conjugate (conjugate (\<lambda>y. y \<rhd> 1)) o conjugate (\<lambda>y. x\<cdot>y)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by (simp add: comp_def)
   thus "y \<rhd> x = x \<rhd> y \<rhd> 1" by metis 
 next
   fix x y
   assume "\<forall>x y. y \<rhd> x = x \<rhd> y \<rhd> 1"
   hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by force
   hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y)" by force
   hence "conjugate (\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y))" by metis
   also have "... = conjugate (conjugate (\<lambda>y. x\<cdot>y)) o conjugate (\<lambda>y. y \<rhd> 1)"
     by (subst conjugate_comp[symmetric]) simp_all
   finally have "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)"
     by (metis conjugate_conjr1 conjugate_conjr2 conjugate_multr)
   thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by (simp add: comp_def)
 qed
 
 lemma jonsson3a: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<longleftrightarrow> (\<forall>x. 1 \<lhd> (1 \<lhd> x) = x)"
 proof safe
   fix x assume "\<forall>x. x \<rhd> 1 \<rhd> 1 = x"
   thus "1 \<lhd> (1 \<lhd> x) = x"
     by (metis compl_le_swap1 compl_le_swap2 conjr2_iff order.eq_iff)
 next
   fix x assume "\<forall>x. 1 \<lhd> (1 \<lhd> x) = x"
   thus "x \<rhd> 1 \<rhd> 1 = x"
     by (metis conjugate_l_def conjugate_r_def double_compl jipsen2r)
 qed
 
 lemma jonsson3b: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<Longrightarrow> (x \<sqinter> y) \<rhd> 1 = (x \<rhd> 1) \<sqinter> (y \<rhd> 1)"
 proof (rule order.antisym, auto simp: conjr2_iso)
   assume assm: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
   hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 = x \<sqinter> (((x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1) \<sqinter> y)"
     by (metis (no_types) conjr2_iso inf.cobounded2 inf.commute inf.orderE)
   hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 \<le> x \<sqinter> y" 
     using inf.orderI inf_left_commute by presburger
   thus "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<le> x \<sqinter> y \<rhd> 1" 
     using assm by (metis (no_types) conjr2_iso)
 qed
 
 lemma jonsson3c: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x \<Longrightarrow> x \<rhd> 1 = 1 \<lhd> x"
 proof (rule indirect_eq)
   fix z
   assume assms: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
   hence "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> ((x \<rhd> 1) \<sqinter> -z) \<rhd> 1 = \<bottom>"
     by (metis compl_sup conjugation_conj double_compl inf_bot_right sup_bot.left_neutral)
   also have "... \<longleftrightarrow> -z\<cdot>x \<sqinter> 1 = \<bottom>"
     by (metis assms jonsson3b conjugation_multr)
   finally have "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> (1 \<lhd> x) \<sqinter> -z = \<bottom>"
     by (metis conjugation_multl inf.commute)
   thus "(x \<rhd> 1 \<le> z) \<longleftrightarrow> (1 \<lhd> x \<le> z)"
     by (metis le_iff_inf_bot)
 qed 
 
 end (* unital_residuated_boolean *)
 
 class residuated_boolean_semigroup = residuated_boolean_algebra + semigroup_mult
 begin
 
 subclass residuated_boolean_algebra ..
 
 text \<open>
   The following lemmas hold trivially, since they are equivalent to associativity.
 \<close>
 
 lemma res_assoc1: "x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
   by (metis res_assoc_iff1 mult_assoc)
 
 lemma res_assoc2: "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
   by (metis res_assoc_iff2 mult_assoc)
 
 lemma res_assoc3: "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
   by (metis res_assoc_iff3 mult_assoc)
 
 end (*residuated_boolean_semigroup *)
 
 class residuated_boolean_monoid = residuated_boolean_algebra + monoid_mult
 begin
 
 subclass unital_residuated_boolean
   by standard auto
 
 subclass residuated_lmonoid ..
 
 lemma jonsson4: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
 proof safe
   fix x y assume assms: "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
   have "x \<rhd> y = (y \<rhd> x) \<rhd> 1"
     by (metis assms jonsson2c)
   also have "... = (y \<rhd> ((x \<rhd> 1) \<rhd> 1)) \<rhd> 1"
     by (metis assms jonsson2b jonsson3a mult_oner)
   also have "... = (((x \<rhd> 1)\<cdot>y) \<rhd> 1) \<rhd> 1"
     by (metis conjugate_r_def double_compl resr3)
   also have "... = (x \<rhd> 1)\<cdot>y"
     by (metis assms jonsson2b jonsson3a mult_oner)
   finally show "x \<rhd> y = (x \<rhd> 1)\<cdot>y" .
 next
   fix x y assume assms: "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
   have "y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
     by (metis assms jonsson1c)
   also have "... = 1 \<lhd> ((1 \<lhd> (1 \<lhd> x)) \<lhd> y)"
     by (metis assms conjugate_l_def double_compl jonsson1c mult_1_right resl3)
   also have "... = 1 \<lhd> (1 \<lhd> (y\<cdot>(1 \<lhd> x)))"
     by (metis conjugate_l_def double_compl resl3)
   also have "... = y\<cdot>(1 \<lhd> x)"
     by (metis assms jonsson1b jonsson1c jonsson3c mult_onel)
-  finally show "y \<lhd> x = y\<cdot>(1 \<lhd> x)".
+  finally show "y \<lhd> x = y\<cdot>(1 \<lhd> x)" .
 qed
 
 end (* residuated_boolean_monoid *)
 
 end
diff --git a/thys/Residuated_Lattices/Residuated_Lattices.thy b/thys/Residuated_Lattices/Residuated_Lattices.thy
--- a/thys/Residuated_Lattices/Residuated_Lattices.thy
+++ b/thys/Residuated_Lattices/Residuated_Lattices.thy
@@ -1,730 +1,718 @@
 (* Title:      Residuated Lattices
    Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
    Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
 *)
 
 theory Residuated_Lattices
   imports Kleene_Algebra.Signatures
 begin
 
 notation
   times (infixl "\<cdot>" 70)
   
-notation
-  bot ("\<bottom>") and
-  top ("\<top>") and
-  inf (infixl "\<sqinter>" 65) and
-  sup (infixl "\<squnion>" 65) and
-  Inf ("\<Sqinter>_" [900] 900) and
-  Sup ("\<Squnion>_" [900] 900)
+unbundle lattice_syntax
 
-syntax
-  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
-  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
-  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
-  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
-  
 section \<open>Residuated Lattices\<close>
 
 subsection \<open>Residuated Functions on a Partial Order\<close>
 
 text \<open>
   We follow Galatos and \emph{al.} to define residuated funtions on
   partial orders. Material from articles by Maddux, and J{\'o}sson and Tsinakis are also considered.
   
   This development should in the future be expanded to functions or categories where the sources and targets have
   different type.
 
   Let $P$ be a partial order, or a poset.
   A map $f : P \to P$ is residuated if there exists a map
   $g: P \to P$ such that $f(x) \le y \Leftrightarrow x \le g(y)$
   for all $x, y \in P$.
   That is, they are adjoints of a Galois connection.
 \<close>
 
 context order begin
 
 definition residuated_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "residuated_pair f g \<equiv> \<forall>x y. f(x) \<le> y \<longleftrightarrow> x \<le> g(y)"
 
 theorem residuated_pairI [intro]: 
   assumes "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
   and "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
   and "\<forall>x. x \<le> (g o f) x"
   and "\<forall>x. (f o g) x \<le> x"
   shows "residuated_pair f g"
   by (metis assms comp_apply local.order_trans residuated_pair_def antisym)
   
 definition residuated :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "residuated f \<equiv> \<exists>g. residuated_pair f g"
   
 text \<open>
   If a map $f$ is residuated, then its residual $g$ is unique. 
 \<close>
 
 lemma residual_unique: "residuated f \<Longrightarrow> \<exists>!g. residuated_pair f g"
   unfolding residuated_def residuated_pair_def
   by (metis ext eq_refl order.antisym)
   
 text \<open>
   Since the residual of a map $f$ is unique, it makes sense to 
   define a residual operator. 
 \<close>
   
 definition residual :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
   "residual f \<equiv> THE g. residuated_pair f g"
 
 lemma residual_galois: "residuated f \<Longrightarrow> f(x) \<le> y \<longleftrightarrow> x \<le> residual f y"
   apply (clarsimp simp: residuated_def residuated_pair_def)
   apply (subgoal_tac "residual f = g")
   apply (simp_all add: residual_def)
   apply (rule the1_equality)
   apply (metis residuated_def residuated_pair_def residual_unique) 
   by (simp add: residuated_pair_def)
 
 lemma residual_galoisI1: "residuated f \<Longrightarrow> f(x) \<le> y \<Longrightarrow> x \<le> residual f y"
   by (metis residual_galois)
 
 lemma residual_galoisI2: "residuated f \<Longrightarrow> x \<le> residual f y \<Longrightarrow> f(x) \<le> y"
   by (metis residual_galois)
   
 text \<open>
   A closure operator on a poset is a map that is expansive, isotone and
   idempotent.
   The composition of the residual of a function $f$ with $f$ is a closure operator.
 \<close>
 
 definition closure :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "closure f \<equiv> (\<forall>x. x \<le> f x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"
   
 lemma res_c1: "residuated f \<Longrightarrow> x \<le> residual f (f x)"
   by (metis local.order.refl residual_galois)
 
 lemma res_c2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f (f x) \<le> residual f (f y)"
   by (metis local.order.refl local.order_trans residual_galois)
   
 lemma res_c3: "residuated f \<Longrightarrow> residual f (f (residual f (f x))) = residual f (f x)"
   by (metis order.eq_iff local.order_trans res_c1 residual_galois)
 
 lemma res_closure: "residuated f \<Longrightarrow> closure (residual f o f)"
   by (auto simp: closure_def intro: res_c1 res_c2 res_c3)
 
 text \<open>
   Dually, an interior operator on a poset is a map that is contractive, isotone and
   idempotent.
   The composition of $f$ with its residual is an interior operator.
 \<close>
 
 definition interior :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
   "interior f \<equiv> (\<forall>x. f x \<le> x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"
 
 lemma res_i1: "residuated f \<Longrightarrow> f (residual f x) \<le> x"
   by (metis local.order.refl residual_galois)
   
 lemma res_i2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f (residual f x) \<le> f (residual f y)"
   by (metis local.order.refl local.order_trans residual_galois)
   
 lemma res_i3: "residuated f \<Longrightarrow> f (residual f (f (residual f x))) = f (residual f x)"
   by (metis local.antisym_conv res_c1 res_c3 res_i1 residual_galois)
   
 lemma res_interior: "residuated f \<Longrightarrow> interior (f o residual f)"
   by (auto simp: interior_def intro: res_i1 res_i2 res_i3)
 
 text \<open>Next we show a few basic lemmas about residuated maps.\<close>
 
 lemma res_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
   by (metis local.order.trans res_c1 residual_galois)
   
 lemma res_residual_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f x \<le> residual f y"
   by (metis local.order.trans res_i1 residual_galois)
 
 lemma res_comp1 [simp]: "residuated f \<Longrightarrow> f o residual f o f = f"
 proof -
   assume resf: "residuated f"
   { 
     fix x
     have "(f o residual f o f) x = f x"
       by (metis resf comp_apply order.eq_iff res_c1 res_i1 res_iso)
   }
   thus ?thesis
     by (metis ext)
 qed
 
 lemma res_comp2 [simp]: "residuated f \<Longrightarrow> residual f o f o residual f = residual f"
 proof -
   assume resf: "residuated f"
   { 
     fix x
     have "(residual f o f o residual f) x = residual f x"
       by (metis resf comp_apply order.eq_iff res_c1 res_i1 res_residual_iso)
   }
   thus ?thesis
     by (metis ext)
 qed
 
 end (* order *)
 
 text \<open>
   A residuated function $f$ preserves all existing joins.
   Dually, its residual preserves all existing meets.
   We restrict our attention to semilattices, where binary joins or meets exist, and to
   complete lattices, where arbitrary joins and meets exist.
 \<close>
 
 lemma (in semilattice_sup) residuated_sup: "residuated f \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
 proof (rule order.antisym)
   assume assm: "residuated f"
   thus "f (x \<squnion> y) \<le> f x \<squnion> f y"
     by (metis local.residual_galoisI1 local.residual_galoisI2 local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
   show "f x \<squnion> f y \<le> f (x \<squnion> y)"
     by (metis assm local.res_iso local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
 qed
 
 lemma (in semilattice_inf) residuated_inf: "residuated f \<Longrightarrow> residual f (x \<sqinter> y) = residual f x \<sqinter> residual f y"
 proof (rule order.antisym)
   assume assm: "residuated f"
   thus "residual f (x \<sqinter> y) \<le> residual f x \<sqinter> residual f y"
     by (metis local.inf.boundedI local.inf.cobounded1 local.inf.cobounded2 local.res_residual_iso)
   show "residual f x \<sqinter> residual f y \<le> residual f (x \<sqinter> y)"
     by (metis assm local.inf.bounded_iff local.inf.cobounded1 local.inf.cobounded2 local.residual_galoisI1 local.residual_galoisI2)
 qed
 
 context bounded_lattice begin
 
 lemma residuated_strict: "residuated f \<Longrightarrow> f \<bottom> = \<bottom>"
   by (metis local.bot_least local.bot_unique local.res_i1 local.res_iso)
   
 lemma res_top: "residuated f \<Longrightarrow> residual f \<top> = \<top>"
   by (metis local.residual_galoisI1 local.top_greatest local.top_unique)
 
 end
 
 context complete_lattice begin
 
 text \<open>
   On a complete lattice, a function $f$ is residuated if and only if
   it preserves arbitrary (possibly infinite) joins.
   Dually, a function $g$ is a residual of a residuated funtion $f$
   if and only if $g$ preserver arbitrary meets. 
 \<close>
 
 lemma residual_eq1: "residuated f \<Longrightarrow> residual f y = \<Squnion> {x. f x \<le> y}"
 proof (rule order.antisym)
   assume assm: "residuated f"
   thus "residual f y \<le> \<Squnion>{x. f x \<le> y}"
     by (auto simp: res_i1 intro!: Sup_upper)
   show "\<Squnion>{x. f x \<le> y} \<le> residual f y"
     by (auto simp: assm intro!: Sup_least residual_galoisI1)
 qed
 
 lemma residual_eq2: "residuated f \<Longrightarrow> f x = \<Sqinter> {y. x \<le> residual f y}"
 proof (rule order.antisym)
   assume assm: "residuated f"
   thus "f x \<le> \<Sqinter>{y. x \<le> residual f y}"
     by (auto intro: Inf_greatest residual_galoisI2)
   show "\<Sqinter>{y. x \<le> residual f y} \<le> f x"
     using assm by (auto simp: res_c1 intro!: Inf_lower)
 qed
 
 lemma residuated_Sup: "residuated f \<Longrightarrow> f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X}"
 proof (rule order.antisym)
   assume assm: "residuated f"
   obtain y where y_def: "y = \<Squnion>{f x |x. x \<in> X}" 
     by auto
   hence "\<forall>x \<in> X. f x \<le> y"
     by (auto simp: y_def intro: Sup_upper)
   hence "\<forall>x \<in> X. x \<le> residual f y"
     by (auto simp: assm intro!: residual_galoisI1)
   hence "\<Squnion>X \<le> residual f y"
     by (auto intro: Sup_least)
   thus "f(\<Squnion> X) \<le> \<Squnion>{f x |x. x \<in> X}"
     by (metis y_def assm residual_galoisI2)
 qed (clarsimp intro!: Sup_least res_iso Sup_upper)
 
 lemma residuated_Inf: "residuated f \<Longrightarrow> residual f(\<Sqinter> X) = \<Sqinter>{residual f x | x. x \<in> X}"
 proof (rule order.antisym, clarsimp intro!: Inf_greatest res_residual_iso Inf_lower)
   assume assm: "residuated f"
   obtain y where y_def: "y = \<Sqinter>{residual f x |x. x \<in> X}" 
     by auto
   hence "\<forall>x \<in> X. y \<le> residual f x"
     by (auto simp: y_def intro: Inf_lower)
   hence "\<forall>x \<in> X. f y \<le> x"
     by (metis assm residual_galoisI2)
   hence "f y \<le> \<Sqinter> X"
     by (auto intro: Inf_greatest)
   thus "\<Sqinter>{residual f x |x. x \<in> X} \<le> residual f (\<Sqinter>X)"
     by (auto simp: assm y_def intro!: residual_galoisI1)
 qed
 
 lemma Sup_sup: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
   apply (erule_tac x="{x, y}" in allE)
   by (force intro: Sup_eqI)
 
 lemma Sup_residuatedI: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> residuated f"
 proof (unfold residuated_def residuated_pair_def, standard+)
   fix x y
   assume "f x \<le> y"
   thus "x \<le> \<Squnion>{x. f x \<le> y}"
     by (clarsimp intro!: Sup_upper)
 next
   fix x y
   assume assm: "\<forall>X. f (\<Squnion>X) = \<Squnion>{f x |x. x \<in> X}"
   hence f_iso: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
     using Sup_sup by (auto simp: le_iff_sup)
   assume "x \<le> \<Squnion>{x. f x \<le> y}"
   hence "f x \<le> f(\<Squnion>{x. f x \<le> y})"
     by (metis f_iso)
   also have "... = \<Squnion>{f x | x . f x \<le> y}"
     using assm by auto
   finally show "f x \<le> y"
     apply (rule order_trans)
     by (auto intro!: Sup_least)
 qed
 
 lemma Inf_inf: "\<forall>X. f(\<Sqinter> X) = \<Sqinter>{f x | x. x \<in> X} \<Longrightarrow> f (x \<sqinter> y) = f x \<sqinter> f y"
   apply (erule_tac x="{x, y}" in allE)
   by (force intro: Inf_eqI)
 
 lemma Inf_residuatedI: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X) \<Longrightarrow> \<exists>f. residuated_pair f g"
 proof (unfold residuated_pair_def, standard+)
   fix x y
   assume "x \<le> g y"
   thus "\<Sqinter>{y. x \<le> g y} \<le> y"
     by (clarsimp intro!: Inf_lower)
 next
   fix x y
   assume assm: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X)"
   hence g_iso: "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
     using Inf_inf by (auto simp: le_iff_inf)
   assume "\<Sqinter>{y. x \<le> g y} \<le> y"
   hence "g (\<Sqinter>{y. x \<le> g y}) \<le> g y"
     by (metis g_iso)
   hence "(\<Sqinter>{g y | y. x \<le> g y}) \<le> g y"
     using assm apply (erule_tac x="{y. x \<le> g y}" in allE)
     by (auto intro!: Inf_lower)
   thus "x \<le> g y"
     apply (rule local.dual_order.trans)
     by (auto intro: Inf_greatest)
 qed
 
 end (* complete lattices *)
 
 subsection \<open>Residuated Structures\<close>
 
 text \<open>
   In this section, we define residuated algebraic structures, starting from the simplest of all,
   a \emph{residuated partial ordered groupoid}, to 
   \emph{residuated l-monoids}, which are residuated 
   lattices where the multiplicative operator forms a monoid.
 \<close>
 
 class pogroupoid = order + times +
   assumes mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
   and mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
 
 text \<open>
   A residuated partial ordered groupoid is simply a partial order and a multiplicative groupoid with 
   two extra operators satisfying the residuation laws.
   It is straighforward to prove that multiplication is compatible with the order,
   that is, multiplication is isotone.
   
   Most of the lemmas below come in pairs; they are related by opposition duality.
   Formalising this duality is left for future work.
 \<close>
 
 class residual_r_op =
   fixes residual_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60)
 
 class residual_l_op =
   fixes residual_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60)
   
 class residuated_pogroupoid = order + times + residual_l_op + residual_r_op +
   assumes resl_galois: "x \<le> z \<leftarrow> y \<longleftrightarrow> x \<cdot> y \<le> z"
   and resr_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
 begin
 
 lemma reslI [intro]: "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
   by (metis resl_galois)
 
 lemma resrI [intro]: "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
   by (metis resr_galois)
 
 lemma residuated_pair_multl [simp]: "residuated_pair (\<lambda>x. x \<cdot> y) (\<lambda>x. x \<leftarrow> y)"
   by (auto simp: residuated_pair_def resl_galois)
   
 lemma residuated_pair_multr [simp]: "residuated_pair (\<lambda>y. x \<cdot> y) (\<lambda>y. x \<rightarrow> y)"
   by (auto simp: residuated_pair_def resr_galois)
 
 text \<open>
   Multiplication is then obviously residuated.
 \<close>
   
 lemma residuated_multl [simp]: "residuated (\<lambda>x. x \<cdot> y)"
   by (metis residuated_def residuated_pair_multl)
 
 lemma residuated_multr [simp]: "residuated (\<lambda>y. x \<cdot> y)"
   by (metis residuated_def residuated_pair_multr)
   
 lemma resl_eq [simp]: "residual (\<lambda>x. x \<cdot> y) = (\<lambda>x. x \<leftarrow> y)"
   unfolding residual_def apply (rule the1_equality)
   by (auto simp: intro!: residual_unique)
   
 lemma resr_eq [simp]: "residual (\<lambda>y. x \<cdot> y) = (\<lambda>y. x \<rightarrow> y)"
   unfolding residual_def apply (rule the1_equality)
   by (auto simp: intro!: residual_unique)
   
 text \<open>
   Next we prove a few lemmas, all of which are instantiation of more general facts about residuated functions.
 \<close>
   
 lemma res_lc1: "x \<le> x \<cdot> y \<leftarrow> y"
   by auto
   
 lemma res_lc2: "x \<le> y \<Longrightarrow> x \<cdot> z \<leftarrow> z \<le> y \<cdot> z \<leftarrow> z"
   by (metis local.res_c2 resl_eq residuated_multl)
 
 lemma res_lc3 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<cdot> y \<leftarrow> y"
   by (metis local.res_c3 resl_eq residuated_multl)
   
 lemma res_rc1: "x \<le> y \<rightarrow> y \<cdot> x"
   by auto
 
 lemma res_rc2: "x \<le> y \<Longrightarrow> z \<rightarrow> z \<cdot> x \<le> z \<rightarrow> z \<cdot> y"
   by (metis local.res_c2 resr_eq residuated_multr)
 
 lemma res_rc3 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<rightarrow> y \<cdot> x"
   by (metis local.res_c3 resr_eq residuated_multr)
   
 lemma res_li1: "(x \<leftarrow> y) \<cdot> y \<le> x"
   by (metis local.res_i1 resl_eq residuated_multl)
   
 lemma res_li2: "x \<le> y \<Longrightarrow> (x \<leftarrow> z) \<cdot> z \<le> (y \<leftarrow> z) \<cdot> z"
   by (metis local.res_i2 resl_eq residuated_multl)
   
 lemma res_li3 [simp]: "((x \<leftarrow> y) \<cdot> y \<leftarrow> y) \<cdot> y = (x \<leftarrow> y) \<cdot> y"
   by (metis local.res_i3 resl_eq residuated_multl)
   
 lemma res_ri1: "y \<cdot> (y \<rightarrow> x) \<le> x"
   by (metis local.res_i1 resr_eq residuated_multr)
   
 lemma res_ri2: "x \<le> y \<Longrightarrow> z \<cdot> (z \<rightarrow> x) \<le> z \<cdot> (z \<rightarrow> y)"
   by (metis local.res_i2 resr_eq residuated_multr)
   
 lemma res_ri3 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> (y \<rightarrow> x)) = y \<cdot> (y \<rightarrow> x)"
   by (metis local.res_i3 resr_eq residuated_multr)
   
 subclass pogroupoid
 proof
   fix x y z
   show "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
     by (metis local.res_iso residuated_multl)
   show "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
     by (metis local.res_iso residuated_multr)
 qed
 
 lemma resl_iso: "x \<le> y \<Longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
   by (metis res_residual_iso resl_eq residuated_multl)
   
 lemma resr_iso: "x \<le> y \<Longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
   by (metis res_residual_iso resr_eq residuated_multr)
 
 lemma resl_comp1 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y = x \<cdot> y"
   by (metis order.antisym local.mult_isor res_lc1 res_li1)
   
 lemma resl_comp2 [simp]: "(x \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<leftarrow> y"
   by (metis order.eq_iff res_lc1 res_li1 resl_iso)
   
 lemma resr_comp1 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<cdot> x"
   by (metis order.antisym local.mult_isol res_rc1 res_ri1)
   
 lemma resr_comp2 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> x) = y \<rightarrow> x"
   by (metis order.eq_iff res_rc1 res_ri1 resr_iso)
   
 lemma resl_antitoner: "x \<le> y \<longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
   by (metis local.dual_order.trans local.mult_isol res_li1 reslI)
 
 lemma resr_antitonel: "x \<le> y \<longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
   by (metis local.dual_order.trans local.resl_galois res_ri1 resrI)
 
 text \<open>The following lemmas are taken from Galatos and \emph{al.}\<close>
 
 lemma jipsen1l: "x \<le> y \<leftarrow> (x \<rightarrow> y)"
   by (metis res_ri1 reslI)
   
 lemma jipsen1r: "x \<le> (y \<leftarrow> x) \<rightarrow> y"
   by (metis res_li1 resrI)
   
 lemma jipsen2l: "(y \<leftarrow> (x \<rightarrow> y)) \<rightarrow> y = x \<rightarrow> y"
   by (metis jipsen1l jipsen1r order.eq_iff local.resr_antitonel)
   
 lemma jipsen2r: "y \<leftarrow> ((y \<leftarrow> x) \<rightarrow> y) = y \<leftarrow> x"
   by (metis jipsen1l jipsen1r order.eq_iff local.resl_antitoner)
   
 end (* residuated_pogroupoid *)
 
 text \<open>
   In a residuated partial ordered semigroup, the multiplicative operator is associative.
 \<close>
   
 class residuated_posemigroup = semigroup_mult + residuated_pogroupoid 
 begin
 
 lemma resl_trans: "(x \<leftarrow> y)  \<cdot>  (y \<leftarrow> z) \<le> x \<leftarrow> z"
   by (metis local.res_li1 local.resl_antitoner local.resl_galois mult_assoc)
   
 lemma resr_trans: "(x \<rightarrow> y)  \<cdot>  (y \<rightarrow> z) \<le> x \<rightarrow> z"
   by (metis local.res_ri1 local.resr_antitonel local.resr_galois mult_assoc)
   
 lemma resr1: "(x \<rightarrow> y) \<cdot> z \<le> (x \<rightarrow> y \<cdot> z)"
   by (metis local.mult_isor local.res_ri1 local.resrI mult_assoc)
   
 lemma resr2: "x \<rightarrow> y \<le> z \<cdot> x \<rightarrow> z \<cdot> y"
   by (metis local.mult_isol local.res_ri1 local.resrI mult_assoc)
   
 lemma resr3: "x \<cdot> y \<rightarrow> z = y \<rightarrow> (x \<rightarrow> z)"
   by (metis order.eq_iff local.resr_galois mult_assoc)
   
 lemma resl1: "z \<cdot> (x \<leftarrow> y) \<le> (z \<cdot> x \<leftarrow> y)"
   by (metis local.mult_isol local.res_li1 local.reslI mult_assoc)
 
 lemma resl2: "x \<leftarrow> y \<le> x \<cdot> z \<leftarrow> y \<cdot> z"
   by (metis local.mult_isor local.res_li1 local.reslI mult_assoc)
 
 lemma resl3: "x \<leftarrow> y \<cdot> z = (x \<leftarrow> z) \<leftarrow> y"
   by (metis order.eq_iff local.resl_galois mult_assoc)
   
 lemma residual_assoc: "x \<rightarrow> (y \<leftarrow> z) = (x \<rightarrow> y) \<leftarrow> z"
 proof (rule order.antisym)
   show "x \<rightarrow> (y \<leftarrow> z) \<le> (x \<rightarrow> y) \<leftarrow> z"
     by (metis local.res_ri1 local.resl_galois local.resr_galois mult_assoc)
   show "(x \<rightarrow> y) \<leftarrow> z \<le> x \<rightarrow> (y \<leftarrow> z)"
     by (metis local.res_li1 local.resl_galois local.resr_galois mult_assoc)
 qed
 
 end (* residuated_posemigroup *)
 
 text \<open>
   In a residuated partially ordered monoid, the multiplicative operator has a unit $1$; that is,
   its reduct forms a monoid.
 \<close>
 
 class residuated_pomonoid = monoid_mult + residuated_pogroupoid 
 begin
 
 subclass residuated_posemigroup ..
 
 lemma resl_unit: "x \<leftarrow> 1 = x"
   by (metis local.mult_1_right local.resl_comp1)
 
 lemma resr_unit: "1 \<rightarrow> x = x"
   by (metis local.mult_1_left local.resr_comp1)
   
 lemma mult_one_resl: "x \<cdot> (1 \<leftarrow> y) \<le> x \<leftarrow> y"  
   by (metis local.mult_1_right local.resl1)
 
 lemma mult_one_resr: "(x \<rightarrow> 1) \<cdot> y \<le> x \<rightarrow> y"
   by (metis local.mult_1_left local.resr1)
 
 text \<open>More lemmas from Galatos and \emph{al.} follow.\<close>
 
 lemma jipsen3l: "1 \<le> x \<leftarrow> x"
   by (metis local.jipsen1l resr_unit)
 
 lemma jipsen3r: "1 \<le> x \<rightarrow> x"
   by (metis local.jipsen1r resl_unit)
   
 lemma jipsen4l [simp]: "(x \<leftarrow> x) \<cdot> x = x"
   by (metis local.mult_1_left local.resl_comp1)
   
 lemma jipsen4r [simp]: "x \<cdot> (x \<rightarrow> x) = x"
   by (metis local.mult_1_right local.resr_comp1)
   
 lemma jipsen5l [simp]: "(x \<leftarrow> x) \<cdot> (x \<leftarrow> x) = x \<leftarrow> x"
   by (metis jipsen4l local.resl3)
   
 lemma jipsen5r [simp]: "(x \<rightarrow> x) \<cdot> (x \<rightarrow> x) = x \<rightarrow> x"
   by (metis jipsen4r local.resr3)
   
 lemma jipsen6l: "y \<leftarrow> x \<le> (y \<leftarrow> z) \<leftarrow> (x \<leftarrow> z)"
   by (metis local.resl_galois local.resl_trans)
   
 lemma jipsen6r: "x \<rightarrow> y \<le> (z \<rightarrow> x) \<rightarrow> (z \<rightarrow> y)"
   by (metis local.resr_galois local.resr_trans)
   
 lemma jipsen7l: "y \<leftarrow> x \<le> (z \<leftarrow> y) \<rightarrow> (z \<leftarrow> x)"
   by (metis local.resr_galois local.resl_trans)
   
 lemma jipsen7r: "x \<rightarrow> y \<le> (x \<rightarrow> z) \<leftarrow> (y \<rightarrow> z)"
   by (metis local.resl_galois local.resr_trans)
 
 end (* residuated_pomonoid *)
 
 text \<open>
   Residuated partially ordered groupoids can be expanded residuated join semilattice ordered groupoids.
   They are used as a base for action algebras, which are expansions 
   of Kleene algebras by operations of residuation.
   Action algebras can be found in the AFP entry for Kleene algebras.
 \<close>
 
 class residuated_sup_lgroupoid = semilattice_sup + residuated_pogroupoid
 begin
 
 lemma distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
   by (metis local.residuated_multr local.residuated_sup)
   
 lemma distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
   by (metis local.residuated_multl local.residuated_sup)
   
 lemma resl_subdist_var: "x \<leftarrow> z \<le> (x \<squnion> y) \<leftarrow> z"
   by (metis local.resl_iso local.sup_ge1)
  
 lemma resl_subdist: "(x \<leftarrow> z) \<squnion> (y \<leftarrow> z) \<le> (x \<squnion> y) \<leftarrow> z"
   by (metis local.le_sup_iff local.sup_commute resl_subdist_var)
   
 lemma resr_subdist_var: "(x \<rightarrow> y) \<le> x \<rightarrow> (y \<squnion> z)"
   by (metis local.resr_iso local.sup_ge1)
   
 lemma resr_subdist: "(x \<rightarrow> y) \<squnion> (x \<rightarrow> z) \<le> x \<rightarrow> (y \<squnion> z)"
   by (metis sup_commute sup_least resr_subdist_var)
   
 lemma resl_superdist_var: "x \<leftarrow> (y \<squnion> z) \<le> x \<leftarrow> y"
   by (metis local.le_sup_iff local.res_li1 local.reslI local.resr_galois)
   
 lemma resr_superdist_var: "(x \<squnion> y) \<rightarrow> z \<le> x \<rightarrow> z"
   by (metis local.le_sup_iff local.res_ri1 local.resl_galois local.resrI)
 
 end (* residuated_sup_lgroupoid *)
 
 text \<open>
   Similarly, semigroup and monoid variants can be defined.
 \<close>
 
 class residuated_sup_lsemigroup = semilattice_sup + residuated_posemigroup
 subclass (in residuated_sup_lsemigroup) residuated_sup_lgroupoid ..
 
 class residuated_sup_lmonoid = semilattice_sup + residuated_posemigroup
 subclass (in residuated_sup_lmonoid) residuated_sup_lsemigroup ..
 
 text \<open>
   By lattice duality, we define residuated meet semillatice ordered groupoid.
 \<close>
 
 class residuated_inf_lgroupoid = semilattice_inf + residuated_pogroupoid
 begin
 
 lemma resl_dist: "(x \<sqinter> y) \<leftarrow> z = (x \<leftarrow> z) \<sqinter> (y \<leftarrow> z)"
   by (metis local.resl_eq local.residuated_inf local.residuated_multl)
 
 lemma resr_dist: "x \<rightarrow> (y \<sqinter> z) = (x \<rightarrow> y) \<sqinter> (x \<rightarrow> z)"
   by (metis local.resr_eq local.residuated_inf local.residuated_multr)
 
 lemma resl_inf_superdist: "x \<leftarrow> y \<le> x \<leftarrow> (y \<sqinter> z)"
   by (metis local.inf_le1 local.resl_antitoner)
 
 lemma resr_inf_superdist_var: "x \<rightarrow> y \<le> (x \<sqinter> z) \<rightarrow> y"
   by (metis local.inf_le1 local.resr_antitonel)
   
 end (* residuated_inf_lgroupoid *)
 
 class residuated_inf_lsemigroup = semilattice_inf + residuated_posemigroup
 subclass (in residuated_inf_lsemigroup) residuated_inf_lgroupoid ..
 
 class residuated_inf_lmonoid = semilattice_inf + residuated_posemigroup
 subclass (in residuated_inf_lmonoid) residuated_inf_lsemigroup ..
 
 text \<open>
   Finally, we obtain residuated lattice groupoids. 
 \<close>
 
 class residuated_lgroupoid = lattice + residuated_pogroupoid
 begin
 
 subclass residuated_sup_lgroupoid ..
 
 lemma resl_distr: "z \<leftarrow> (x \<squnion> y) = (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
 proof (rule order.antisym)
   show "z \<leftarrow> x \<squnion> y \<le> (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
     by (metis local.inf.bounded_iff local.resl_superdist_var local.sup_commute)
   show "(z \<leftarrow> x) \<sqinter> (z \<leftarrow> y) \<le> z \<leftarrow> x \<squnion> y"
     by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup.bounded_iff)
 qed
 
 lemma resr_distl: "(x \<squnion> y) \<rightarrow> z = (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
 proof (rule order.antisym)
   show "x \<squnion> y \<rightarrow> z \<le> (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
     by (metis local.inf.bounded_iff local.resr_antitonel local.resr_superdist_var local.sup_ge2)
   show "(x \<rightarrow> z) \<sqinter> (y \<rightarrow> z) \<le> x \<squnion> y \<rightarrow> z"
     by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup_least)
 qed 
 
 end (* residuated_lgroupoid *)
 
 class residuated_lsemigroup = lattice + residuated_sup_lsemigroup
 subclass (in residuated_lsemigroup) residuated_lgroupoid ..
 
 class residuated_lmonoid = lattice + residuated_sup_lmonoid
 subclass (in residuated_lmonoid) residuated_lsemigroup ..
 
 class residuated_blgroupoid = bounded_lattice + residuated_pogroupoid
 begin
 
 lemma multl_strict [simp]: "x \<cdot> \<bottom> = \<bottom>"
   by (metis local.residuated_multr local.residuated_strict)
 
 lemma multr_strict [simp]: "\<bottom> \<cdot> x = \<bottom>"
   by (metis local.residuated_multl local.residuated_strict)
 
 lemma resl_top [simp]: "\<top> \<leftarrow> x = \<top>"
   by (metis local.res_top local.residuated_multl local.resl_eq)
 
 lemma resl_impl [simp]: "x \<leftarrow> \<bottom> = \<top>"
   by (metis local.resl_comp2 multl_strict resl_top)
 
 lemma resr_top [simp]: "x \<rightarrow> \<top> = \<top>"
   by (metis local.resrI local.top_greatest local.top_unique)
 
 lemma resr_impl [simp]: "\<bottom> \<rightarrow> x = \<top>"
   by (metis local.resr_comp2 multr_strict resr_top)
 
 end (* residuated_blgroupoid *)
 
 class residuated_blsemigroup = bounded_lattice + residuated_sup_lsemigroup
 subclass (in residuated_blsemigroup) residuated_blgroupoid ..
 
 class residuated_blmonoid = bounded_lattice + residuated_sup_lmonoid
 subclass (in residuated_blmonoid) residuated_blsemigroup ..
 
 class residuated_clgroupoid = complete_lattice + residuated_pogroupoid
 begin
 
 lemma resl_eq_def: "y \<leftarrow> x = \<Squnion> {z. z \<cdot> x \<le> y}"
   by (metis local.residual_eq1 local.residuated_multl local.resl_eq)
 
 lemma resr_eq_def: "x \<rightarrow> y = \<Squnion> {z. x \<cdot> z \<le> y}"
   by (metis local.residual_eq1 local.residuated_multr local.resr_eq)
 
 lemma multl_def: "x \<cdot> y = \<Sqinter> {z. x \<le> z \<leftarrow> y}"
 proof -
   have "\<Sqinter>{ya. x \<le> residual (\<lambda>a. a \<cdot> y) ya} = \<Sqinter>{z. x \<le> z \<leftarrow> y}"
     by simp
   thus ?thesis
     by (metis residuated_multl residual_eq2)
 qed
 
 lemma multr_def: "x \<cdot> y = \<Sqinter> {z. y \<le> x \<rightarrow> z}"
 proof -
   have "\<Sqinter>{ya. y \<le> residual ((\<cdot>) x) ya} = \<Sqinter>{z. y \<le> x \<rightarrow> z}"
     by simp
   thus ?thesis
     by (metis residuated_multr residual_eq2)
 qed
 
 end (* residuated_clgroupoid *)
 
 class residuated_clsemigroup = complete_lattice + residuated_sup_lsemigroup
 subclass (in residuated_clsemigroup) residuated_clgroupoid ..
 
 class residuated_clmonoid = complete_lattice + residuated_sup_lmonoid
 subclass (in residuated_clmonoid) residuated_clsemigroup ..
 
 end
diff --git a/thys/SIFUM_Type_Systems/Preliminaries.thy b/thys/SIFUM_Type_Systems/Preliminaries.thy
--- a/thys/SIFUM_Type_Systems/Preliminaries.thy
+++ b/thys/SIFUM_Type_Systems/Preliminaries.thy
@@ -1,79 +1,81 @@
 (*
 Title: SIFUM-Type-Systems
 Authors: Sylvia Grewe, Heiko Mantel, Daniel Schoepe
 *)
 section \<open>Preliminaries\<close>
 theory Preliminaries
-imports Main "HOL-Library.Lattice_Syntax"
+imports Main
 begin
 
+unbundle lattice_syntax
+
 text \<open>Possible modes for variables:\<close>
 datatype Mode = AsmNoRead | AsmNoWrite | GuarNoRead | GuarNoWrite
 
 text \<open>We consider a two-element security lattice:\<close>
 datatype Sec = High | Low
 
 notation
   less_eq  (infix "\<sqsubseteq>" 50) and
   less  (infix "\<sqsubset>" 50)
 
 text \<open>@{term Sec} forms a (complete) lattice:\<close>
 instantiation Sec :: complete_lattice
 begin
 
 definition top_Sec_def: "\<top> = High"
 definition sup_Sec_def: "d1 \<squnion> d2 = (if (d1 = High \<or> d2 = High) then High else Low)"
 definition inf_Sec_def: "d1 \<sqinter> d2 = (if (d1 = Low \<or> d2 = Low) then Low else High)"
 definition bot_Sec_def: "\<bottom> = Low"
 definition less_eq_Sec_def: "d1 \<le> d2 = (d1 = d2 \<or> d1 = Low)"
 definition less_Sec_def: "d1 < d2 = (d1 = Low \<and> d2 = High)"
 definition Sup_Sec_def: "\<Squnion>S = (if (High \<in> S) then High else Low)"
 definition Inf_Sec_def: "\<Sqinter>S = (if (Low \<in> S) then Low else High)"
 
 instance
   apply (intro_classes)
   apply (metis Sec.exhaust Sec.simps(2) less_Sec_def less_eq_Sec_def)
   apply (metis less_eq_Sec_def)
   apply (metis less_eq_Sec_def)
   apply (metis less_eq_Sec_def)
   apply (metis Sec.exhaust inf_Sec_def less_eq_Sec_def)
   apply (metis Sec.exhaust inf_Sec_def less_eq_Sec_def)
   apply (metis Sec.exhaust inf_Sec_def less_eq_Sec_def)
   apply (metis Sec.exhaust less_eq_Sec_def sup_Sec_def)
   apply (metis Sec.exhaust less_eq_Sec_def sup_Sec_def)
   apply (metis Sec.exhaust Sec.simps(2) less_eq_Sec_def sup_Sec_def)
   apply (metis (full_types) Inf_Sec_def Sec.exhaust less_eq_Sec_def)
   apply (metis Inf_Sec_def Sec.exhaust less_eq_Sec_def)
   apply (metis Sec.exhaust Sup_Sec_def less_eq_Sec_def)
   apply (metis (full_types) Sup_Sec_def less_eq_Sec_def)
   apply (metis (opaque_lifting, mono_tags) Inf_Sec_def empty_iff top_Sec_def)
   by (metis (opaque_lifting, mono_tags) Sup_Sec_def bot_Sec_def empty_iff)
 end
 
 text \<open>Memories are mappings from variables to values\<close>
 type_synonym ('var, 'val) Mem = "'var \<Rightarrow> 'val"
 
 text \<open>A mode state maps modes to the set of variables for which the
   given mode is set.\<close>
 type_synonym 'var Mds = "Mode \<Rightarrow> 'var set"
 
 text \<open>Local configurations:\<close>
 type_synonym ('com, 'var, 'val) LocalConf = "('com \<times> 'var Mds) \<times> ('var, 'val) Mem"
 
 text \<open>Global configurations:\<close>
 type_synonym ('com, 'var, 'val) GlobalConf = "('com \<times> 'var Mds) list \<times> ('var, 'val) Mem"
 
 text \<open>A locale to fix various parametric components in Mantel et. al, and assumptions
   about them:\<close>
 locale sifum_security =
   fixes dma :: "'Var \<Rightarrow> Sec"
   fixes stop :: "'Com"
   fixes eval :: "('Com, 'Var, 'Val) LocalConf rel"
   fixes some_val :: "'Val"
   fixes some_val' :: "'Val"
   assumes stop_no_eval: "\<not> ((((stop, mds), mem), ((c', mds'), mem')) \<in> eval)"
   assumes deterministic: "\<lbrakk> (lc, lc') \<in> eval; (lc, lc'') \<in> eval \<rbrakk> \<Longrightarrow> lc' = lc''"
   assumes finite_memory: "finite {(x::'Var). True}"
   assumes different_values: "some_val \<noteq> some_val'"
 
 end