diff --git a/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy b/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
--- a/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
+++ b/thys/Functional_Ordered_Resolution_Prover/IsaFoR_Term.thy
@@ -1,634 +1,634 @@
 (*  Title:       Integration of IsaFoR Terms
     Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2014
     Author:      Anders Schlichtkrull <andschl at dtu.dk>, 2017
     Maintainer:  Anders Schlichtkrull <andschl at dtu.dk>
 *)
 
 section \<open>Integration of \textsf{IsaFoR} Terms\<close>
 
 text \<open>
 This theory implements the abstract interface for atoms and substitutions using
 the \textsf{IsaFoR} library (part of the AFP entry \<open>First_Order_Terms\<close>).
 \<close>
 
 theory IsaFoR_Term
   imports
     Deriving.Derive
     Ordered_Resolution_Prover.Abstract_Substitution
     First_Order_Terms.Unification
     First_Order_Terms.Subsumption
     "HOL-Cardinals.Wellorder_Extension"
     Open_Induction.Restricted_Predicates
 begin
 
 hide_const (open) mgu
 
 abbreviation subst_apply_literal ::
   "('f, 'v) term literal \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term literal" (infixl "\<cdot>lit" 60) where
   "L \<cdot>lit \<sigma> \<equiv> map_literal (\<lambda>A. A \<cdot> \<sigma>) L"
 
 definition subst_apply_clause ::
   "('f, 'v) term clause \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) term clause" (infixl "\<cdot>cls" 60) where
   "C \<cdot>cls \<sigma> = image_mset (\<lambda>L. L \<cdot>lit \<sigma>) C"
 
 abbreviation vars_lit :: "('f, 'v) term literal \<Rightarrow> 'v set" where
   "vars_lit L \<equiv> vars_term (atm_of L)"
 
 definition vars_clause :: "('f, 'v) term clause \<Rightarrow> 'v set" where
   "vars_clause C = Union (set_mset (image_mset vars_lit C))"
 
 definition vars_clause_list :: "('f, 'v) term clause list \<Rightarrow> 'v set" where
   "vars_clause_list Cs = Union (vars_clause ` set Cs) "
 
 definition vars_partitioned :: "('f,'v) term clause list \<Rightarrow> bool" where
   "vars_partitioned Cs \<longleftrightarrow>
    (\<forall>i < length Cs. \<forall>j < length Cs. i \<noteq> j \<longrightarrow> (vars_clause (Cs ! i) \<inter> vars_clause (Cs ! j)) = {})"
 
 lemma vars_clause_mono: "S \<subseteq># C \<Longrightarrow> vars_clause S \<subseteq> vars_clause C"
   unfolding vars_clause_def by auto
 
 interpretation substitution_ops "(\<cdot>)" Var "(\<circ>\<^sub>s)" .
 
 lemma is_ground_atm_is_ground_on_var:
   assumes "is_ground_atm (A \<cdot> \<sigma>)" and "v \<in> vars_term A"
   shows "is_ground_atm (\<sigma> v)"
 using assms proof (induction A)
   case (Var x)
   then show ?case by auto
 next
   case (Fun f ts)
   then show ?case unfolding is_ground_atm_def
     by auto
 qed
 
 lemma is_ground_lit_is_ground_on_var:
   assumes ground_lit: "is_ground_lit (subst_lit L \<sigma>)" and v_in_L: "v \<in> vars_lit L"
   shows "is_ground_atm (\<sigma> v)"
 proof -
   let ?A = "atm_of L"
   from v_in_L have A_p: "v \<in> vars_term ?A"
     by auto
   then have "is_ground_atm (?A \<cdot> \<sigma>)"
     using ground_lit unfolding is_ground_lit_def by auto
   then show ?thesis
     using A_p is_ground_atm_is_ground_on_var by metis
 qed
 
 lemma is_ground_cls_is_ground_on_var:
   assumes
     ground_clause: "is_ground_cls (subst_cls C \<sigma>)" and
     v_in_C: "v \<in> vars_clause C"
   shows "is_ground_atm (\<sigma> v)"
 proof -
   from v_in_C obtain L where L_p: "L \<in># C" "v \<in> vars_lit L"
     unfolding vars_clause_def by auto
   then have "is_ground_lit (subst_lit L \<sigma>)"
     using ground_clause unfolding is_ground_cls_def subst_cls_def by auto
   then show ?thesis
     using L_p is_ground_lit_is_ground_on_var by metis
 qed
 
 lemma is_ground_cls_list_is_ground_on_var:
   assumes ground_list: "is_ground_cls_list (subst_cls_list Cs \<sigma>)"
     and v_in_Cs: "v \<in> vars_clause_list Cs"
   shows "is_ground_atm (\<sigma> v)"
 proof -
   from v_in_Cs obtain C where C_p: "C \<in> set Cs" "v \<in> vars_clause C"
     unfolding vars_clause_list_def by auto
   then have "is_ground_cls (subst_cls C \<sigma>)"
     using ground_list unfolding is_ground_cls_list_def subst_cls_list_def by auto
   then show ?thesis
     using C_p is_ground_cls_is_ground_on_var by metis
 qed
 
 lemma same_on_vars_lit:
   assumes "\<forall>v \<in> vars_lit L. \<sigma> v = \<tau> v"
   shows "subst_lit L \<sigma> = subst_lit L \<tau>"
   using assms
 proof (induction L)
   case (Pos x)
   then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
     using term_subst_eq by metis+
   then show ?case
     unfolding subst_lit_def using Pos by auto
 next
   case (Neg x)
   then have "\<forall>v \<in> vars_term x. \<sigma> v = \<tau> v \<Longrightarrow> subst_atm_abbrev x \<sigma> = subst_atm_abbrev x \<tau>"
     using term_subst_eq by metis+
   then show ?case
     unfolding subst_lit_def using Neg by auto
 qed
 
 lemma in_list_of_mset_in_S:
   assumes "i < length (list_of_mset S)"
   shows "list_of_mset S ! i \<in># S"
 proof -
   from assms have "list_of_mset S ! i \<in> set (list_of_mset S)"
     by auto
   then have "list_of_mset S ! i \<in># mset (list_of_mset S)"
     by (meson in_multiset_in_set)
   then show ?thesis
     by auto
 qed
 
 lemma same_on_vars_clause:
   assumes "\<forall>v \<in> vars_clause S. \<sigma> v = \<tau> v"
   shows "subst_cls S \<sigma> = subst_cls S \<tau>"
   by (smt assms image_eqI image_mset_cong2 mem_simps(9) same_on_vars_lit set_image_mset
       subst_cls_def vars_clause_def)
 
 lemma vars_partitioned_var_disjoint:
   assumes "vars_partitioned Cs"
   shows "var_disjoint Cs"
   unfolding var_disjoint_def
 proof (intro allI impI)
   fix \<sigma>s :: \<open>('b \<Rightarrow> ('a, 'b) term) list\<close>
   assume "length \<sigma>s = length Cs"
   with assms[unfolded vars_partitioned_def] Fun_More.fun_merge[of "map vars_clause Cs" "nth \<sigma>s"]
   obtain \<sigma> where
     \<sigma>_p: "\<forall>i < length (map vars_clause Cs). \<forall>x \<in> map vars_clause Cs ! i. \<sigma> x = (\<sigma>s ! i) x"
     by auto
   have "\<forall>i < length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
   proof (rule, rule, rule, rule)
     fix i :: nat and S :: "('a, 'b) term literal multiset"
     assume
       "i < length Cs" and
       "S \<subseteq># Cs ! i"
     then have "\<forall>v \<in> vars_clause S. (\<sigma>s ! i) v = \<sigma> v"
       using vars_clause_mono[of S "Cs ! i"] \<sigma>_p by auto
     then show "subst_cls S (\<sigma>s ! i) = subst_cls S \<sigma>"
       using same_on_vars_clause by auto
   qed
   then show "\<exists>\<tau>. \<forall>i<length Cs. \<forall>S. S \<subseteq># Cs ! i \<longrightarrow> subst_cls S (\<sigma>s ! i) = subst_cls S \<tau>"
     by auto
 qed
 
 lemma vars_in_instance_in_range_term:
   "vars_term (subst_atm_abbrev A \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
   by (induction A) auto
 
 lemma vars_in_instance_in_range_lit: "vars_lit (subst_lit L \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
 proof (induction L)
   case (Pos A)
   have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
     using vars_in_instance_in_range_term[of A \<sigma>] by blast
   then show ?case by auto
 next
   case (Neg A)
   have "vars_term (A \<cdot> \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
     using vars_in_instance_in_range_term[of A \<sigma>] by blast
   then show ?case by auto
 qed
 
 lemma vars_in_instance_in_range_cls:
   "vars_clause (subst_cls C \<sigma>) \<subseteq> Union (image vars_term (range \<sigma>))"
   unfolding vars_clause_def subst_cls_def using vars_in_instance_in_range_lit[of _ \<sigma>] by auto
 
 primrec renamings_apart :: "('f, nat) term clause list \<Rightarrow> (('f, nat) subst) list" where
   "renamings_apart [] = []"
 | "renamings_apart (C # Cs) =
    (let \<sigma>s = renamings_apart Cs in
       (\<lambda>v. Var (v + Max (vars_clause_list (subst_cls_lists Cs \<sigma>s) \<union> {0}) + 1)) # \<sigma>s)"
 
 definition var_map_of_subst :: "('f, nat) subst \<Rightarrow> nat \<Rightarrow> nat" where
   "var_map_of_subst \<sigma> v = the_Var (\<sigma> v)"
 
 lemma len_renamings_apart: "length (renamings_apart Cs) = length Cs"
   by (induction Cs) (auto simp: Let_def)
 
 lemma renamings_apart_is_Var: "\<forall>\<sigma> \<in> set (renamings_apart Cs). \<forall>x. is_Var (\<sigma> x)"
   by (induction Cs) (auto simp: Let_def)
 
 lemma renamings_apart_inj: "\<forall>\<sigma> \<in> set (renamings_apart Cs). inj \<sigma>"
 proof (induction Cs)
   case (Cons a Cs)
   then have "inj (\<lambda>v. Var (Suc (v + Max (vars_clause_list
                (subst_cls_lists Cs (renamings_apart Cs)) \<union> {0}))))"
     by (meson add_right_imp_eq injI nat.inject term.inject(1))
   then show ?case
     using Cons by (auto simp: Let_def)
 qed auto
 
 lemma finite_vars_clause[simp]: "finite (vars_clause x)"
   unfolding vars_clause_def by auto
 
 lemma finite_vars_clause_list[simp]: "finite (vars_clause_list Cs)"
   unfolding vars_clause_list_def by (induction Cs) auto
 
 lemma Suc_Max_notin_set: "finite X \<Longrightarrow> Suc (v + Max (insert 0 X)) \<notin> X"
   by (metis Max.boundedE Suc_n_not_le_n empty_iff finite.insertI le_add2 vimageE vimageI
       vimage_Suc_insert_0)
 
 lemma vars_partitioned_Nil[simp]: "vars_partitioned []"
   unfolding vars_partitioned_def by auto
 
 lemma subst_cls_lists_Nil[simp]: "subst_cls_lists Cs [] = []"
   unfolding subst_cls_lists_def by auto
 
 lemma vars_clause_hd_partitioned_from_tl:
   assumes "Cs \<noteq>[]"
   shows "vars_clause (hd (subst_cls_lists Cs (renamings_apart Cs)))
     \<inter> vars_clause_list (tl (subst_cls_lists Cs (renamings_apart Cs))) = {}"
   using assms
 proof (induction Cs)
   case (Cons C Cs)
   define \<sigma>' :: "nat \<Rightarrow> nat"
     where "\<sigma>' = (\<lambda>v. (Suc (v + Max ((vars_clause_list (subst_cls_lists Cs
                         (renamings_apart Cs))) \<union> {0}))))"
   define \<sigma> :: "nat \<Rightarrow> ('a, nat) term"
     where "\<sigma> = (\<lambda>v. Var (\<sigma>' v))"
 
-  have "vars_clause (subst_cls C \<sigma>) \<subseteq> UNION (range \<sigma>) vars_term"
+  have "vars_clause (subst_cls C \<sigma>) \<subseteq> \<Union> (vars_term ` range \<sigma>)"
     using vars_in_instance_in_range_cls[of C "hd (renamings_apart (C # Cs))"] \<sigma>_def \<sigma>'_def
     by (auto simp: Let_def)
-  moreover have "UNION (range \<sigma>) vars_term
+  moreover have "\<Union> (vars_term ` range \<sigma>)
     \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
   proof -
     have "range \<sigma>' \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
       unfolding \<sigma>'_def using Suc_Max_notin_set by auto
     then show ?thesis
       unfolding \<sigma>_def \<sigma>'_def by auto
   qed
   ultimately have "vars_clause (subst_cls C \<sigma>)
      \<inter> vars_clause_list (subst_cls_lists Cs (renamings_apart Cs)) = {}"
     by auto
   then show ?case
     unfolding \<sigma>_def \<sigma>'_def unfolding subst_cls_lists_def
     by (simp add: Let_def subst_cls_lists_def)
 qed auto
 
 lemma vars_partitioned_renamings_apart: "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
 proof (induction Cs)
   case (Cons C Cs)
   {
     fix i :: nat and j :: nat
     assume ij:
       "i < Suc (length Cs)"
       "j < i"
     have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
         vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
         {}"
     proof (cases i; cases j)
       fix j' :: nat
       assume i'j':
         "i = 0"
         "j = Suc j'"
       then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
         vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
         {}"
         using ij by auto
     next
       fix i' :: nat
       assume i'j':
         "i = Suc i'"
         "j = 0"
       have disjoin_C_Cs: "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
         vars_clause_list ((subst_cls_lists Cs (renamings_apart Cs))) = {}"
         using vars_clause_hd_partitioned_from_tl[of "C # Cs"]
         by (simp add: Let_def subst_cls_lists_def)
       {
         fix x
         assume asm: "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
         then have "(subst_cls_lists Cs (renamings_apart Cs) ! i')
           \<in> set (subst_cls_lists Cs (renamings_apart Cs))"
           using i'j' ij unfolding subst_cls_lists_def
           by (metis Suc_less_SucD length_map len_renamings_apart length_zip min_less_iff_conj
               nth_mem)
         moreover from asm have
           "x \<in> vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')"
           using i'j' ij
           unfolding subst_cls_lists_def by simp
         ultimately have "\<exists>D \<in> set (subst_cls_lists Cs (renamings_apart Cs)). x \<in> vars_clause D"
             by auto
       }
       then have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i')
         \<subseteq> Union (set (map vars_clause ((subst_cls_lists Cs (renamings_apart Cs)))))"
         by auto
       then have "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! 0) \<inter>
         vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') =
         {}" using disjoin_C_Cs unfolding vars_clause_list_def by auto
       moreover
       have "subst_cls_lists Cs (renamings_apart Cs) ! i' =
         subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i"
         using i'j' ij unfolding subst_cls_lists_def by (simp add: Let_def)
       ultimately
       show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
         vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
         {}"
         using i'j' by (simp add: Int_commute)
     next
       fix i' :: nat and j' :: nat
       assume i'j':
         "i = Suc i'"
         "j = Suc j'"
       have "i'<length (subst_cls_lists Cs (renamings_apart Cs))"
         using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
       moreover
       have "j'<length (subst_cls_lists Cs (renamings_apart Cs))"
         using ij i'j' unfolding subst_cls_lists_def by (auto simp: len_renamings_apart)
       moreover
       have "i' \<noteq> j'"
         using \<open>i = Suc i'\<close> \<open>j = Suc j'\<close> ij by blast
       ultimately
       have "vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! i') \<inter>
           vars_clause (subst_cls_lists Cs (renamings_apart Cs) ! j') =
           {}"
         using Cons unfolding vars_partitioned_def by auto
       then show "vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
         vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
         {}"
         unfolding i'j'
         by (simp add: subst_cls_lists_def Let_def)
     next
       assume
         \<open>i = 0\<close> and
         \<open>j = 0\<close>
       then show \<open>vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! i) \<inter>
         vars_clause (subst_cls_lists (C # Cs) (renamings_apart (C # Cs)) ! j) =
         {}\<close> using ij by auto
     qed
   }
   then show ?case
     unfolding vars_partitioned_def
     by (metis (no_types, lifting) Int_commute Suc_lessI len_renamings_apart length_map
         length_nth_simps(2) length_zip min.idem nat.inject not_less_eq subst_cls_lists_def)
 qed auto
 
 interpretation substitution "(\<cdot>)" "Var :: _ \<Rightarrow> ('f, nat) term" "(\<circ>\<^sub>s)" renamings_apart "Fun undefined"
 proof (standard)
   show "\<And>A. A \<cdot> Var = A"
     by auto
 next
   show "\<And>A \<tau> \<sigma>. A \<cdot> \<tau> \<circ>\<^sub>s \<sigma> = A \<cdot> \<tau> \<cdot> \<sigma>"
     by auto
 next
   show "\<And>\<sigma> \<tau>. (\<And>A. A \<cdot> \<sigma> = A \<cdot> \<tau>) \<Longrightarrow> \<sigma> = \<tau>"
     by (simp add: subst_term_eqI)
 next
   fix C :: "('f, nat) term clause"
   fix \<sigma>
   assume "is_ground_cls (subst_cls C \<sigma>)"
   then have ground_atms_\<sigma>: "\<And>v. v \<in> vars_clause C \<Longrightarrow> is_ground_atm (\<sigma> v)"
     by (meson is_ground_cls_is_ground_on_var)
 
   define some_ground_trm :: "('f, nat) term" where "some_ground_trm = (Fun undefined [])"
   have ground_trm: "is_ground_atm some_ground_trm"
     unfolding is_ground_atm_def some_ground_trm_def by auto
   define \<tau> where "\<tau> = (\<lambda>v. if v \<in> vars_clause C then \<sigma> v else some_ground_trm)"
   then have \<tau>_\<sigma>: "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
     unfolding \<tau>_def by auto
 
   have all_ground_\<tau>: "is_ground_atm (\<tau> v)" for v
   proof (cases "v \<in> vars_clause C")
     case True
     then show ?thesis
       using ground_atms_\<sigma> \<tau>_\<sigma> by auto
   next
     case False
     then show ?thesis
       unfolding \<tau>_def using ground_trm by auto
   qed
   have "is_ground_subst \<tau>"
     unfolding is_ground_subst_def
   proof
     fix A
     show "is_ground_atm (subst_atm_abbrev A \<tau>)"
     proof (induction A)
       case (Var v)
       then show ?case using all_ground_\<tau> by auto
     next
       case (Fun f As)
       then show ?case using all_ground_\<tau>
         by (simp add: is_ground_atm_def)
     qed
   qed
   moreover have "\<forall>v \<in> vars_clause C. \<sigma> v = \<tau> v"
     using \<tau>_\<sigma> unfolding vars_clause_list_def
     by blast
   then have "subst_cls C \<sigma> = subst_cls C \<tau>"
     using same_on_vars_clause by auto
   ultimately show "\<exists>\<tau>. is_ground_subst \<tau> \<and> subst_cls C \<tau> = subst_cls C \<sigma>"
     by auto
 next
   fix Cs :: "('f, nat) term clause list"
   show "length (renamings_apart Cs) = length Cs"
     using len_renamings_apart by auto
 next
   fix Cs :: "('f, nat) term clause list"
   fix \<rho> ::  "nat \<Rightarrow> ('f, nat) Term.term"
   assume \<rho>_renaming: "\<rho> \<in> set (renamings_apart Cs)"
   {
     have inj_is_renaming:
       "\<And>\<sigma> :: ('f, nat) subst. (\<And>x. is_Var (\<sigma> x)) \<Longrightarrow> inj \<sigma> \<Longrightarrow> is_renaming \<sigma>"
     proof -
       fix \<sigma> :: "('f, nat) subst"
       fix x
       assume is_var_\<sigma>: "\<And>x. is_Var (\<sigma> x)"
       assume inj_\<sigma>: "inj \<sigma>"
       define \<sigma>' where "\<sigma>' = var_map_of_subst \<sigma>"
       have \<sigma>: "\<sigma> = Var \<circ> \<sigma>'"
         unfolding \<sigma>'_def var_map_of_subst_def using is_var_\<sigma> by auto
 
       from is_var_\<sigma> inj_\<sigma> have "inj \<sigma>'"
         unfolding is_renaming_def unfolding subst_domain_def inj_on_def \<sigma>'_def var_map_of_subst_def
          by (metis term.collapse(1))
       then have "inv \<sigma>' \<circ> \<sigma>' = id"
         using inv_o_cancel[of \<sigma>'] by simp
       then have "Var \<circ> (inv \<sigma>' \<circ> \<sigma>') = Var"
         by simp
       then have "\<forall>x. (Var \<circ> (inv \<sigma>' \<circ> \<sigma>')) x = Var x"
         by metis
       then have "\<forall>x. ((Var \<circ> \<sigma>') \<circ>\<^sub>s (Var \<circ> (inv \<sigma>'))) x = Var x"
         unfolding subst_compose_def by auto
       then have "\<sigma> \<circ>\<^sub>s (Var \<circ> (inv \<sigma>')) = Var"
         using \<sigma> by auto
       then show "is_renaming \<sigma>"
         unfolding is_renaming_def by blast
     qed
     then have "\<forall>\<sigma> \<in> (set (renamings_apart Cs)). is_renaming \<sigma>"
       using renamings_apart_is_Var renamings_apart_inj by blast
   }
   then show "is_renaming \<rho>"
     using \<rho>_renaming by auto
 next
   fix Cs :: "('f, nat) term clause list"
   have "vars_partitioned (subst_cls_lists Cs (renamings_apart Cs))"
     using vars_partitioned_renamings_apart by auto
   then show "var_disjoint (subst_cls_lists Cs (renamings_apart Cs))"
     using vars_partitioned_var_disjoint by auto
 next
   show "\<And>\<sigma> As Bs. Fun undefined As \<cdot> \<sigma> = Fun undefined Bs \<longleftrightarrow> map (\<lambda>A. A \<cdot> \<sigma>) As = Bs"
     by simp
 next
   show "wfP (strictly_generalizes_atm :: ('f, 'v) term \<Rightarrow> _ \<Rightarrow> _)"
     unfolding wfP_def
     by (rule wf_subset[OF wf_subsumes])
       (auto simp: strictly_generalizes_atm_def generalizes_atm_def term_subsumable.subsumes_def
         subsumeseq_term.simps)
 qed
 
 fun pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
   "pairs (x # y # xs) = (x, y) # pairs (y # xs)" |
   "pairs _ = []"
 
 derive compare "term"
 derive compare "literal"
 
 lemma class_linorder_compare: "class.linorder (le_of_comp compare) (lt_of_comp compare)"
   apply standard
       apply (simp_all add: lt_of_comp_def le_of_comp_def split: order.splits)
      apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
     apply (metis comparator_compare comparator_def order.distinct(5))
    apply (metis comparator.sym comparator_compare invert_order.simps(1) order.distinct(5))
   by (metis comparator.sym comparator_compare invert_order.simps(2) order.distinct(5))
 
 context begin
 interpretation compare_linorder: linorder
   "le_of_comp compare"
   "lt_of_comp compare"
   by (rule class_linorder_compare)
 
 definition Pairs where
   "Pairs AAA = concat (compare_linorder.sorted_list_of_set
      ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))"
 
 lemma unifies_all_pairs_iff:
   "(\<forall>p \<in> set (pairs xs). fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>) \<longleftrightarrow> (\<forall>a \<in> set xs. \<forall>b \<in> set xs. a \<cdot> \<sigma> = b \<cdot> \<sigma>)"
 proof (induct xs rule: pairs.induct)
   case (1 x y xs)
   then show ?case
     unfolding pairs.simps list.set ball_Un ball_simps simp_thms fst_conv snd_conv by metis
 qed simp_all
 
 lemma in_pair_in_set:
   assumes "(A,B) \<in> set ((pairs As))"
   shows "A \<in> set As \<and> B \<in> set As"
   using assms
 proof (induction As)
   case (Cons A As)
   note Cons_outer = this
   show ?case
   proof (cases As)
     case Nil
     then show ?thesis
       using Cons_outer by auto
   next
     case (Cons B As')
     then show ?thesis using Cons_outer by auto
   qed
 qed auto
 
 lemma in_pairs_sorted_list_of_set_in_set:
   assumes
     "finite AAA"
     "\<forall>AA \<in> AAA. finite AA"
     "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA" and
     "(A :: _ :: compare, B) \<in> set AB_pairs"
   shows "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
 proof -
   from assms have "AB_pairs \<in> (pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA"
     by auto
   then obtain AA where
     AA_p: "AA \<in> AAA \<and> (pairs \<circ> compare_linorder.sorted_list_of_set) AA = AB_pairs"
     by auto
   have "(A, B) \<in> set (pairs (compare_linorder.sorted_list_of_set AA))"
     using AA_p[] assms(4) by auto
   then have "A \<in> set (compare_linorder.sorted_list_of_set AA)" and
     "B \<in> set (compare_linorder.sorted_list_of_set AA)"
     using in_pair_in_set[of A] by auto
   then show ?thesis
     using assms(2) AA_p by auto
 qed
 
 lemma unifiers_Pairs:
   assumes
     "finite AAA" and
     "\<forall>AA \<in> AAA. finite AA"
   shows "unifiers (set (Pairs AAA)) = {\<sigma>. is_unifiers \<sigma> AAA}"
 proof (rule; rule)
   fix \<sigma> :: "('a, 'b) subst"
   assume asm: "\<sigma> \<in> unifiers (set (Pairs AAA))"
   have "\<And>AA. AA \<in> AAA \<Longrightarrow> card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
   proof -
     fix AA :: "('a, 'b) term set"
     assume asm': "AA \<in> AAA"
     then have "\<forall>p \<in> set (pairs (compare_linorder.sorted_list_of_set AA)).
       subst_atm_abbrev (fst p) \<sigma> = subst_atm_abbrev (snd p) \<sigma>"
       using assms asm unfolding Pairs_def by auto
     then have "\<forall>A \<in> AA. \<forall>B \<in> AA. subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
       using assms asm' unfolding unifies_all_pairs_iff
       using compare_linorder.sorted_list_of_set by blast
     then show "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
       by (smt imageE card.empty card_Suc_eq card_mono finite.intros(1) finite_insert le_SucI
            singletonI subsetI)
   qed
   then show "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"
     using assms by (auto simp: is_unifiers_def is_unifier_def subst_atms_def)
 next
   fix \<sigma> :: "('a, 'b) subst"
   assume asm: "\<sigma> \<in> {\<sigma>. is_unifiers \<sigma> AAA}"
 
   {
     fix AB_pairs A B
     assume
       "AB_pairs \<in> set (compare_linorder.sorted_list_of_set
          ((pairs \<circ> compare_linorder.sorted_list_of_set) ` AAA))" and
       "(A, B) \<in> set AB_pairs"
     then have "\<exists>AA. AA \<in> AAA \<and> A \<in> AA \<and> B \<in> AA"
       using assms by (simp add: in_pairs_sorted_list_of_set_in_set)
     then obtain AA where
      a: "AA \<in> AAA" "A \<in> AA" "B \<in> AA"
       by blast
     from a assms asm have card_AA_\<sigma>: "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) \<le> Suc 0"
       unfolding is_unifiers_def is_unifier_def subst_atms_def by auto
     have "subst_atm_abbrev A \<sigma> = subst_atm_abbrev B \<sigma>"
     proof (cases "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = Suc 0")
       case True
       moreover
       have "subst_atm_abbrev A \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
         using a assms asm card_AA_\<sigma> by auto
       moreover
       have "subst_atm_abbrev B \<sigma> \<in> AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>"
         using a assms asm card_AA_\<sigma> by auto
       ultimately
       show ?thesis
         using a assms asm card_AA_\<sigma> by (metis (no_types, lifting) card_Suc_eq singletonD)
     next
       case False
       then have "card (AA \<cdot>\<^sub>s\<^sub>e\<^sub>t \<sigma>) = 0"
         using a assms asm card_AA_\<sigma>
         by arith
       then show ?thesis
         using a assms asm card_AA_\<sigma> by auto
     qed
   }
   then show "\<sigma> \<in> unifiers (set (Pairs AAA))"
     unfolding Pairs_def unifiers_def by auto
 qed
 
 end
 
 definition "mgu_sets AAA = map_option subst_of (unify (Pairs AAA) [])"
 
 interpretation mgu "(\<cdot>)" "Var :: _ \<Rightarrow> ('f :: compare, nat) term" "(\<circ>\<^sub>s)" "Fun undefined"
   renamings_apart mgu_sets
 proof
   fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
   assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "mgu_sets AAA = Some \<sigma>"
   then have "is_imgu \<sigma> (set (Pairs AAA))"
     using unify_sound unfolding mgu_sets_def by blast
   then show "is_mgu \<sigma> AAA"
     unfolding is_imgu_def is_mgu_def unifiers_Pairs[OF fin] by auto
 next
   fix AAA :: "('a :: compare, nat) term set set" and \<sigma> :: "('a, nat) subst"
   assume fin: "finite AAA" "\<forall>AA \<in> AAA. finite AA" and "is_unifiers \<sigma> AAA"
   then have "\<sigma> \<in> unifiers (set (Pairs AAA))"
     unfolding is_mgu_def unifiers_Pairs[OF fin] by auto
   then show "\<exists>\<tau>. mgu_sets AAA = Some \<tau>"
     using unify_complete unfolding mgu_sets_def by blast
 qed
 
 derive linorder prod
 derive linorder list
 
 end
diff --git a/thys/Graph_Saturation/CombinedCorrectness.thy b/thys/Graph_Saturation/CombinedCorrectness.thy
--- a/thys/Graph_Saturation/CombinedCorrectness.thy
+++ b/thys/Graph_Saturation/CombinedCorrectness.thy
@@ -1,234 +1,234 @@
 section \<open>Combined correctness\<close>
 text \<open>This section does not correspond to any theorems in the paper.
       However, the main correctness proof is not a theorem in the paper either.
       As the paper sets out to prove that we can decide entailment and consistency,
       this file shows how to combine the results so far and indeed establish those properties. \<close>
 theory CombinedCorrectness
   imports GraphRewriting StandardRules
 begin
 
 (* a somewhat concrete function to get the model if one exists *)
 definition the_model where
 "the_model C Rs
-  \<equiv> let L = fst ` UNION Rs (edges o snd) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C;
+  \<equiv> let L = fst ` \<Union> ((edges o snd) ` Rs) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C;
         Rules = Rs \<union> (standard_rules C L);
         sel = non_constructive_selector Rules 
      in the_lcg sel Rules (0,{})"
 
 definition entailment_model where
 "entailment_model C Rs init
-  \<equiv> let L = fst ` UNION Rs (edges o snd) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C \<union> fst ` edges init;
+  \<equiv> let L = fst ` \<Union> ((edges o snd) ` Rs) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C \<union> fst ` edges init;
         Rules = Rs \<union> (standard_rules C L);
         sel = non_constructive_selector Rules 
      in the_lcg sel Rules (card (vertices init),edges init)"
 
 abbreviation check_consistency where
   "check_consistency C Rs \<equiv> getRel S_Bot (the_model C Rs) = {}"
 
 abbreviation check_entailment where
   "check_entailment C Rs R \<equiv> 
      let mdl = entailment_model C Rs (translation (fst R))
      in (0,1) \<in> :mdl:\<lbrakk>snd R\<rbrakk> \<or> getRel S_Bot mdl \<noteq> {}"
 
 definition transl_rules where
-  "transl_rules T = UNION T (\<lambda> (x,y). {(translation x, translation (A_Int x y)),(translation y, translation (A_Int y x))})"
+  "transl_rules T = (\<Union>(x, y)\<in>T. {(translation x, translation (A_Int x y)), (translation y, translation (A_Int y x))})"
 
 lemma gr_transl_rules:
   "x \<in> transl_rules T \<Longrightarrow> graph_rule x"
   using graph_rule_translation unfolding transl_rules_def by blast
 term entails
 
 lemma check_consistency:
   assumes "finite T" "finite C"
   shows "check_consistency C (transl_rules T) \<longleftrightarrow> consistent (t::nat itself) C T"
    (is "?lhs = ?rhs")
 proof -
   from assms(1) have fin_t:"finite (transl_rules T)" unfolding transl_rules_def by fast
   define L where
-    "L = fst ` UNION (transl_rules T) (edges \<circ> snd) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C"
-  have "finite (UNION (transl_rules T) (edges \<circ> snd))" using fin_t gr_transl_rules by auto
+    "L = fst ` \<Union> ((edges \<circ> snd) ` transl_rules T) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C"
+  have "finite (\<Union> ((edges \<circ> snd) ` transl_rules T))" using fin_t gr_transl_rules by auto
   hence fin_l:"finite L" unfolding L_def using assms(2) by auto
   define Rules where "Rules = transl_rules T \<union> standard_rules C L"
   hence fin_r:"finite Rules" using assms(2) fin_t fin_l unfolding standard_rules_def by auto
-  have incl_L:"fst ` UNION Rules (edges o snd) \<subseteq> L"
+  have incl_L:"fst ` (\<Union> ((edges o snd) ` Rules)) \<subseteq> L"
     unfolding L_def Rules_def by (auto elim:standard_rules_edges)
   have "\<forall>R\<in>transl_rules T. graph_rule R" using gr_transl_rules by blast
   moreover have "\<forall>R\<in> constant_rules C. graph_rule R" using constant_rules_graph_rule by auto
   moreover have "\<forall>R\<in> identity_rules L. graph_rule R" using identity_rules_graph_rule by auto
   moreover have "\<forall>R\<in> {top_rule S_Top,nonempty_rule}. graph_rule R" using are_rules(1,2) by fastforce
   ultimately have gr:"set_of_graph_rules Rules"
     unfolding set_of_graph_rules_def Rules_def ball_Un standard_rules_def
     by blast
   define sel where "sel = non_constructive_selector Rules"
   hence sel:"valid_selector Rules sel" using gr non_constructive_selector by auto
   define cfg where "cfg = the_lcg sel Rules (0, {})"
   have cfg:"cfg = the_model C (transl_rules T)"
     unfolding cfg_def sel_def Rules_def L_def the_model_def Let_def..
   have cfg_c:"least_consequence_graph TYPE('a + nat) Rules (graph_of (0,{})) cfg"
     unfolding cfg_def
     by (rule lcg_through_make_step[OF fin_r gr _ sel],auto)
   hence cfg_sdt:"maintainedA (standard_rules C L) cfg"
     and cfg_g: "graph cfg"
     and cfg_l:"least TYPE('a + nat) Rules (graph_of (0, {})) cfg"
     and cfg_m:"r \<in> transl_rules T \<Longrightarrow> maintained r cfg" for r
     unfolding Rules_def least_consequence_graph_def by auto
   have cfg_lbl:"fst ` edges cfg \<subseteq> L" 
     unfolding cfg_def by (auto intro!: the_lcg_edges[OF sel incl_L])
   have d1: "?lhs \<Longrightarrow> ?rhs" proof -
     assume ?lhs
     from maintained_standard_noconstants[OF cfg_sdt cfg_g cfg_lbl this[folded cfg]]
     obtain G :: "('a Standard_Constant, 'a + nat) labeled_graph"
       where G_std:"standard' C G"
       and m:"maintained r cfg \<Longrightarrow> maintained r G"
       for r :: "('a Standard_Constant, nat) Graph_PreRule"
       by blast
     hence g:"graph G" unfolding standard_def by auto
     have "(a,b)\<in>T \<Longrightarrow> G \<Turnstile> (a,b)" for a b proof(subst eq_as_subsets,standard)
       assume a:"(a,b)\<in>T"
       from a cfg_m[unfolded transl_rules_def,THEN m]
       show "G \<Turnstile> a \<sqsubseteq> b" by (subst maintained_holds_iff[OF g,symmetric]) blast
       from a cfg_m[unfolded transl_rules_def,THEN m]
       show "G \<Turnstile> b \<sqsubseteq> a" by (subst maintained_holds_iff[OF g,symmetric]) blast
     qed
     hence h:"(\<forall>S\<in>T. G \<Turnstile> S)" by auto
     with G_std show ?rhs unfolding model_def by blast
   qed
   have d2: "\<not> ?lhs \<Longrightarrow> ?rhs \<Longrightarrow> False" proof -
     assume "\<not> ?lhs"
     then obtain a b where ab:"(S_Bot,a,b) \<in> edges cfg"
       "a \<in> vertices cfg" "b \<in> vertices cfg"
       using cfg_g unfolding cfg getRel_def by auto
     assume ?rhs then obtain G :: "('a Standard_Constant, 'a + nat) labeled_graph"
       where G:"model C G T" by auto
     with model_def have std:"standard' C G" and holds:"\<forall>S\<in>T. G \<Turnstile> S" by fast+
     hence g:"graph G" unfolding standard_def by auto
     from maintained_holds_iff[OF g] holds
     have "maintainedA (transl_rules T) G" unfolding transl_rules_def by auto
     hence mnt:"maintainedA Rules G" unfolding Rules_def
       using standard_maintains_rules[OF std] by auto
     from consequence_graphI[OF _ _ g] gr[unfolded set_of_graph_rules_def] mnt
     have cg:"consequence_graph Rules G" by fast
     with cfg_l[unfolded least_def]
     have mtd:"maintained (graph_of (0, {}), cfg) G" by blast
     have "graph_homomorphism (fst (graph_of (0::nat, {}), cfg)) G {}"
       unfolding graph_homomorphism_def using g by auto
     with mtd maintained_def have "extensible (graph_of (0, {}), cfg) G {}" by auto
     then obtain g where "edges (map_graph g cfg) \<subseteq> edges G" "vertices cfg = Domain g"
       unfolding extensible_def graph_homomorphism_def2 graph_union_iff by auto
     hence "\<exists> a b. (S_Bot,a,b) \<in> edges G" using ab unfolding edge_preserving by auto
     thus False using std unfolding standard_def getRel_def by auto
   qed
   from d1 d2 show ?thesis by metis
 qed
 
 
 lemma check_entailment:
   assumes "finite T" "finite C"
   shows "check_entailment C (transl_rules T) S \<longleftrightarrow> entails (t::nat itself) C T (fst S, (A_Int (fst S) (snd S)))"
    (is "?lhs = ?rhs")
 proof -
   from assms(1) have fin_t:"finite (transl_rules T)" unfolding transl_rules_def by fast
   define R where "R = transl_rule S"
   define init where "init = (card (vertices (fst R)), edges (fst R))"
   have gi[intro]:"graph (graph_of init)" and init:"graph_of init = translation (fst S)"
     using verts_in_translation[of "fst S"] unfolding inv_translation_def init_def R_def by auto
   define Rs where "Rs = transl_rules T"
   define L where
-    "L = fst ` UNION Rs (edges \<circ> snd) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C \<union> fst ` edges (fst R)"
-  have "finite (UNION (transl_rules T) (edges \<circ> snd))" using fin_t gr_transl_rules by auto
+    "L = fst ` (\<Union> ((edges o snd) ` Rs)) \<union> {S_Bot,S_Top,S_Idt} \<union> S_Const ` C \<union> fst ` edges (fst R)"
+  have "finite (\<Union> ((edges \<circ> snd) ` transl_rules T))" using fin_t gr_transl_rules by auto
   hence fin_l:"finite L" unfolding L_def Rs_def R_def using assms(2) by auto
   have fin_t:"finite Rs" using fin_t Rs_def by auto
   define Rules where "Rules = Rs \<union> standard_rules C L"
   hence fin_r:"finite Rules" using assms(2) fin_t fin_l unfolding standard_rules_def by auto
-  have incl_L:"fst ` UNION Rules (edges o snd) \<subseteq> L" "fst ` snd init \<subseteq> L" 
+  have incl_L:"fst ` (\<Union> ((edges o snd) ` Rules)) \<subseteq> L" "fst ` snd init \<subseteq> L" 
     unfolding L_def Rules_def init_def by (auto elim:standard_rules_edges)
   have "\<forall>R\<in>transl_rules T. graph_rule R" using gr_transl_rules by blast
   moreover have "\<forall>R\<in> constant_rules C. graph_rule R" using constant_rules_graph_rule by auto
   moreover have "\<forall>R\<in> identity_rules L. graph_rule R" using identity_rules_graph_rule by auto
   moreover have "\<forall>R\<in> {top_rule S_Top,nonempty_rule}. graph_rule R" using are_rules(1,2) by fastforce
   ultimately have gr:"set_of_graph_rules Rules"
     unfolding set_of_graph_rules_def Rules_def ball_Un standard_rules_def Rs_def
     by blast
   define sel where "sel = non_constructive_selector Rules"
   hence sel:"valid_selector Rules sel" using gr non_constructive_selector by auto
   define cfg where "cfg = the_lcg sel Rules init"
   have cfg:"cfg = entailment_model C Rs (fst R)"
     unfolding cfg_def sel_def Rules_def L_def entailment_model_def Let_def init_def..
   have cfg_c:"least_consequence_graph TYPE('a + nat) Rules (graph_of init) cfg"
     unfolding cfg_def by (rule lcg_through_make_step[OF fin_r gr gi sel])
   hence cfg_sdt:"maintainedA (standard_rules C L) cfg"
     and cfg_g: "graph cfg"
     and cfg_l:"least TYPE('a + nat) Rules (graph_of init) cfg"
     and cfg_m:"r \<in> Rs \<Longrightarrow> maintained r cfg" for r
     unfolding Rules_def least_consequence_graph_def by auto
   have cfg_lbl:"fst ` edges cfg \<subseteq> L" unfolding cfg_def
     by (auto intro!: the_lcg_edges[OF sel incl_L])
   have "(0,1) \<in> :translation (fst S):\<lbrakk>fst S\<rbrakk>" by (fact translation_self)
   hence "(0,1) \<in> :graph_of init:\<lbrakk>fst S\<rbrakk>" unfolding init by auto
   from subgraph_semantics[OF _ this] cfg_l[unfolded least_def]
   have cfg_fst:"(0,1) \<in> :cfg:\<lbrakk>fst S\<rbrakk>" unfolding cfg_def by auto
   from semantics_in_vertices[OF cfg_g this]
   have cfg_01:"0 \<in> vertices cfg" "1 \<in> vertices cfg" "(0,1)\<in>vertices cfg\<times>vertices cfg" by auto
   have d1: "\<not> ?lhs \<Longrightarrow> ?rhs \<Longrightarrow> False" proof -
     assume "\<not> ?lhs"
     hence gr:"(0,1) \<notin> :cfg:\<lbrakk>snd S\<rbrakk>" "getRel S_Bot cfg = {}"
       unfolding entailment_model_def cfg R_def Rs_def Let_def by auto
     from maintained_standard_noconstants[OF cfg_sdt cfg_g cfg_lbl gr(2)]
     obtain G :: "('a Standard_Constant, 'a + nat) labeled_graph" and f g
       where fg:"G = map_graph_fn G (f \<circ> g)"
       and f:"G = map_graph_fn cfg f" "subgraph (map_graph_fn G g) cfg"
       and G_std:"standard' C G"
       and m:"\<And> r:: ('a Standard_Constant, nat) Graph_PreRule. maintained r cfg \<Longrightarrow> maintained r G"
       and e:"\<And> x y e. x \<in> vertices cfg \<Longrightarrow> y \<in> vertices cfg \<Longrightarrow> 
                           (g (f x), g (f y)) \<in> :map_graph_fn G g:\<lbrakk>e\<rbrakk> \<Longrightarrow> (x,y) \<in> :cfg:\<lbrakk>e\<rbrakk>"
       by clarify blast (* just blast also works, but clarify blast is much faster *)
     hence g:"graph G" unfolding standard_def by auto
     have "(a,b)\<in>T \<Longrightarrow> G \<Turnstile> (a,b)" for a b apply(subst eq_as_subsets)
       using cfg_m[unfolded transl_rules_def Rs_def,THEN m]
       unfolding maintained_holds_iff[OF g,symmetric] by blast
     hence h:"(\<forall>S\<in>T. G \<Turnstile> S)" by auto
     assume "?rhs"
     from this[unfolded entails_def model_def] G_std h have "G \<Turnstile> fst S \<sqsubseteq> snd S" by blast
     with cfg_fst cfg_g f(1) have "(f 0, f 1) \<in> :G:\<lbrakk>snd S\<rbrakk>" by auto
     then have "(g (f 0), g (f 1)) \<in> :map_graph_fn G g:\<lbrakk>snd S\<rbrakk>" using map_graph_in[OF g] by auto
     with e cfg_01(1,2) gr(1) show "False" by auto
   qed
   have "?lhs \<Longrightarrow> model C G T \<Longrightarrow> (a,b) \<in> :G:\<lbrakk>fst S\<rbrakk> \<Longrightarrow> (a,b) \<in> :G:\<lbrakk>snd S\<rbrakk>"
     for G :: "('a Standard_Constant, 'a + nat) labeled_graph" and a b proof -
     assume mod:"model C G T"
     from mod model_def have std:"standard' C G" and holds:"\<forall>S\<in>T. G \<Turnstile> S" by fast+
     hence g:"graph G" unfolding standard_def by auto
     with maintained_holds_iff[OF g] holds
     have "maintainedA Rs G" unfolding transl_rules_def Rs_def by auto
     hence mnt:"maintainedA Rules G" unfolding Rules_def
       using standard_maintains_rules[OF std] by auto
     from consequence_graphI[OF _ _ g] gr[unfolded set_of_graph_rules_def] mnt
     have cg:"consequence_graph Rules G" by fast
     with cfg_l[unfolded least_def] have mtd:"maintained (graph_of init, cfg) G" by auto
     assume ab:"(a,b) \<in> :G:\<lbrakk>fst S\<rbrakk>"
     hence abv:"a \<in> vertices G" "b \<in> vertices G" using semantics_in_vertices[OF g] by auto
     from ab translation[OF g] init
     obtain f where f:"graph_homomorphism (graph_of init) G f" "(0, a) \<in> f \<and> (1, b) \<in> f"
       by auto
     from maintainedD2[OF mtd f(1)] obtain g
       where g:"graph_homomorphism cfg G g" and "f \<subseteq> g" by blast
     with f have g01:"(0, a) \<in> g" "(1, b) \<in> g" by auto
     assume ?lhs
     then consider (maintained) "(0,1) \<in> :cfg:\<lbrakk>snd S\<rbrakk>" | (no_models) ":cfg:\<lbrakk>\<bottom>\<rbrakk> \<noteq> {}"
       using cfg_g unfolding cfg entailment_model_def Let_def Rs_def R_def by auto
     thus "(a,b) \<in> :G:\<lbrakk>snd S\<rbrakk>" proof(cases)
       case maintained
       from graph_homomorphism_semantics[OF g maintained g01] show ?thesis.
     next
       case no_models
       from graph_homomorphism_nonempty[OF g no_models]
       have "getRel S_Bot G \<noteq> {}" by auto
       hence False using std unfolding standard_def by auto
       thus ?thesis by auto
     qed
   qed
   hence d2:"?lhs \<Longrightarrow> ?rhs" unfolding entails_def by auto
   from d1 d2 show ?thesis by metis
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Graph_Saturation/GraphRewriting.thy b/thys/Graph_Saturation/GraphRewriting.thy
--- a/thys/Graph_Saturation/GraphRewriting.thy
+++ b/thys/Graph_Saturation/GraphRewriting.thy
@@ -1,552 +1,552 @@
 section \<open>Graph rewriting and saturation\<close>
 text \<open>Here we describe graph rewriting, again without connecting it to semantics.\<close>
 theory GraphRewriting
   imports RulesAndChains 
     "HOL-Library.Infinite_Set"
 begin
 
 (* Algorithm 1 on page 16 *)
 text \<open>To describe Algorithm 1, we give a single step instead of the recursive call.
 This allows us to reason about its effect without dealing with non-termination.
 We define a worklist, saying what work can be done.
 A valid selection needs to be made in order to ensure fairness.
 To do a step, we define the function extend, and use it in @{term make_step}.
 A function that always makes a valid selection is used in this step. \<close>
 
 abbreviation graph_of where
   "graph_of \<equiv> \<lambda> X. LG (snd X) {0..<fst X}"
 
 definition nextMax :: "nat set \<Rightarrow> nat"
   where
   "nextMax x \<equiv> if x = {} then 0 else Suc (Max x)"
 
 lemma nextMax_max[intro]:
   assumes "finite x" "v \<in> x"
   shows "v < nextMax x" "v \<le> nextMax x"
   using Max.coboundedI[OF assms] assms(2) unfolding nextMax_def by auto
 
 definition worklist :: "nat \<times> ('a \<times> nat \<times> nat) set
            \<Rightarrow> (('a, 'b) labeled_graph \<times> ('a, 'b) labeled_graph) set
               \<Rightarrow> (nat \<times> ('a, 'b) Graph_PreRule \<times> ('b \<times> nat) set) set" where
 "worklist G Rs \<equiv> let G = graph_of G
   in {(N,R,f). R\<in> Rs \<and> graph_homomorphism (fst R) G f \<and> N = nextMax (Range f)
                  \<and> \<not> extensible R G f }"
 
 definition valid_selection where
 "valid_selection Rs G R f \<equiv>
   let wl = worklist G Rs in
     (nextMax (Range f), R,f) \<in> wl \<and>
     (\<forall> (N,_) \<in> wl. N \<ge> nextMax (Range f)) \<and>
     graph_rule R"
 
 lemma valid_selection_exists:
   assumes "worklist G Rs \<noteq> {}"
           "set_of_graph_rules Rs"
   shows "\<exists>L R f. valid_selection Rs G R f"
 proof -
   define wl where "wl = worklist G Rs" hence wl_ne:"wl \<noteq> {}" using assms(1) by auto
   let ?N = "LEAST N. N \<in> Domain wl"
   from wl_ne have "\<exists> N. N \<in> Domain wl" by auto
   with LeastI2 have "?N \<in> Domain wl" by metis
   then obtain L R f where NLRf:"(?N,(L,R),f)\<in>wl" by auto
   hence N_def:"?N = nextMax (Range f)"
     and in_Rs: "(L,R) \<in> Rs" unfolding wl_def worklist_def Let_def by auto
   from Least_le wl_ne Domain.intros case_prodI2 
   have min:"(\<forall> (N',_) \<in> wl. N' \<ge> ?N)" by (metis (no_types, lifting))
   from in_Rs have "finite_graph R" "subgraph L R"
     using assms(2)[unfolded set_of_graph_rules_def] by auto
   with min NLRf N_def show ?thesis unfolding wl_def[symmetric] valid_selection_def by auto
 qed
 
 definition valid_selector where
 "valid_selector Rs selector \<equiv> \<forall> G.
    (worklist G Rs \<noteq> {} \<longrightarrow> (\<exists> (R,f)\<in>UNIV. selector G = Some (R,f)
                                \<and> valid_selection Rs G R f)) \<and>
    (worklist G Rs = {} \<longrightarrow> selector G = None)"
 
 lemma valid_selectorD[dest]:
   assumes "valid_selector Rs selector"
   shows "worklist G Rs = {} \<longleftrightarrow> selector G = None"
         "selector G = Some (R,f) \<Longrightarrow> valid_selection Rs G R f"
   using assms[unfolded valid_selector_def,rule_format,of G]
   by (cases "worklist G Rs = {}",auto)
 
 text \<open>The following gives a valid selector.
       This selector is not useful as concrete implementation, because it used the choice operation.\<close>
 definition non_constructive_selector where
 "non_constructive_selector Rs G \<equiv> let wl = worklist G Rs in
    if wl = {} then None else Some (SOME (R,f). valid_selection Rs G R f) "
 
 lemma non_constructive_selector:
   assumes "set_of_graph_rules Rs"
   shows "valid_selector Rs (non_constructive_selector Rs)"
   unfolding valid_selector_def proof((clarify,standard;clarify),goal_cases)
   case (1 n E)
   let ?x = "(SOME (R, f). valid_selection Rs (n, E) R f)"
   from valid_selection_exists[OF 1 assms]
   have "\<exists> R f. valid_selection Rs (n, E) R f" by auto
   hence "\<exists> x. valid_selection Rs (n, E) (fst x) (snd x)"
     by auto
   from this prod.case_eq_if tfl_some
   have "\<not> valid_selection Rs (n, E) (fst ?x) (snd ?x) \<Longrightarrow> False"
     by (metis (mono_tags, lifting))
   thus ?case unfolding non_constructive_selector_def Let_def using 1 by (auto simp:prod_eq_iff)
 qed (auto simp:non_constructive_selector_def)
 
 
 text \<open>The following is used to make a weak pushout step.
       In the paper, we aren't too specific on how this should be done. Here we are.
       We work on natural numbers in order to be able to pick fresh elements easily. \<close>
 definition extend ::
     "nat \<Rightarrow> ('b, 'a::linorder) Graph_PreRule  \<Rightarrow> ('a \<times> nat) set \<Rightarrow> ('a \<times> nat) set" where
 "extend n R f \<equiv> f \<union> 
    (let V_new = sorted_list_of_set (vertices (snd R) - vertices (fst R))
     in set (zip V_new [n..<(n+length V_new)]))"
 
 lemma nextMax_set[simp]:
   assumes "sorted xs"
   shows "nextMax (set xs) = (if xs = Nil then 0 else Suc (last xs))"
   using assms
 proof(induct xs)
   case Nil show ?case unfolding nextMax_def by auto
 next
   case (Cons a list)
   hence "list \<noteq> [] \<Longrightarrow> fold max list a = last list"
     using list_sorted_max by (metis last.simps)
   thus ?case unfolding nextMax_def Max.set_eq_fold by auto
 qed
 
 lemma nextMax_Un_eq[simp]:
 "finite x \<Longrightarrow> finite y \<Longrightarrow> nextMax (x \<union> y) = max (nextMax x) (nextMax y)"
   unfolding nextMax_def using Max_Un by auto
 
 lemma extend: (* extensible into the new graph *)
   assumes "graph_homomorphism (fst R) (LG E {0..<n}) f" "graph_rule R"
   defines "g \<equiv> extend n R f"
   defines "G' \<equiv> LG ((on_triple g `` (edges (snd R))) \<union> E) {0..<max n (nextMax (Range g))}"
   shows "graph_homomorphism (snd R) G' g" "agree_on (fst R) f g" "f \<subseteq> g"
         "subgraph (LG E {0..<n}) G'"
         "weak_universal (t:: 'x itself) R (LG E {0..<n}) G' f g"
 proof -
   have ln:"length x = length [n..<n + length x]" for x::"'b list" by auto
   let ?R_L = "vertices (snd R) - vertices (fst R)"
   from assms
   have "graph_rule (fst R,snd R)" and fin_R:"finite (vertices (snd R))"
     and subsLR:"vertices (fst R) \<subseteq> vertices (snd R)" and gr_R:"graph (snd R)"
     unfolding subgraph_def graph_union_iff
     by auto
   hence fin_R_L[simp]:"finite ?R_L"
      and fin_L:"finite (vertices (fst R))"
      using finite_subset by auto
   from assms have f_dom:"Domain f = vertices (fst R)"
     and f_uni:"univalent f" unfolding graph_homomorphism_def by auto
   from assms[unfolded graph_homomorphism_def]
   have "f `` vertices (fst R) \<subseteq> vertices (LG E {0..<n})" by blast
   hence f_ran:"Range f \<subseteq> {0..<n}" using f_dom by auto
   let ?g = "(let V_new = sorted_list_of_set ?R_L
               in set (zip V_new [n..<n + length V_new]))" (* new part of g *)
   have fin_g':"finite ?g" "finite (Range ?g)" unfolding Let_def by auto
   have "finite (Domain f)" "univalent f" using assms(1) fin_L
     unfolding graph_homomorphism_def by auto
   hence fin_f:"finite (Range f)" unfolding Range_snd by auto
   hence fin_g:"finite (Range g)" unfolding extend_def g_def Let_def Range_Un_eq by auto
   have nextMax_f:"nextMax (Range f) \<le> n"
     using f_ran Max_in[OF fin_f] by (simp add:nextMax_def Suc_leI subset_eq)
   
   have "x \<in> Domain ?g \<Longrightarrow> x \<notin> Domain f" for x unfolding f_dom Let_def by auto
   hence g_not_f:"(x,y) \<in> ?g \<Longrightarrow> (x,z) \<notin> f" for x y z by auto
   have uni_g':"univalent ?g" "univalent (converse ?g)" unfolding Let_def by auto
   with f_uni have uni_g:"univalent g" by (auto simp:g_def extend_def g_not_f)
   from fin_g have "(a,b) \<in> g \<Longrightarrow> b < Suc (Max (Range g))" for a b
     unfolding less_Suc_eq_le by (rule Max.coboundedI) force
   hence "(a,b) \<in> g \<Longrightarrow> b < nextMax (Range g)" for a b
     unfolding nextMax_def by (cases "Range g = {}",auto)
   hence in_g:"(a,b) \<in> g \<Longrightarrow> b < max n (nextMax (Range g))" for a b by fastforce
   let ?G = "LG E {0..<n}"
   have gr_G:"graph ?G" using assms(1) unfolding graph_homomorphism_def by blast
   hence "(a, aa, b) \<in> E \<Longrightarrow> b < max n c" "(a, aa, b) \<in> E \<Longrightarrow> aa < max n c"
     for a aa b c by fastforce+
   hence gr_G':"graph G'" unfolding G'_def restrict_def using in_g by auto
   show "subgraph (LG E {0..<n}) G'"
     unfolding subgraph_def2[OF gr_G gr_G'] unfolding G'_def by auto
   have g_dom:"vertices (snd R) = Domain g" using subsLR
     unfolding g_def extend_def Domain_Un_eq f_dom by (auto simp:Let_def)
   show "graph_homomorphism (snd R) G' g"
     by (intro graph_homomorphismI[OF g_dom _ uni_g _ gr_R gr_G'])
        (auto simp:G'_def intro:in_g)
   show "f \<subseteq> g" by (auto simp:g_def extend_def)
   thus "agree_on (fst R) f g" using f_dom uni_g agree_on_subset equalityE by metis
   show "weak_universal t R ?G G' f g" proof fix a:: "('b \<times> 'x) set" fix b G
     assume a:"graph_homomorphism (snd R) G a"
              "graph_homomorphism ?G G b" "f O b \<subseteq> a"
     hence univ_b:"univalent b" and univ_a:"univalent a"
       and rng_b:"Range b \<subseteq> vertices G" and rng_a:"Range a \<subseteq> vertices G"
       and ep_b:"edge_preserving b (edges (LG E {0..<n})) (edges G)"
       and ep_a:"edge_preserving a (edges (snd R)) (edges G)"
       unfolding graph_homomorphism_def prod.sel labeled_graph.sel by blast+
     from a have dom_b:"Domain b = {0..<n}"
       and dom_a:"Domain a = vertices (snd R)" and v6: "graph G"
       unfolding graph_homomorphism_def prod.sel labeled_graph.sel by auto
 
     have help_dom_b:"(y, z) \<in> b \<Longrightarrow> n \<le> y \<Longrightarrow> False" for y z using dom_b
       by (metis Domain.DomainI atLeastLessThan_iff not_less)
     have disj_doms:"Domain b \<inter> Domain (?g\<inverse> O a) = {}" using help_dom_b
       unfolding Let_def by (auto dest!:set_zip_leftD)
 
     have "max n (nextMax (Range ?g)) = n + length (sorted_list_of_set ?R_L)" (is "_ = ?len")
       unfolding Let_def Range_snd set_map[symmetric] map_snd_zip[OF ln] nextMax_set[OF sorted_upt]
       by fastforce
     hence n_eq:"?len = max n (nextMax (Range g))"
       unfolding Range_snd[symmetric] g_def extend_def Range_Un_eq
                 nextMax_Un_eq[OF fin_f fin_g'(2)] max.assoc[symmetric] max_absorb1[OF nextMax_f]
       by auto
 
     let ?h = "b \<union> ?g\<inverse> O a"
 
     have dg:"Domain (?g\<inverse>) = {n..<max n (nextMax (Range g))}"
       unfolding Let_def Domain_converse Range_set_zip[OF ln] atLeastLessThan_upt
       unfolding Range_snd n_eq ..
     have "?g `` Domain a = ?g `` (?R_L \<union> vertices (fst R))"
       using dom_a subsLR by auto
     also have "\<dots> = ?g `` ?R_L \<union> ?g `` vertices (fst R)" by auto
     also have "?g `` vertices (fst R) = {}" apply(rule Image_outside_Domain)
       unfolding Let_def Domain_set_zip[OF ln] by auto
     also have "?g `` ?R_L = Range ?g" apply(rule Image_Domain)
       unfolding Let_def Domain_set_zip[OF ln] by auto
     finally have dg2:"?g `` Domain a = {n..<max n (nextMax (Range g))}"
       unfolding Let_def Range_set_zip[OF ln] set_sorted_list_of_set[OF fin_R_L] 
       unfolding n_eq set_upt by auto
     have "Domain (?g\<inverse> O a) = {n..<max n (nextMax (Range g))}"
       unfolding Domain_id_on converse_converse dg dg2 by auto
     hence v1: "vertices G' = Domain ?h" unfolding G'_def Domain_Un_eq dom_b by auto
     have "b `` vertices G' \<subseteq> vertices G" "(?g\<inverse> O a) `` vertices G' \<subseteq> vertices G"
       using rng_a rng_b by auto
     hence v2: "?h `` vertices G' \<subseteq> vertices G" by blast
     have v3: "univalent ?h"
       using disj_doms univalent_union[OF univ_b univalent_composes[OF uni_g'(2) univ_a]] by blast
     (* showing edge preservation *)
     { fix l x y x' y' assume a2:"(l,x,y) \<in> edges G'" "(x,x') \<in> ?h" "(y,y') \<in> ?h"
       have "(l,x',y') \<in> edges G" proof(cases "(l,x,y) \<in> edges ?G")
         case True
         with gr_G[THEN restrictD]
         have "x \<in> Domain b" "y \<in> Domain b" unfolding dom_b by auto
         hence "x \<notin> Domain (converse ?g O a)" "y \<notin> Domain (converse ?g O a)"
           using disj_doms by blast+
         hence "(x,x') \<in> b" "(y,y') \<in> b" using a2 by auto
         with ep_b True show ?thesis unfolding edge_preserving by auto
       next
         have "g O ?h = f O b \<union> ?g O b \<union> ((f O ?g\<inverse>) O a \<union> (?g O ?g\<inverse>) O a)"
           unfolding g_def extend_def by blast
         also have "(?g O ?g\<inverse>) = Id_on ?R_L"
           unfolding univalent_O_converse[OF uni_g'(2)] unfolding Let_def by auto
         also have "(f O ?g\<inverse>) = {}" using f_ran unfolding Let_def by (auto dest!:set_zip_leftD)
         also have "?g O b = {}" using help_dom_b unfolding Let_def by (auto dest!:set_zip_rightD)
         finally have gOh:"g O ?h \<subseteq> a" using a(3) by blast
         case False
         hence "(l,x,y) \<in> on_triple g `` edges (snd R)" using a2(1) unfolding G'_def by auto
         then obtain r_x r_y
           where r:"(l,r_x,r_y) \<in> edges (snd R)" "(r_x,x) \<in> g" "(r_y,y) \<in> g" by auto
         hence "(r_x,x') \<in> a" "(r_y,y') \<in> a" using gOh a2(2,3) by auto
         hence "(l,x',y') \<in> on_triple a `` edges (snd R)" using r(1) unfolding on_triple_def by auto
         thus ?thesis using ep_a unfolding edge_preserving by auto
       qed
     }
     hence v4: "edge_preserving ?h (edges G') (edges G)" by auto
     have "graph_homomorphism G' G ?h" by(fact graph_homomorphismI[OF v1 v2 v3 v4 gr_G' v6])
     thus "\<exists>h. graph_homomorphism G' G h \<and> b \<subseteq> h" by auto
   qed
 qed
 
 text \<open>Showing that the extend function indeed creates a valid pushout.\<close>
 lemma selector_pushout:
   assumes "valid_selector Rs selector" "selector G'' = Some (R,f)"
   defines "G \<equiv> graph_of G''"
   assumes "graph G"
   defines "g \<equiv> extend (fst G'') R f"
   defines "G' \<equiv> LG (on_triple g `` edges (snd R) \<union> (snd G'')) {0..<max (fst G'') (nextMax (Range g))}"
   shows "pushout_step (t:: 'x itself) R G G'"
 proof -
   have "valid_selection Rs G'' R f" using assms by(cases "selector G''",auto)
   hence igh:"graph_homomorphism (fst R) G f" "graph_rule R"
     unfolding valid_selection_def worklist_def G_def Let_def by auto
   have "subgraph G G'"
        "graph_homomorphism (fst R) G f"
        "graph_homomorphism (snd R) G' g"
        "f \<subseteq> g"
        "weak_universal t R G G' f g"
     using extend[OF igh[unfolded G_def],folded g_def,folded G'_def,folded G_def] igh(1)
     by auto
   thus ?thesis unfolding pushout_step_def by auto
 qed
 
 text \<open>Making a single step in Algorithm 1.
   A prerequisite is that its first argument is a @{term valid_selector}.\<close>
 
 definition make_step where
 "make_step selector S \<equiv>
    case selector S of
      None \<Rightarrow> S |
      Some (R,f) \<Rightarrow> (let g = extend (fst S) R f in
          (max (fst S) (nextMax (Range g)), (on_triple g `` (edges (snd R))) \<union> (snd S)))"
 
 lemma WPC_through_make_step:
   assumes "set_of_graph_rules Rs" "graph (graph_of (X 0))"
      and makestep: "\<forall> i. X (Suc i) = make_step selector (X i)"
      and selector: "valid_selector Rs selector"
   shows "Simple_WPC t Rs (\<lambda> i. graph_of (X i))" "chain (\<lambda> i. graph_of (X i))"
 proof
   note ms = makestep[unfolded make_step_def,rule_format]
   have gr:"graph (graph_of (X i))" for i proof(induct i)
     case (Suc i)
     then show ?case proof(cases "selector (X i)")
       case None
       then show ?thesis using ms Suc by auto
     next
       case (Some a)
       then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
       then show ?thesis using ms[of i,unfolded Some Let_def]
         selector_pushout[OF selector Some Suc,of t
                         ,unfolded pushout_step_def subgraph_def]
         by auto
     qed
   qed (fact assms)
   show "chain (\<lambda> i. graph_of (X i))" unfolding chain_def
   proof(clarify) fix i
     show "subgraph (graph_of (X i)) (graph_of (X (i + 1)))"
     proof(cases "selector (X i)")
       case None
       then show ?thesis using ms gr by (auto intro!:graph_homomorphismI)
     next
       case Some
       then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
       then show ?thesis using ms selector_pushout[OF selector Some gr,of t]
       unfolding pushout_step_def Let_def by simp
     qed
   qed
   show "graph_of (X i) = graph_of (X (Suc i)) \<or>
          (\<exists>R\<in>Rs. pushout_step t R (graph_of (X i)) (graph_of (X (Suc i))))" for i
   proof(cases "selector (X i)")
     case None thus ?thesis using ms by auto
   next
     case Some
     then obtain R f where Some:"selector (X i) = Some (R,f)" by fastforce
     hence "R \<in> Rs" 
       using valid_selectorD(2)[OF selector,unfolded valid_selection_def worklist_def Let_def]
       by(cases R,blast)
     then show ?thesis using ms[of i,unfolded Some Let_def] selector_pushout[OF selector Some gr]
       unfolding make_step_def by auto
   qed
 qed (fact assms)+
 
 lemma N_occurs_finitely_often:
   assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of (X 0))"
       and makestep: "\<And> i. X (Suc i) = make_step selector (X i)"
       and selector: "valid_selector Rs selector"
     shows "finite {(R,f). \<exists> i. R\<in> Rs \<and> graph_homomorphism (fst R) (graph_of (X i)) f
                         \<and> nextMax (Range f) \<le> N}" (is "finite {(R,f).?P R f}")
 proof -
   have prod_eq : "(\<forall> x \<in> {(x, y). A x y}. B x) \<longleftrightarrow> (\<forall> x. A (fst x) (snd x) \<longrightarrow> B x)"
      "(x \<in> {(x, y). A x y}) \<longleftrightarrow> (A (fst x) (snd x))"
     for A B x by auto
   let ?S = "{(R,f).?P R f}"
   let "?Q R f" = "Domain f = vertices (fst (R::('a, 'b) Graph_PreRule)) \<and> univalent f \<and> nextMax (Range f) \<le> N"
   have seteq:"(\<Union>R\<in>Rs. {(R', f). R' = R \<and> ?Q R f}) = {(R,f). R \<in> Rs \<and> ?Q R f}" by auto
   have "\<forall> R \<in> Rs. finite {(R',f). R' = R \<and> ?Q R f}"
   proof fix R assume "R \<in> Rs"
     hence fin:"finite (vertices (fst R))" using assms by auto
     hence fin2:"finite (Pow (vertices (fst R) \<times> {0..N}))" by auto
     have fin:"Domain x = vertices (fst R) \<Longrightarrow> univalent x \<Longrightarrow> finite (snd ` x)"
       for x:: "('b \<times> nat) set" using fin univalent_finite[of x] by simp
     hence "Domain f = vertices (fst R) \<Longrightarrow>
       univalent f \<Longrightarrow> (a,b) \<in> f \<Longrightarrow> nextMax (Range f) \<le> N \<Longrightarrow> b \<le> N" for f a b
       unfolding Range_snd using image_eqI nextMax_max(2) snd_conv order.trans by metis
     hence sub:"{f. ?Q R f} \<subseteq> Pow (vertices (fst R) \<times> {0..N})"
       using nextMax_max[OF fin] by (auto simp:Range_snd image_def)
     from finite_subset[OF sub fin2] show "finite {(R',f). R' = R \<and> ?Q R f}" by auto
   qed
   from this[folded finite_UN[OF assms(1)],unfolded seteq]
   have fin:"finite {(R,f). R \<in> Rs \<and> ?Q R f}".
   have "?P R f \<Longrightarrow> R \<in> Rs \<and> ?Q R f" for R f
     unfolding graph_homomorphism_def by auto
   hence "?S \<subseteq> {(R,f). R \<in> Rs \<and> ?Q R f}" unfolding subset_eq prod_eq by blast
   from finite_subset[OF this fin] show ?thesis by auto
 qed
 
 lemma inj_on_infinite:
   assumes "infinite A" "inj_on f A" "range f \<subseteq> B"
   shows "infinite B"
 proof -
   from assms[unfolded infinite_iff_countable_subset] obtain g::"nat \<Rightarrow> 'a" where
     g:"inj g \<and> range g \<subseteq> A" by blast
   hence i:"inj (f o g)" using assms(2) using comp_inj_on inj_on_subset by blast
   have "range (f o g) \<subseteq> B" using assms(3) by auto
   with i show ?thesis
     unfolding infinite_iff_countable_subset by blast
 qed
 
 lemma makestep_makes_selector_inj:
   assumes "selector (X y) = Some (R,f)"
           "selector (X x) = Some (R,f)"
           "valid_selector Rs selector"
     and step: "\<forall> i. X (Suc i) = make_step selector (X i)"
     and chain:"chain (\<lambda> i. graph_of (X i))"
   shows "x = y"
 proof(rule ccontr)
   assume a:"x \<noteq> y"
   define x' y' where "x' \<equiv> min x y" "y' \<equiv> max x y"
   hence xy:"selector (X x') = Some (R, f)" "selector (X y') = Some (R, f)" "x' < y'"
     using assms(1,2) a unfolding min_def max_def by auto
   with valid_selectorD assms
   have "valid_selection Rs (X x') R f" "valid_selection Rs (X y') R f" by auto
   hence not_ex:"\<not> extensible R (graph_of (X y')) f"
     and hom:"graph_homomorphism (fst R) (graph_of (X x')) f" "graph_rule R"
     unfolding valid_selection_def Let_def worklist_def by auto
   have X:"X (Suc x') = (max (fst (X x')) (nextMax (Range (extend (fst (X x')) R f))),
           on_triple (extend (fst (X x')) R f) `` edges (snd R) \<union> snd (X x'))"
     unfolding step[unfolded make_step_def Let_def,rule_format] xy by auto
   let ?ex = "extend (fst (X x')) R f"
   have hom:"graph_homomorphism (snd R) (graph_of (X (Suc x'))) ?ex"
        and agr:"agree_on (fst R) f ?ex" using extend(1,2)[OF hom] unfolding X by auto
   from xy have "Suc x' \<le> y'" by auto
   with chain[unfolded chain_def2] have "subgraph (graph_of (X (Suc x'))) (graph_of (X y'))" by auto
   from subgraph_preserves_hom[OF this hom]
   have hom:"graph_homomorphism (snd R) (graph_of (X y')) ?ex".
   with agr have "extensible R (graph_of (X y')) f" unfolding extensible_def by auto
   thus False using not_ex by auto
 qed
 
 lemma fair_through_make_step:
   assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of (X 0))"
      (* It should suffice to take infinitely many make_steps, 
         rather than having every step be a make_step,
         but we focus on the algorithm as in the paper here *)
      and makestep: "\<forall> i. X (Suc i) = make_step selector (X i)"
      and selector: "valid_selector Rs selector"
   shows "fair_chain Rs (\<lambda> i. graph_of (X i))"
 proof
   show chn:"chain (\<lambda>i. graph_of (X i))" using WPC_through_make_step assms by blast
   fix R f i
   assume Rs:"R \<in> Rs" and h:"graph_homomorphism (fst R) (graph_of (X i)) f"
   hence R:"finite (vertices (snd R))" "subgraph (fst R) (snd R)"  "finite (vertices (fst R))"
     using assms by auto
   hence f:"finite f" "finite (Range f)" "finite (Domain f)" "univalent f" 
     using h unfolding graph_homomorphism_def Range_snd by auto
   define N where "N \<equiv> nextMax (Range f)"
   fix S
   let "?Q X' j" = " fst X' \<in> Rs
                   \<and> graph_homomorphism (fst (fst X')) (graph_of (X (j+i))) (snd X')
                   \<and> nextMax (Range (snd X')) \<le> N"
   let ?S = "{(R,f). \<exists>j. ?Q (R,f) j}"
   from assms(4) have "\<And>ia. X (Suc ia + i) = make_step selector (X (ia + i))" by auto
   note r = assms(1,2) chain_then_restrict[OF chn] this assms(5)
   from N_occurs_finitely_often[of Rs "\<lambda> j. X (j + i)",OF r]
   have fin_S:"finite ?S" by auto
   { assume a:"\<forall>j. \<not> extensible R (graph_of (X j)) f"
     let "?P X' j" = "?Q X' j \<and> Some X' = selector (X (j+i))"
     { fix j let ?j = "j+i" have "?j \<ge> i" by auto
       from subgraph_preserves_hom[OF chain[OF chn this] h]
       have h:"graph_homomorphism (fst R) (graph_of (X ?j)) f".
       have "\<not> extensible R (graph_of (X ?j)) f" using a by blast 
       with h Rs have wl:"(nextMax (Range f),R,f) \<in> worklist (X ?j) Rs" 
         unfolding worklist_def Let_def set_eq_iff by auto
       hence "worklist (X ?j) Rs \<noteq> {}" by auto
       with valid_selectorD[OF selector]
       obtain R' f'
         where sel:"Some (R',f') = selector (X ?j)"
                   "valid_selection Rs (X ?j) R' f'" by auto
       hence max:"(nextMax (Range f'), R', f') \<in> worklist (X ?j) Rs"
                 "(\<forall>(N, _)\<in>worklist (X ?j) Rs. nextMax (Range f') \<le> N)"
         unfolding valid_selection_def Let_def by auto
       with wl have "nextMax (Range f') \<le> N" unfolding N_def by auto
       with max(1)[unfolded worklist_def Let_def mem_Collect_eq prod.case] sel(1)
       have "\<exists> X'. ?P X' j" by (metis fst_conv snd_conv)
     }
     then obtain ch where ch:"\<And> j. ?P (ch j) j" by metis (* uses 'choice' internally *)
     have inj:"inj ch" proof fix x y assume "ch x = ch y"
       with ch[of x] ch[of y]
       have "selector (X (x + i)) = Some (ch x)" "selector (X (y + i)) = Some (ch x)" by auto
       with makestep_makes_selector_inj[OF _ _ selector makestep chn] have "x + i = y + i"
         by (cases "ch x",metis (full_types))
       thus "x = y" by auto
     qed
     have "ch x \<in> ?S" for x using ch[of x] unfolding mem_Collect_eq by(intro case_prodI2) metis
     hence "range ch \<subseteq> ?S" unfolding UNIV_def by(rule image_Collect_subsetI)
     with infinite_iff_countable_subset inj have "infinite ?S" by blast
     with fin_S have "False" by auto
   }
   thus "\<exists>j. extensible R (graph_of (X j)) f" by auto
 qed
 
 fun mk_chain where
   "mk_chain sel Rs init 0 = init" |
   "mk_chain sel Rs init (Suc n) = mk_chain sel Rs (make_step sel init) n"
 
 lemma mk_chain:
   "\<forall> i. mk_chain sel Rs init (Suc i) = make_step sel (mk_chain sel Rs init i)"
 proof
   fix i
   show "mk_chain sel Rs init (Suc i) = make_step sel (mk_chain sel Rs init i)"
     by (induct i arbitrary:init,auto)
 qed
 
 text \<open>Algorithm 1, abstractly.\<close>
 abbreviation the_lcg where
 "the_lcg sel Rs init \<equiv> chain_sup (\<lambda>i. graph_of (mk_chain sel Rs init i))"
 
 lemma mk_chain_edges:
   assumes "valid_selector Rules sel"
-          "UNION Rules (edges \<circ> snd) \<subseteq> L \<times> UNIV"
+          "\<Union> ((edges o snd) ` Rules) \<subseteq> L \<times> UNIV"
           "edges (graph_of G) \<subseteq> L \<times> UNIV"
   shows "edges (graph_of (mk_chain sel Rules G i)) \<subseteq> L \<times> UNIV"
 using assms(3) proof(induct i arbitrary:G)
   case 0
   then show ?case using assms(2) by auto
 next
   case (Suc i G)
   hence "edges (graph_of (make_step sel G)) \<subseteq> L \<times> UNIV"
   proof(cases "sel G")
     case None show ?thesis unfolding None make_step_def using Suc by auto
   next
     case (Some a)
     then obtain R f where Some:"sel G = Some (R, f)" by fastforce
     hence "(a, x, y) \<in> edges (snd R) \<Longrightarrow> a \<in> L" for a x y
       using assms(2) valid_selectorD(2)[OF assms(1) Some]
       unfolding valid_selection_def Let_def worklist_def by auto
     then show ?thesis unfolding Some make_step_def Let_def using Suc by auto
   qed
   thus ?case unfolding mk_chain.simps by(rule Suc)
 qed
 
 lemma the_lcg_edges:
   assumes "valid_selector Rules sel"
-          "fst ` UNION Rules (edges \<circ> snd) \<subseteq> L" (is "fst `?fR \<subseteq> _")
+          "fst ` (\<Union> ((edges o snd) ` Rules)) \<subseteq> L" (is "fst `?fR \<subseteq> _")
           "fst ` snd G \<subseteq> L"
   shows "fst ` edges (the_lcg sel Rules G) \<subseteq> L"
 proof -
   from assms have "fst `?fR \<times> UNIV \<subseteq> L \<times> UNIV" "fst `(edges (graph_of G)) \<times> UNIV \<subseteq> L \<times> UNIV"
     by auto
-  hence "UNION Rules (edges \<circ> snd) \<subseteq> L \<times> UNIV" "edges (graph_of G) \<subseteq> L \<times> UNIV"
+  hence "(\<Union> ((edges o snd) ` Rules)) \<subseteq> L \<times> UNIV" "edges (graph_of G) \<subseteq> L \<times> UNIV"
     using fst_UNIV[of ?fR] fst_UNIV[of "(edges (graph_of G))"] by blast+
   note assms = assms(1) this
   have "edges (graph_of (mk_chain sel Rules G i)) \<subseteq> L \<times> UNIV" for i
     using mk_chain_edges[OF assms,unfolded Times_subset_cancel2[OF UNIV_I]].
   hence "edges (the_lcg sel Rules G) \<subseteq> L \<times> UNIV" unfolding chain_sup_def by auto
   thus ?thesis by auto
 qed
 
 text \<open>Lemma 9.\<close>
 lemma lcg_through_make_step:
 assumes "finite Rs" "set_of_graph_rules Rs" "graph (graph_of init)"
         "valid_selector Rs sel"
   shows "least_consequence_graph t Rs (graph_of init) (the_lcg sel Rs init)"
 proof -
   from assms have gr:"graph (graph_of (mk_chain sel Rs init 0))" by auto
   note assms = assms(1,2) this mk_chain assms(4)
   from set_of_graph_rulesD[OF assms(2)]
   have "(\<And>R. R \<in> Rs \<Longrightarrow> subgraph (fst R) (snd R) \<and> finite_graph (fst R))" by auto
   from fair_chain_impl_consequence_graph[OF fair_through_make_step[OF assms] this]
        wpc_simpl[OF WPC_through_make_step(1)[OF assms(2-)],THEN wpc_least] 
   show ?thesis unfolding least_consequence_graph_def by auto
 qed
 
 end
diff --git a/thys/HOL-CSP/Process.thy b/thys/HOL-CSP/Process.thy
--- a/thys/HOL-CSP/Process.thy
+++ b/thys/HOL-CSP/Process.thy
@@ -1,1282 +1,1282 @@
 (*<*)
 \<comment>\<open> ********************************************************************
  * Project         : HOL-CSP - A Shallow Embedding of CSP in  Isabelle/HOL
  * Version         : 2.0
  *
  * Author          : Burkhart Wolff, Safouan Taha, Lina Ye.
  *                   (Based on HOL-CSP 1.0 by Haykal Tej and Burkhart Wolff)
  *
  * This file       : A Combined CSP Theory
  *
  * Copyright (c) 2009 Université Paris-Sud, France
  *
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
  * modification, are permitted provided that the following conditions are
  * met:
  *
  *     * Redistributions of source code must retain the above copyright
  *       notice, this list of conditions and the following disclaimer.
  *
  *     * Redistributions in binary form must reproduce the above
  *       copyright notice, this list of conditions and the following
  *       disclaimer in the documentation and/or other materials provided
  *       with the distribution.
  *
  *     * Neither the name of the copyright holders nor the names of its
  *       contributors may be used to endorse or promote products derived
  *       from this software without specific prior written permission.
  *
  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  ******************************************************************************\<close>
 (*>*)
 
 chapter\<open>The Notion of Processes\<close>
 
 text\<open>As mentioned earlier, we base the theory of CSP on HOLCF, a Isabelle/HOL library
 providing a theory of continuous functions, fixpoint induction and recursion.\<close>
 
 theory Process
   imports HOLCF
 begin
 
 text\<open>Since HOLCF sets the default type class to @{class "cpo"}, while our 
 Process theory establishes links between standard types and @{class "pcpo"} 
 types. Consequently, we reset the default type class to the default in HOL.\<close>
 
 default_sort type
 
 subsection\<open>Pre-Requisite: Basic Traces and tick-Freeness\<close>
 
 text\<open>The denotational semantics of CSP assumes a distinguishable
 special event, called \verb+tick+ and written $\checkmark$, that is required
 to occur only in the end of traces in order to signalize successful termination of
 a process. (In the original text of Hoare, this treatment was more
 liberal and lead to foundational problems: the process invariant
 could not be established for the sequential composition operator
 of CSP; see @{cite "tej.ea:corrected:1997"} for details.)\<close>
 
 datatype '\<alpha> event = ev '\<alpha> | tick
 
 type_synonym '\<alpha> trace = "('\<alpha> event) list"
 
 text\<open>We chose as standard ordering on traces the prefix ordering.\<close>
 
 instantiation  list :: (type) order
 begin 
 
 definition  le_list_def  : "(s::'a list) \<le> t \<longleftrightarrow> (\<exists> r. s @ r = t)"
 
 definition  less_list_def: "(s::'a list) < t \<longleftrightarrow> s \<le> t \<and> s \<noteq> t" 
 
 lemma A : "((x::'a list) < y) = (x \<le> y \<and> \<not> y \<le> x)"
 by(auto simp: le_list_def less_list_def)
 
 instance 
 proof
    fix x y z ::"'a list"
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" 
      by(auto simp: le_list_def less_list_def)
    show "x \<le> x"  by(simp add: le_list_def)
    assume A:"x \<le> y" and B:"y \<le> z" thus "x \<le> z"
      apply(insert A B, simp add: le_list_def, safe)  
      apply(rename_tac r ra, rule_tac x="r@ra" in exI, simp)
      done
    assume A:"x \<le> y" and B:"y \<le> x" thus "x = y"
      by(insert A B, auto simp: le_list_def)  
 qed
 
 end
 
 text\<open>Some facts on the prefix ordering.\<close>
 
 lemma nil_le[simp]: "[] \<le> s"
 by(induct "s", simp_all, auto simp: le_list_def) 
 
 lemma nil_le2[simp]: "s \<le> [] = (s = [])"
 by(induct "s", auto simp:le_list_def)
 
 lemma nil_less[simp]: "\<not> t < []"
 by(simp add: less_list_def)
 
 lemma nil_less2[simp]: "[] < t @ [a]"
 by(simp add: less_list_def)
 
 lemma less_self[simp]: "t < t@[a]"
 by(simp add:less_list_def le_list_def)
    
 lemma le_length_mono: "s \<le> t \<Longrightarrow> length s \<le> length t"
 by(auto simp: le_list_def)
 
 lemma less_length_mono: "s < t \<Longrightarrow> length s < length t"
 by(auto simp: less_list_def le_list_def)
 
 lemma less_cons: "s < t \<Longrightarrow> a # s < a # t"
 by (simp add: le_list_def less_list_def)
 
 lemma less_append: "s < t \<Longrightarrow> a @ s < a @ t"
 by (simp add: le_list_def less_list_def)
 
 lemma less_tail: "s \<noteq> [] \<Longrightarrow> s < t \<Longrightarrow> tl s < tl t"
 by (auto simp add: le_list_def less_list_def)
 
 \<comment>\<open>should be in the List library\<close>
 lemma list_nonMt_append: "s \<noteq> [] \<Longrightarrow> \<exists> a t. s = t @ [a]"
 by(erule rev_mp,induct "s",simp_all,case_tac "s = []",auto)
 
 lemma append_eq_first_pref_spec[rule_format]: "s @ t = r @ [x] \<and> t \<noteq> [] \<longrightarrow> s \<le> r"
   apply(rule_tac x=s in spec)
   apply(induct r,auto)
     apply(erule rev_mp)
     apply(rename_tac xa, rule_tac list=xa in list.induct, simp_all)
   apply(simp add: le_list_def)
   apply(drule list_nonMt_append, auto)
   done
 
 lemma prefixes_fin: "let prefixes = {t. \<exists>t2. x = t @ t2} in finite prefixes \<and> card prefixes = length x + 1"  
 proof(induct x, simp)
   case (Cons a x)
   hence A:"finite {t. (\<exists>t2. x = t @ t2)}" using not_add_less2 by fastforce
   have B:"inj_on Cons UNIV" by (metis injI list.inject)
   from Cons A B inj_on_iff_eq_card have  C:"card ((\<lambda>x. a#x)`{t. (\<exists>t2. x = t @ t2)}) = length x + 1"
     by fastforce
   have D:"{t. \<exists>t2. a # x = t @ t2} = {[]} \<union> (\<lambda>x. a#x)`{t. (\<exists>t2. x = t @ t2)}" 
     by(intro set_eqI iffI, auto simp add:Cons_eq_append_conv) 
   from C D card_insert_if[of "(\<lambda>x. a#x)`{t. (\<exists>t2. x = t @ t2)}"] show ?case 
     by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Un_insert_left finite.insertI 
         finite_imageI image_iff list.distinct(1) list.size(4) local.A sup_bot.left_neutral)
 qed
 
 lemma sublists_fin: "finite {t. \<exists>t1 t2. x = t1 @ t @ t2}"
   proof(induct x, simp)
     case (Cons a x)
     have "{t. \<exists>t1 t2. a # x = t1 @ t @ t2} \<subseteq> {t. \<exists>t1 t2. x = t1 @ t @ t2} \<union> {t. \<exists>t2. a#x = t @ t2}"
       apply(auto) by (metis Cons_eq_append_conv)
     with Cons prefixes_fin[of "a#x"] show ?case by (meson finite_UnI finite_subset)
   qed
 
 lemma suffixes_fin: "finite {t. \<exists>t1. x = t1 @ t}"
   apply(subgoal_tac "{t. \<exists>t1. x = t1 @ t} \<subseteq> {t. \<exists>t1 t2. x = t1 @ t @ t2}")
   using infinite_super sublists_fin apply blast
   by blast
 
 text\<open>For the process invariant, it is a key element to
 reduce the notion of traces to traces that may only contain
 one tick event at the very end. This is captured by the definition
 of the predicate \verb+front_tickFree+ and its stronger version
 \verb+tickFree+. Here is the theory of this concept.\<close>
 
 definition tickFree :: "'\<alpha> trace \<Rightarrow> bool"
   where "tickFree s = (tick \<notin> set s)"
 
 definition front_tickFree :: "'\<alpha> trace \<Rightarrow> bool"
   where "front_tickFree s = (s =[] \<or> tickFree(tl(rev s)))"
 
 lemma tickFree_Nil [simp]: "tickFree []"
 by(simp add: tickFree_def)
 
 lemma tickFree_Cons [simp]: "tickFree (a # t) = (a \<noteq> tick \<and> tickFree t)"
 by(auto simp add: tickFree_def)
 
 lemma tickFree_tl : "[|s ~= [] ; tickFree s|] ==> tickFree(tl s)"
 by(case_tac s, simp_all)
   
 lemma tickFree_append[simp]: "tickFree(s@t) = (tickFree s \<and> tickFree t)"
 by(simp add: tickFree_def member_def)
 
 lemma non_tickFree_tick [simp]: "\<not> tickFree [tick]"
 by(simp add: tickFree_def)
 
 lemma non_tickFree_implies_nonMt: "\<not> tickFree s \<Longrightarrow> s \<noteq> []"
 by(simp add:tickFree_def,erule rev_mp, induct s, simp_all)
 
 lemma  tickFree_rev : "tickFree(rev t) = (tickFree t)"
 by(simp  add: tickFree_def member_def)
 
 lemma front_tickFree_Nil[simp]: "front_tickFree []"
 by(simp add: front_tickFree_def)
 
 lemma front_tickFree_single[simp]: "front_tickFree [a]"
 by(simp add: front_tickFree_def)
 
 lemma tickFree_implies_front_tickFree: "tickFree s \<Longrightarrow> front_tickFree s"
 apply(simp add: tickFree_def front_tickFree_def member_def,safe)
 apply(erule contrapos_np, simp,(erule rev_mp)+)
 apply(rule_tac xs=s in List.rev_induct,simp_all)
 done
 
 lemma front_tickFree_charn: "front_tickFree s = (s = [] \<or> (\<exists>a t. s = t @ [a] \<and> tickFree t))"
 apply(simp add: front_tickFree_def)
 apply(cases "s=[]", simp_all)
 apply(drule list_nonMt_append, auto simp: tickFree_rev)
 done
 
 lemma front_tickFree_implies_tickFree: "front_tickFree (t @ [a]) \<Longrightarrow> tickFree t"
 by(simp add: tickFree_def front_tickFree_def member_def)
 
 lemma tickFree_implies_front_tickFree_single: "tickFree t \<Longrightarrow> front_tickFree (t @ [a])"
 by(simp add:front_tickFree_charn) 
 
 
 lemma nonTickFree_n_frontTickFree: "\<lbrakk>\<not> tickFree s; front_tickFree s \<rbrakk> \<Longrightarrow> \<exists>t. s = t @ [tick]"
 apply(frule non_tickFree_implies_nonMt)
 apply(drule front_tickFree_charn[THEN iffD1], auto)
 done
 
 lemma front_tickFree_dw_closed : "front_tickFree (s @ t) \<Longrightarrow>  front_tickFree s"
 apply(erule rev_mp, rule_tac x= s in spec)
 apply(rule_tac xs=t in List.rev_induct, simp, safe)
 apply(rename_tac x xs xa)
 apply(simp only: append_assoc[symmetric])
 apply(rename_tac x xs xa, erule_tac x="xa @ xs" in all_dupE)
 apply(drule front_tickFree_implies_tickFree)
 apply(erule_tac x="xa" in allE, auto)
 apply(auto dest!:tickFree_implies_front_tickFree)
 done
 
 lemma front_tickFree_append: "\<lbrakk> tickFree s; front_tickFree t\<rbrakk> \<Longrightarrow> front_tickFree (s @ t)"
 apply(drule front_tickFree_charn[THEN iffD1], auto)
 apply(erule tickFree_implies_front_tickFree)
 apply(subst append_assoc[symmetric])
 apply(rule tickFree_implies_front_tickFree_single)
 apply(auto intro: tickFree_append)
 done
 
 lemma front_tickFree_mono: "front_tickFree (t @ r) \<and> r \<noteq> [] \<longrightarrow> tickFree t \<and> front_tickFree r"
 by(metis append_assoc append_butlast_last_id front_tickFree_charn 
          front_tickFree_implies_tickFree tickFree_append)
 
 
 subsection\<open> Basic Types, Traces, Failures and Divergences \<close>
 
 type_synonym '\<alpha> refusal = "('\<alpha> event) set"
 type_synonym '\<alpha> failure = "'\<alpha> trace \<times> '\<alpha> refusal"
 type_synonym '\<alpha> divergence = "'\<alpha> trace set"
 type_synonym '\<alpha> process\<^sub>0 = "'\<alpha> failure set \<times> '\<alpha> divergence"
  
 definition FAILURES :: "'\<alpha> process\<^sub>0 \<Rightarrow> ('\<alpha> failure set)"
   where "FAILURES P = fst P"
 
 definition TRACES :: "'\<alpha> process\<^sub>0 \<Rightarrow> ('\<alpha> trace set)"
   where "TRACES P = {tr. \<exists> a. a \<in> FAILURES P \<and> tr = fst a}"
 
 definition DIVERGENCES :: "'\<alpha> process\<^sub>0 \<Rightarrow> '\<alpha> divergence"
   where "DIVERGENCES P = snd P"
 
 definition REFUSALS :: "'\<alpha> process\<^sub>0 \<Rightarrow> ('\<alpha> refusal set)"
   where "REFUSALS P = {ref.  \<exists> F. F \<in> FAILURES P \<and> F = ([],ref)}"
 
 subsection\<open> The Process Type Invariant \<close>
 
 definition is_process :: "'\<alpha> process\<^sub>0 \<Rightarrow> bool" where
   "is_process P =
       (([],{}) \<in> FAILURES P \<and>
        (\<forall> s X.  (s,X) \<in> FAILURES P \<longrightarrow> front_tickFree s) \<and>
        (\<forall> s t . (s@t,{}) \<in> FAILURES P \<longrightarrow> (s,{}) \<in> FAILURES P) \<and>
        (\<forall> s X Y. (s,Y) \<in> FAILURES P & X <= Y \<longrightarrow> (s,X) \<in> FAILURES P) \<and> 
        (\<forall> s X Y. (s,X) \<in> FAILURES P \<and>
        (\<forall> c.      c \<in> Y \<longrightarrow> ((s@[c],{})\<notin>FAILURES P)) \<longrightarrow> 
                                          (s,X \<union> Y)\<in>FAILURES P) \<and>
        (\<forall> s X.  (s@[tick],{}) : FAILURES P \<longrightarrow> (s,X-{tick}) \<in> FAILURES P) \<and>
        (\<forall> s t.  s \<in> DIVERGENCES P \<and> tickFree s \<and> front_tickFree t 
                                       \<longrightarrow> s@t \<in> DIVERGENCES P)  \<and>
        (\<forall> s X. s \<in> DIVERGENCES P \<longrightarrow> (s,X) \<in> FAILURES P) \<and>
        (\<forall> s. s @ [tick] : DIVERGENCES P \<longrightarrow> s \<in> DIVERGENCES P))"
 
 
 lemma is_process_spec:
  "is_process P = 
        (([],{}) \<in>  FAILURES P \<and>
        (\<forall> s X. (s,X) \<in>  FAILURES P \<longrightarrow> front_tickFree s) \<and>
        (\<forall> s t . (s @ t,{}) \<notin> FAILURES P \<or>   (s,{}) \<in> FAILURES P) \<and>
        (\<forall> s X Y. (s,Y)  \<notin>  FAILURES P \<or> \<not>(X\<subseteq>Y) | (s,X) \<in> FAILURES P) \<and>
        (\<forall> s X Y.(s,X) \<in> FAILURES P \<and> 
        (\<forall> c. c \<in>  Y \<longrightarrow> ((s@[c],{}) \<notin>  FAILURES P)) \<longrightarrow>(s,X \<union> Y) \<in>  FAILURES P) \<and>
        (\<forall> s X. (s@[tick],{}) \<in>  FAILURES P \<longrightarrow> (s,X - {tick}) \<in>  FAILURES P) \<and>
        (\<forall> s t. s \<notin> DIVERGENCES P \<or> \<not>tickFree s \<or> \<not>front_tickFree t 
                                  \<or> s @ t \<in> DIVERGENCES P) \<and>
        (\<forall> s X. s \<notin> DIVERGENCES P \<or> (s,X) \<in>  FAILURES P) \<and>
        (\<forall> s. s @ [tick] \<notin>  DIVERGENCES P \<or> s \<in>  DIVERGENCES P))"
 by(simp  only: is_process_def  HOL.nnf_simps(1)  HOL.nnf_simps(3) [symmetric]  
                       HOL.imp_conjL[symmetric])
 
 lemma Process_eqI :
 assumes A: "FAILURES P = FAILURES Q "
 assumes B: "DIVERGENCES P = DIVERGENCES Q"
 shows      "(P::'\<alpha> process\<^sub>0) = Q"
 apply(insert A B, unfold FAILURES_def DIVERGENCES_def) 
 apply(rule_tac t=P in surjective_pairing[symmetric,THEN subst])
 apply(rule_tac t=Q in surjective_pairing[symmetric,THEN subst])
 apply(simp)
 done
 
 lemma process_eq_spec:
 "((P::'a process\<^sub>0) = Q) = (FAILURES P = FAILURES Q \<and> DIVERGENCES P = DIVERGENCES Q)"
 apply(auto simp: FAILURES_def DIVERGENCES_def)
 apply(rule_tac t=P in surjective_pairing[symmetric,THEN subst])
 apply(rule_tac t=Q in surjective_pairing[symmetric,THEN subst])
 apply(simp)
 done
 
 lemma process_surj_pair: "(FAILURES P,DIVERGENCES P) = P"
 by(auto simp:FAILURES_def DIVERGENCES_def)
 
 lemma Fa_eq_imp_Tr_eq: "FAILURES P = FAILURES Q \<Longrightarrow> TRACES P = TRACES Q"
 by(auto simp:FAILURES_def DIVERGENCES_def TRACES_def) 
 
 lemma is_process1:  "is_process P \<Longrightarrow> ([],{})\<in> FAILURES P "
 by(auto simp: is_process_def)
 
 lemma is_process2: "is_process P \<Longrightarrow> \<forall> s X. (s,X) \<in> FAILURES P \<longrightarrow> front_tickFree s "
 by(simp only: is_process_spec, metis)
 
 lemma is_process3: "is_process P \<Longrightarrow> \<forall> s t. (s @ t,{}) \<in> FAILURES P \<longrightarrow> (s, {}) \<in> FAILURES P"
 by(simp only: is_process_spec, metis)
 
 
 lemma is_process3_S_pref: "\<lbrakk>is_process P; (t, {}) \<in> FAILURES P; s \<le> t\<rbrakk> \<Longrightarrow> (s, {}) \<in> FAILURES P"
 by(auto simp: le_list_def intro: is_process3 [rule_format])
 
 lemma is_process4: "is_process P \<Longrightarrow> \<forall>s X Y. (s, Y) \<notin> FAILURES P \<or> \<not> X \<subseteq> Y \<or> (s, X) \<in> FAILURES P"
 by(simp only: is_process_spec, simp)
 
 lemma is_process4_S: "\<lbrakk>is_process P; (s, Y) \<in> FAILURES P; X \<subseteq> Y\<rbrakk> \<Longrightarrow> (s, X) \<in> FAILURES P"
 by(drule is_process4, auto)
 
 lemma is_process4_S1: "\<lbrakk>is_process P; x \<in> FAILURES P; X \<subseteq> snd x\<rbrakk> \<Longrightarrow> (fst x, X) \<in> FAILURES P"
 by(drule is_process4_S, auto)
 
 lemma is_process5:
 "is_process P \<Longrightarrow>
     \<forall>sa X Y. (sa, X) \<in> FAILURES P \<and> (\<forall>c. c \<in> Y \<longrightarrow> (sa @ [c], {}) \<notin> FAILURES P) \<longrightarrow> (sa, X \<union> Y) \<in> FAILURES P"
 by(drule is_process_spec[THEN iffD1],metis)
 
 lemma is_process5_S:
 "\<lbrakk>is_process P; (sa, X) \<in> FAILURES P; \<forall>c. c \<in> Y \<longrightarrow> (sa @ [c], {}) \<notin> FAILURES P\<rbrakk> \<Longrightarrow> (sa, X \<union> Y) \<in> FAILURES P"
 by(drule is_process5, metis)
 
 lemma is_process5_S1:
 "\<lbrakk>is_process P; (sa, X) \<in> FAILURES P; (sa, X \<union> Y) \<notin> FAILURES P\<rbrakk> \<Longrightarrow> \<exists>c. c \<in> Y \<and> (sa @ [c], {}) \<in> FAILURES P"
 by(erule contrapos_np, drule is_process5_S, simp_all)
 
 lemma is_process6: "is_process P \<Longrightarrow>  \<forall> s X. (s@[tick],{}) \<in> FAILURES P \<longrightarrow> (s,X-{tick}) \<in> FAILURES P"
 by(drule is_process_spec[THEN iffD1], metis)
 
 lemma is_process6_S: "\<lbrakk>is_process P ;(s@[tick],{}) \<in> FAILURES P\<rbrakk> \<Longrightarrow>  (s,X-{tick}) \<in> FAILURES P"
 by(drule is_process6, metis)
 
 lemma is_process7:
 "is_process P \<Longrightarrow> \<forall> s t. s \<notin> DIVERGENCES P \<or> \<not> tickFree s \<or> \<not> front_tickFree t \<or> s @ t \<in> DIVERGENCES P"
 by(drule is_process_spec[THEN iffD1], metis)
 
 lemma is_process7_S:
 "\<lbrakk> is_process P;s : DIVERGENCES P;tickFree s;front_tickFree t\<rbrakk> 
  \<Longrightarrow>  s @ t \<in> DIVERGENCES P"
 by(drule is_process7, metis)
 
 lemma is_process8: "is_process P \<Longrightarrow> \<forall>  s X. s \<notin> DIVERGENCES P \<or>  (s,X) \<in> FAILURES P"
 by(drule is_process_spec[THEN iffD1], metis)
 
 lemma is_process8_S: "\<lbrakk> is_process P; s \<in> DIVERGENCES P \<rbrakk> \<Longrightarrow> (s,X)  \<in> FAILURES P"
 by(drule is_process8, metis)
 
 lemma is_process9: "is_process P \<Longrightarrow> \<forall>  s. s@[tick] \<notin> DIVERGENCES P \<or>  s \<in> DIVERGENCES P"
 by(drule is_process_spec[THEN iffD1], metis)
 
 lemma is_process9_S: "\<lbrakk> is_process P;s@[tick] \<in> DIVERGENCES P \<rbrakk> \<Longrightarrow> s \<in> DIVERGENCES P"
 by(drule is_process9, metis)
 
 lemma Failures_implies_Traces: " \<lbrakk>is_process P; (s, X) \<in> FAILURES P\<rbrakk> \<Longrightarrow> s \<in> TRACES P"
 by(simp add: TRACES_def, metis)
 
 lemma is_process5_sing: 
 "\<lbrakk> is_process P ; (s,{x}) \<notin> FAILURES P;(s,{}) \<in> FAILURES P\<rbrakk> \<Longrightarrow> (s @ [x],{}) \<in> FAILURES P"
 by(drule_tac X="{}" in is_process5_S1, auto)
 
 lemma is_process5_singT: 
 "\<lbrakk> is_process P ; (s,{x}) \<notin> FAILURES P;(s,{}) \<in> FAILURES P\<rbrakk>  \<Longrightarrow> s @ [x]  \<in> TRACES P"
 apply(drule is_process5_sing, auto)
 by(simp add: TRACES_def, auto)
 
 
 lemma front_trace_is_tickfree:
 assumes A: "is_process P" and B: "(t @ [tick],X) \<in> FAILURES P"
 shows     "tickFree t"
 proof -
   have C: "front_tickFree(t @ [tick])" by(insert A B, drule is_process2, metis) 
   show ?thesis  by(rule front_tickFree_implies_tickFree[OF C])   
 qed
 
 
 lemma trace_with_Tick_implies_tickFree_front : "\<lbrakk>is_process P; t @ [tick] \<in> TRACES P\<rbrakk> \<Longrightarrow> tickFree t"
 by(auto simp: TRACES_def intro: front_trace_is_tickfree)
 
 
 subsection \<open> The Abstraction to the process-Type \<close>
 
 typedef 
   '\<alpha> process = "{p :: '\<alpha> process\<^sub>0 . is_process p}"
 proof - 
    have "({(s, X). s = []},{}) \<in> {p::'\<alpha> process\<^sub>0. is_process p}"
         by(simp add: is_process_def  front_tickFree_def
                      FAILURES_def TRACES_def DIVERGENCES_def )
    thus ?thesis by auto
 qed
 
 definition F :: "'\<alpha> process \<Rightarrow>  ('\<alpha> failure set)"
   where   "F P = FAILURES (Rep_process P)"
 
 definition T :: "'\<alpha> process \<Rightarrow>  ('\<alpha> trace set)"
   where   "T P = TRACES (Rep_process P)"
 
 definition D :: "'\<alpha> process \<Rightarrow> '\<alpha> divergence"
   where   "D P = DIVERGENCES (Rep_process P)"
 
 definition R :: "'\<alpha> process \<Rightarrow> ('\<alpha> refusal set)"
   where   "R P = REFUSALS (Rep_process P)"
 
 
 lemma is_process_Rep : "is_process (Rep_process P)"
 by(rule_tac P=is_process in CollectD, rule Rep_process)
 
 lemma Process_spec: "Abs_process((F P , D P)) = P"
 by(simp add: F_def FAILURES_def D_def 
              DIVERGENCES_def Rep_process_inverse)
 
 lemma Process_eq_spec: "(P = Q)=(F P = F Q \<and> D P = D Q)"
 apply(rule iffI,simp)
 apply(rule_tac t=P in Process_spec[THEN subst])
 apply(rule_tac t=Q in Process_spec[THEN subst])
 apply simp
   done
 
 lemma Process_eq_spec_optimized: "(P = Q) = (D P = D Q \<and> (D P = D Q \<longrightarrow> F P = F Q))"
   using Process_eq_spec by auto
 
 lemma is_processT:
 "([],{}) \<in> F P \<and>
  (\<forall> s X. (s,X) \<in> F P \<longrightarrow> front_tickFree s) \<and>
  (\<forall> s t .(s@t,{}) \<in> F P \<longrightarrow> (s,{}) \<in> F P) \<and>
  (\<forall> s X Y.(s,Y) \<in> F P \<and> (X\<subseteq>Y) \<longrightarrow> (s,X) \<in> F P) \<and>
  (\<forall> s X Y.(s,X) \<in> F P \<and> (\<forall>c. c \<in> Y \<longrightarrow>((s@[c],{})\<notin>F P)) \<longrightarrow> (s,X \<union> Y) \<in> F P) \<and>
  (\<forall> s X. (s@[tick],{}) \<in> F P \<longrightarrow> (s, X-{tick}) \<in> F P) \<and>
  (\<forall> s t. s \<in> D P \<and> tickFree s \<and> front_tickFree t \<longrightarrow> s @ t \<in> D P) \<and>
  (\<forall> s X. s \<in> D P \<longrightarrow> (s,X) \<in> F P) \<and>
  (\<forall> s. s@[tick] \<in> D P \<longrightarrow> s \<in> D P)"
 apply(simp only: F_def D_def T_def)
 apply(rule is_process_def[THEN iffD1])
 apply(rule is_process_Rep)
 done
 
 lemma process_charn:
   "([], {}) \<in> F P \<and>
    (\<forall>s X. (s, X) \<in> F P \<longrightarrow> front_tickFree s) \<and>
    (\<forall>s t. (s @ t, {}) \<notin> F P \<or> (s, {}) \<in> F P) \<and>
    (\<forall>s X Y. (s, Y) \<notin> F P \<or> \<not> X \<subseteq> Y \<or> (s, X) \<in> F P) \<and>
    (\<forall>s X Y. (s, X) \<in> F P \<and> (\<forall>c. c \<in> Y \<longrightarrow> (s @ [c], {}) \<notin> F P) \<longrightarrow>
              (s, X \<union> Y) \<in> F P) \<and>
    (\<forall>s X. (s @ [tick], {}) \<in> F P \<longrightarrow> (s, X - {tick}) \<in> F P) \<and>
    (\<forall>s t. s \<notin> D P \<or> \<not> tickFree s \<or> \<not> front_tickFree t \<or> s @ t \<in> D P) \<and>
    (\<forall>s X. s \<notin> D P \<or> (s, X) \<in> F P) \<and> (\<forall>s. s @ [tick] \<notin> D P \<or> s \<in> D P)"
 proof -
   {
     have A: "(\<forall>s t. (s @ t, {}) \<notin> F P \<or>  (s, {}) \<in> F P) = 
       (\<forall>s t. (s @ t, {}) \<in> F P \<longrightarrow> (s, {}) \<in> F P)"
       by metis
 
     have B : "(\<forall>s X Y. (s, Y) \<notin> F P \<or> \<not> X \<subseteq> Y \<or> (s, X) \<in> F P)  =
       (\<forall>s X Y. (s, Y) \<in> F P \<and> X \<subseteq> Y \<longrightarrow> (s, X) \<in> F P) "
       by metis
 
     have C : "(\<forall>s t. s \<notin> D P \<or> \<not> tickFree s \<or> 
       \<not> front_tickFree t \<or> s @ t \<in> D P)  =
       (\<forall>s t. s \<in> D P \<and> tickFree s \<and> front_tickFree t \<longrightarrow> s @ t \<in> D P) "
       by metis
 
     have D:"(\<forall>s X. s \<notin> D P \<or> (s, X) \<in> F P) = (\<forall>s X. s \<in> D P \<longrightarrow> (s, X) \<in> F P)"
       by metis
 
     have E:"(\<forall>s. s @ [tick] \<notin> D P \<or> s \<in> D P) = 
       (\<forall>s. s @ [tick] \<in> D P \<longrightarrow> s \<in> D P)"
       by metis
 
     note A B C D E 
   }
   note a = this
   then
   show ?thesis
     apply(simp only: a)
     apply(rule is_processT)
     done
 qed
 
 
 text\<open> split of \verb+is_processT+: \<close>
 
 lemma is_processT1: "([],{}) \<in> F P"
 by(simp add:process_charn)
 
 lemma is_processT2: "\<forall>s X. (s, X) \<in> F P \<longrightarrow> front_tickFree s"
 by(simp add:process_charn)
 
 lemma  is_processT2_TR : "\<forall>s. s \<in> T P \<longrightarrow> front_tickFree s"
 apply(simp add: F_def [symmetric] T_def TRACES_def, safe)
 apply (drule is_processT2[rule_format], assumption)
 done
 
 lemma is_proT2:
   assumes A : " (s, X) \<in> F P" and B : " s \<noteq> []"
   shows   "tick \<notin> set (tl (rev s))"
 proof -
   have C: "front_tickFree s" by(insert A B, simp add: is_processT2)
   show ?thesis
   by(insert C,simp add: B  tickFree_def front_tickFree_def) 
 qed
 
 lemma is_processT3 : "\<forall>s t. (s @ t, {}) \<in> F P \<longrightarrow> (s, {}) \<in> F P"
 by(simp only: process_charn  HOL.nnf_simps(3), simp)
 
 lemma is_processT3_S_pref : 
 "\<lbrakk>(t, {}) \<in> F P; s \<le> t\<rbrakk> \<Longrightarrow> (s, {}) \<in> F P"
 apply(simp only: le_list_def, safe)
 apply(erule is_processT3[rule_format])
 done
 
 lemma  is_processT4 : "\<forall>s X Y. (s, Y) \<in> F P \<and> X \<subseteq> Y \<longrightarrow> (s, X) \<in> F P"
 by(insert  process_charn [of P], metis)
 
 lemma is_processT4_S1 : "\<lbrakk>x \<in> F P; X \<subseteq> snd x\<rbrakk> \<Longrightarrow> (fst x, X) \<in> F P"
 apply(rule_tac Y = "snd x" in is_processT4[rule_format])
 apply simp
 done
 
 lemma is_processT5: "\<forall>s X Y.(s,X) \<in> F P \<and> (\<forall>c. c\<in>Y \<longrightarrow> (s@[c],{}) \<notin> F P) \<longrightarrow> (s,X\<union>Y)\<in>F P "
 by(simp add: process_charn)
 
 lemma is_processT5_S1: "\<lbrakk>(s, X) \<in> F P; (s, X \<union> Y) \<notin> F P\<rbrakk> \<Longrightarrow> \<exists>c. c \<in> Y \<and> (s @ [c], {}) \<in> F P"
 by(erule contrapos_np, simp add: is_processT5[rule_format])
 
 lemma is_processT5_S2: "\<lbrakk>(s, X) \<in> F P; (s @ [c], {}) \<notin> F P\<rbrakk> \<Longrightarrow> (s, X \<union> {c}) \<in> F P"
 by(rule is_processT5[rule_format,OF conjI], metis, safe)
 
 
 lemma is_processT5_S2a: "\<lbrakk>(s, X) \<in> F P; (s, X \<union> {c}) \<notin> F P\<rbrakk> \<Longrightarrow> (s @ [c], {}) \<in> F P"
 apply(erule contrapos_np)
 apply(rule is_processT5_S2)
 apply(simp_all)
 done
 
 lemma  is_processT5_S3:
 assumes A: "(s, {}) \<in> F P"
 and     B: "(s @ [c], {}) \<notin> F P"
 shows      "(s, {c}) \<in> F P"
 proof -
    have C : " {c} = ({} Un {c})" by simp
    show ?thesis
    by(subst C, rule is_processT5_S2, simp_all add: A B)
 qed
    
 lemma is_processT5_S4: "\<lbrakk>(s, {}) \<in> F P; (s, {c}) \<notin> F P\<rbrakk> \<Longrightarrow> (s @ [c], {}) \<in> F P"
 by(erule contrapos_np, simp add: is_processT5_S3)
 
 
 lemma is_processT5_S5:
 "\<lbrakk>(s, X) \<in> F P; \<forall>c. c \<in> Y \<longrightarrow> (s, X \<union> {c}) \<notin> F P\<rbrakk> \<Longrightarrow> \<forall>c. c \<in> Y \<longrightarrow> (s @ [c], {}) \<in> F P"
 by(erule_tac Q = "\<forall>c. c \<in> Y \<longrightarrow> (s, X \<union> {c}) \<notin> F P" in contrapos_pp, metis is_processT5_S2) 
 
 lemma is_processT5_S6: "([], {c}) \<notin> F P \<Longrightarrow> ([c], {}) \<in> F P"
 apply(rule_tac t="[c]" and s="[]@[c]" in subst, simp)
 apply(rule is_processT5_S4, simp_all add: is_processT1)
 done
 
 lemma is_processT6: "\<forall>s X. (s @ [tick], {}) \<in> F P \<longrightarrow> (s, X - {tick}) \<in> F P"
 by(simp add: process_charn)
 
 
 lemma is_processT7:  "\<forall>s t. s \<in> D P \<and> tickFree s \<and> front_tickFree t \<longrightarrow> s @ t \<in> D P"
 by(insert process_charn[of P], metis)
 
 lemmas is_processT7_S =  is_processT7[rule_format,OF conjI[THEN conjI, THEN  conj_commute[THEN iffD1]]]
 
 lemma is_processT8: "\<forall>s X. s \<in> D P \<longrightarrow> (s, X) \<in> F P "
 by(insert process_charn[of P], metis)
 
 lemmas is_processT8_S = is_processT8[rule_format]
 
 lemma is_processT8_Pair: "fst s \<in> D P \<Longrightarrow> s \<in> F P"
 apply(subst surjective_pairing)
 apply(rule is_processT8_S, simp)
 done
 
 lemma is_processT9: "\<forall>s. s @ [tick] \<in> D P \<longrightarrow> s \<in> D P"
 by(insert process_charn[of P], metis)
 
 lemma is_processT9_S_swap: "s \<notin> D P \<Longrightarrow> s @ [tick] \<notin> D P"
 by(erule contrapos_nn,simp add: is_processT9[rule_format])
 
 
 subsection\<open> Some Consequences of the Process Characterization\<close>
 
 lemma no_Trace_implies_no_Failure: "s \<notin> T P \<Longrightarrow> (s, {}) \<notin> F P"
 by(simp add: T_def TRACES_def F_def)
 
 lemmas  NT_NF = no_Trace_implies_no_Failure
 
 lemma T_def_spec: "T P = {tr. \<exists>a. a \<in> F P \<and> tr = fst a}"
 by(simp add: T_def TRACES_def F_def)
 
 lemma F_T: "(s, X) \<in> F P \<Longrightarrow> s \<in> T P"
 by(simp add: T_def_spec split_def, metis)
 
 lemma F_T1: "a \<in> F P \<Longrightarrow> fst a \<in> T P"
 by(rule_tac X="snd a" in F_T,simp)
 
 
 lemma T_F: "s \<in> T P \<Longrightarrow> (s, {}) \<in> F P"
 apply(auto simp: T_def_spec)
 apply(drule is_processT4_S1, simp_all)
 done
 
 lemmas is_processT4_empty [elim!]= F_T [THEN T_F]
 
 lemma NF_NT: "(s, {}) \<notin> F P \<Longrightarrow> s \<notin> T P"
   by(erule contrapos_nn, simp only: T_F)
 
 lemma  is_processT6_S1: "\<lbrakk> tick \<notin> X;(s @ [tick], {}) \<in> F P \<rbrakk> \<Longrightarrow> (s::'a event list, X) \<in> F P"
 by(subst Diff_triv[of X "{tick}", symmetric],
    simp, erule is_processT6[rule_format])
 
 lemmas is_processT3_ST = T_F [THEN is_processT3[rule_format,THEN F_T]]
 
 lemmas is_processT3_ST_pref = T_F [THEN is_processT3_S_pref [THEN F_T]]
 
 lemmas is_processT3_SR = F_T [THEN T_F [THEN is_processT3[rule_format]]]
 
 lemmas D_T = is_processT8_S [THEN F_T]
 
 lemma D_T_subset : "D P \<subseteq> T P" by(auto intro!:D_T)
 
 lemma NF_ND : "(s, X) \<notin> F P \<Longrightarrow> s \<notin> D P"
 by(erule contrapos_nn, simp add: is_processT8_S)
 
 lemmas NT_ND = D_T_subset[THEN Set.contra_subsetD]
 
 lemma T_F_spec : "((t, {}) \<in> F P) = (t \<in> T P)"
 by(auto simp:T_F F_T)
 
 lemma is_processT5_S7:  " \<lbrakk>t \<in> T P; (t, A) \<notin> F P\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> A \<and> t @ [x] \<in> T P"
 apply(erule contrapos_np, simp)
 apply(rule is_processT5[rule_format, OF conjI,of _ "{}", simplified])
 apply(auto simp: T_F_spec)
   done
 
 lemma is_processT5_S7': " \<lbrakk>(t, X) \<in> F P; (t, X \<union> A) \<notin> F P\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> A \<and> x \<notin> X \<and> t @ [x] \<in> T P"
   apply(erule contrapos_np, simp, subst Un_Diff_cancel[of X A, symmetric])
   apply(rule is_processT5[rule_format])  
   apply(auto simp: T_F_spec)
   done
 
 lemma Nil_subset_T: " {[]} \<subseteq> T P"
 by(auto simp: T_F_spec[symmetric] is_processT1)
 
 lemma Nil_elem_T: "[] \<in> T P"
 by(simp add: Nil_subset_T[THEN subsetD])
 
 lemmas D_imp_front_tickFree = is_processT8_S[THEN is_processT2[rule_format]]
 
 lemma D_front_tickFree_subset : "D P \<subseteq> Collect front_tickFree"
 by(auto simp: D_imp_front_tickFree)
 
 lemma F_D_part : "F P = {(s, x). s \<in> D P} \<union> {(s, x). s \<notin> D P \<and> (s, x) \<in> F P}"
 by(auto intro:is_processT8_Pair)
 
 lemma D_F : "{(s, x). s \<in> D P} \<subseteq> F P"
 by(auto intro:is_processT8_Pair)
 
 lemma append_T_imp_tickFree:  "\<lbrakk>t @ s \<in> T P; s \<noteq> []\<rbrakk> \<Longrightarrow> tickFree t"
 by(frule is_processT2_TR[rule_format], 
    simp add: front_tickFree_def tickFree_rev)
 
 corollary append_single_T_imp_tickFree : "t @ [a] \<in> T P \<Longrightarrow> tickFree t"
   by (simp add: append_T_imp_tickFree)
 
 lemma F_subset_imp_T_subset: "F P \<subseteq> F Q \<Longrightarrow> T P \<subseteq> T Q"
 by(auto simp: subsetD T_F_spec[symmetric])
 
 lemma is_processT6_S2: "\<lbrakk>tick \<notin> X; [tick] \<in> T P\<rbrakk> \<Longrightarrow> ([], X) \<in> F P"
 by(erule is_processT6_S1, simp add: T_F_spec) 
 
 lemma is_processT9_tick: "\<lbrakk>[tick] \<in> D P; front_tickFree s\<rbrakk> \<Longrightarrow> s \<in> D P"
 apply(rule append.simps(1) [THEN subst, of _ s])
 apply(rule is_processT7_S, simp_all)
 apply(rule is_processT9 [rule_format], simp)
 done
 
 
 lemma T_nonTickFree_imp_decomp: "\<lbrakk>t \<in> T P; \<not> tickFree t\<rbrakk> \<Longrightarrow> \<exists>s. t = s @ [tick]"
 by(auto elim: is_processT2_TR[rule_format] nonTickFree_n_frontTickFree)
 
 
 subsection\<open> Process Approximation is a Partial Ordering, a Cpo, and a Pcpo \<close>
 text\<open>The Failure/Divergence Model of CSP Semantics provides two orderings:
 The \emph{approximation ordering} (also called \emph{process ordering})
 will be used for giving semantics to recursion (fixpoints) over processes,
 the \emph{refinement ordering} captures our intuition that a more concrete
 process is more deterministic and more defined than an abstract one.
 
 We start with the key-concepts of the approximation ordering, namely
 the predicates $min\_elems$ and $Ra$ (abbreviating \emph{refusals after}).
 The former provides just a set of minimal elements from a given set
 of elements of type-class $ord$ \ldots \<close>
 
 definition min_elems :: "('s::ord) set \<Rightarrow> 's set"
   where   "min_elems X = {s \<in> X. \<forall>t. t \<in> X \<longrightarrow> \<not> (t < s)}"
 
 lemma Nil_min_elems : "[] \<in> A \<Longrightarrow> [] \<in> min_elems A"
 by(simp add: min_elems_def)
 
 lemma min_elems_le_self[simp] : "(min_elems A) \<subseteq> A"
 by(auto simp: min_elems_def)
 
 lemmas elem_min_elems = Set.set_mp[OF min_elems_le_self]
 
 lemma min_elems_Collect_ftF_is_Nil : "min_elems (Collect front_tickFree) = {[]}"
 apply(auto simp: min_elems_def le_list_def)
 apply(drule front_tickFree_charn[THEN iffD1])
 apply(auto dest!: tickFree_implies_front_tickFree)
 done
 
 lemma min_elems5 : 
   assumes A: "(x::'a list) \<in> A"
   shows      "\<exists>s\<le>x. s \<in> min_elems A"
 proof -
    have * : "!! (x::'a list) (A::'a list set) (n::nat).
                 x \<in> A \<and> length x \<le> n \<longrightarrow> (\<exists>s\<le>x. s \<in> min_elems A)"
             apply(rule_tac x=x in spec)
             apply(rule_tac n=n in nat_induct) (* quirk in induct *)
             apply(auto simp: Nil_min_elems)
             apply(case_tac "\<exists> y.  y \<in> A \<and> y < x",auto)
             apply(rename_tac A na x y, erule_tac x=y in allE, simp)
             apply(erule impE,drule less_length_mono, arith)
             apply(safe, rename_tac s, rule_tac x=s in exI,simp)
             apply(rule_tac x=x in exI, simp add:min_elems_def)
             done
    show ?thesis by(rule_tac n="length x" in *[rule_format],simp add:A)
 qed
 
 lemma min_elems4: "A \<noteq> {} \<Longrightarrow> \<exists>s. (s :: 'a trace) \<in> min_elems A"
 by(auto dest: min_elems5)
 
 lemma min_elems_charn: "t \<in> A \<Longrightarrow> \<exists> t' r. t = (t' @ r) \<and> t' \<in> min_elems A"
 by(drule min_elems5[simplified le_list_def], auto)
 
 lemmas min_elems_ex = min_elems_charn  (* Legacy *)
 
 lemma min_elems_no: "(x::'a list) \<in> min_elems A \<Longrightarrow> t \<in> A \<Longrightarrow> t \<le> x \<Longrightarrow> x = t" 
   by (metis (no_types, lifting) less_list_def mem_Collect_eq min_elems_def)
 
 text\<open> \ldots while the second returns the set of possible
 refusal sets after a given trace $s$ and a given process
 $P$: \<close>
 
 definition Ra :: "['\<alpha> process, '\<alpha> trace] \<Rightarrow> ('\<alpha> refusal set)"
   where   "Ra P s = {X. (s, X) \<in> F P}"
 
 text\<open> In the following, we link the process theory to the underlying 
 fixpoint/domain theory of HOLCF by identifying the approximation ordering 
 with HOLCF's pcpo's. \<close>
 
 instantiation 
    process  ::  ("type") below     
 begin
 text\<open> declares approximation ordering $\_ \sqsubseteq \_$ also written 
         \verb+_ << _+. \<close>
 
 definition le_approx_def : "P \<sqsubseteq> Q \<equiv> D Q \<subseteq> D P \<and>
                                     (\<forall>s. s \<notin> D P \<longrightarrow> Ra P s = Ra Q s) \<and> 
                                      min_elems (D P) \<subseteq> T Q"
 
 text\<open> The approximation ordering captures the fact that more concrete
 processes should be more defined by ordering the divergence sets
 appropriately. For defined positions in a process, the failure
 sets must coincide pointwise; moreover, the minimal elements
 (wrt.~prefix ordering on traces, i.e.~lists) must be contained in
 the trace set of the more concrete process.\<close>
 
 instance ..
 
 end
 
 
 lemma le_approx1: "P\<sqsubseteq>Q \<Longrightarrow> D Q \<subseteq> D P"
 by(simp add: le_approx_def)
 
 
 lemma le_approx2: "\<lbrakk> P\<sqsubseteq>Q; s \<notin> D P\<rbrakk> \<Longrightarrow> (s,X) \<in> F Q = ((s,X) \<in> F P)" 
 by(auto simp: Ra_def le_approx_def)
 
 
 lemma le_approx3: "P \<sqsubseteq> Q \<Longrightarrow> min_elems(D P) \<subseteq> T Q"
 by(simp add: le_approx_def)
 
 lemma le_approx2T: "\<lbrakk> P\<sqsubseteq>Q; s \<notin> D P\<rbrakk> \<Longrightarrow>  s \<in> T Q = (s \<in> T P)" 
 by(auto simp: le_approx2 T_F_spec[symmetric])
 
 lemma le_approx_lemma_F : "P\<sqsubseteq>Q \<Longrightarrow> F Q \<subseteq> F P"
 apply(subst F_D_part[of Q], subst F_D_part[of P])
 apply(auto simp:le_approx_def Ra_def min_elems_def)
 done
 
 lemmas order_lemma = le_approx_lemma_F
 
 lemma le_approx_lemma_T: "P\<sqsubseteq>Q \<Longrightarrow> T Q \<subseteq> T P"
 by(auto dest!:le_approx_lemma_F simp: T_F_spec[symmetric])
 
 lemma proc_ord2a :  "\<lbrakk>P \<sqsubseteq> Q; s \<notin> D P\<rbrakk> \<Longrightarrow> ((s, X) \<in> F P) = ((s, X) \<in> F Q)"
 by(auto simp: le_approx_def Ra_def)
 
 
 instance
    process :: ("type") po
 proof
    fix P::"'\<alpha> process"
    show "P \<sqsubseteq> P" by(auto simp: le_approx_def min_elems_def elim: Process.D_T)
  next
    fix P Q ::"'\<alpha> process" 
    assume A:"P \<sqsubseteq> Q" and B:"Q \<sqsubseteq> P" thus "P = Q"
    apply(insert A[THEN le_approx1] B[THEN le_approx1])
    apply(insert A[THEN le_approx_lemma_F] B[THEN le_approx_lemma_F])
    by(auto simp: Process_eq_spec)
  next
    fix P Q R ::"'\<alpha> process" 
    assume A: "P \<sqsubseteq> Q" and B: "Q \<sqsubseteq> R" thus "P \<sqsubseteq> R" 
    proof -
       have C : "D R \<subseteq> D P" 
                by(insert A[THEN le_approx1] B[THEN le_approx1], auto)
       have D : "\<forall> s. s \<notin> D P \<longrightarrow> {X. (s, X) \<in> F P} = {X. (s, X) \<in>  F R}" 
                apply(rule allI, rule impI, rule set_eqI, simp)
                apply(frule A[THEN le_approx1, THEN Set.contra_subsetD])
                apply(frule B[THEN le_approx1, THEN Set.contra_subsetD])
                apply(drule A[THEN le_approx2], drule B[THEN le_approx2]) 
                apply auto
                done
       have E : "min_elems (D P) \<subseteq> T R"
                apply(insert B[THEN le_approx3] A[THEN le_approx3] )
                apply(insert B[THEN le_approx_lemma_T] A[THEN le_approx1] ) 
                apply(rule subsetI, simp add: min_elems_def, auto)
                apply(rename_tac x, case_tac "x \<in> D Q")
                apply(drule_tac B = "T R" and t=x 
                      in subset_iff[THEN iffD1,rule_format], auto)
                apply(subst B [THEN le_approx2T],simp)
                apply(rename_tac x, drule_tac B = "T Q" and t=x 
                      in subset_iff[THEN iffD1,rule_format],auto)
                done
       show ?thesis
       by(insert C D E, simp add: le_approx_def Ra_def)
    qed
 qed
 
 text\<open> At this point, we inherit quite a number of facts from the underlying
 HOLCF theory, which comprises a library of facts such as \verb+chain+,
 \verb+directed+(sets), upper bounds and least upper bounds, etc. \<close>
 
 
 text\<open>
 Some facts from the theory of complete partial orders:
 \begin{itemize}
 \item \verb+Porder.chainE+ : @{thm "Porder.chainE"}
 \item \verb+Porder.chain_mono+ : @{thm "Porder.chain_mono"}
 \item \verb+Porder.is_ubD+ : @{thm "Porder.is_ubD"}
 \item \verb+Porder.ub_rangeI+ : \\ @{thm "Porder.ub_rangeI"}
 \item \verb+Porder.ub_imageD+ : @{thm "Porder.ub_imageD"}
 \item \verb+Porder.is_ub_upward+ : @{thm "Porder.is_ub_upward"}
 \item \verb+Porder.is_lubD1+ : @{thm "Porder.is_lubD1"}
 \item \verb+Porder.is_lubI+ : @{thm "Porder.is_lubI"}
 \item \verb+Porder.is_lub_maximal+ : @{thm "Porder.is_lub_maximal"}
 \item \verb+Porder.is_lub_lub+ : @{thm "Porder.is_lub_lub"}
 \item \verb+Porder.is_lub_range_shift+: \\ @{thm "Porder.is_lub_range_shift"}
 \item \verb+Porder.is_lub_rangeD1+: @{thm "Porder.is_lub_rangeD1"}
 \item \verb+Porder.lub_eqI+: @{thm "Porder.lub_eqI"}
 \item \verb+Porder.is_lub_unique+:@{thm "Porder.is_lub_unique"}
 \end{itemize}
 \<close>
 
 
 definition lim_proc :: "('\<alpha> process) set \<Rightarrow> '\<alpha> process"
-  where   "lim_proc (X) = Abs_process (INTER X F, INTER X D)"
+  where   "lim_proc (X) = Abs_process (\<Inter> (F ` X), \<Inter> (D ` X))"
 
 lemma min_elems3: "\<lbrakk>s @ [c] \<in> D P; s @ [c] \<notin> min_elems (D P)\<rbrakk> \<Longrightarrow> s \<in> D P"
 apply(auto simp: min_elems_def le_list_def less_list_def)
 apply(rename_tac t r) 
 apply(subgoal_tac "t \<le> s")
 apply(subgoal_tac "r \<noteq> []")
 apply(simp add: le_list_def)
 apply(auto intro!: is_processT7_S append_eq_first_pref_spec)
 apply(auto dest!: D_T)
 apply(simp_all only: append_assoc[symmetric],
       drule append_T_imp_tickFree,
       simp_all add: tickFree_implies_front_tickFree)+
 done
 
 lemma min_elems1: "\<lbrakk>s \<notin> D P; s @ [c] \<in> D P\<rbrakk> \<Longrightarrow> s @ [c] \<in> min_elems (D P)"
   by(erule contrapos_np, auto elim!: min_elems3)
 
 lemma min_elems2: "\<lbrakk>s \<notin> D P; s @ [c] \<in> D P; P \<sqsubseteq> S; Q \<sqsubseteq> S\<rbrakk> \<Longrightarrow> (s @ [c], {}) \<in> F Q"
   apply(frule_tac P=Q and Q=S in le_approx_lemma_T)
   apply(simp add: T_F_spec)
   apply(rule_tac A="T S" in subsetD, assumption)
   apply(rule_tac A="min_elems(D P)" in subsetD) 
   apply(simp_all add: le_approx_def min_elems1)
 done
 
 lemma min_elems6: "\<lbrakk>s \<notin> D P; s @ [c] \<in> D P; P \<sqsubseteq> S\<rbrakk> \<Longrightarrow> (s @ [c], {}) \<in> F S"
 by(auto intro!: min_elems2)
 
 lemma ND_F_dir2: "\<lbrakk>s \<notin> D P; (s, {}) \<in> F P; P \<sqsubseteq> S; Q \<sqsubseteq> S\<rbrakk> \<Longrightarrow> (s, {}) \<in> F Q"
   apply(frule_tac P=Q and Q=S in le_approx_lemma_T)
   apply(simp add: le_approx_def Ra_def T_F_spec, safe)
   apply((erule_tac x=s in allE)+,simp)
   apply(drule_tac x="{}" in eqset_imp_iff, auto simp: T_F_spec)
 done \<comment>\<open>orig version\<close>
 
 lemma ND_F_dir2': "\<lbrakk>s \<notin> D P; s \<in> T P; P \<sqsubseteq> S; Q \<sqsubseteq> S\<rbrakk> \<Longrightarrow> s \<in> T Q"
   apply(frule_tac P=Q and Q=S in le_approx_lemma_T)
   apply(simp add: le_approx_def Ra_def T_F_spec, safe)
   apply((erule_tac x=s in allE)+,simp)
   apply(drule_tac x="{}" in eqset_imp_iff, auto simp: T_F_spec)
 done
 
 
 lemma chain_lemma: "\<lbrakk>chain S\<rbrakk> \<Longrightarrow> S i \<sqsubseteq> S k \<or> S k \<sqsubseteq> S i"
 by(case_tac "i \<le> k", auto intro:chain_mono chain_mono_less)
  
 
 lemma is_process_REP_LUB: 
   assumes chain: "chain S"
-  shows "is_process(INTER (range S) F,INTER (range S) D)"
+  shows "is_process (\<Inter> (F ` range S), \<Inter> (D ` range S))"
 
 proof (auto simp: is_process_def)
    show   "([], {}) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp: FAILURES_def is_processT)
 next
    fix s::"'a trace" fix X::"'a event set"
    assume A : "(s, X) \<in> (FAILURES (\<Inter> a :: nat. F (S a), \<Inter> a :: nat. D (S a)))" 
    thus   "front_tickFree s"
           by(auto simp:   DIVERGENCES_def FAILURES_def
                   intro!: is_processT2[rule_format])
 next
    fix s  t::"'a trace"
    assume " (s @ t, {}) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a)) "
    thus "(s, {}) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp:  DIVERGENCES_def FAILURES_def
                   intro: is_processT3[rule_format])
 next
    fix s::"'a trace"   fix X Y ::"'a event set"
    assume "(s, Y) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))" and "X \<subseteq> Y"
    thus   "(s, X) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp:  DIVERGENCES_def FAILURES_def
                   intro: is_processT4[rule_format])
 next
    fix s::"'a trace"   fix X Y ::" 'a event set"
    assume A:"(s, X) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
    assume B:"\<forall> c. c\<in>Y \<longrightarrow> (s@[c],{})\<notin>FAILURES(\<Inter> a::nat. F(S a),\<Inter> a::nat. D(S a))"
    thus   "(s, X \<union> Y) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
    txt\<open> What does this mean: All trace prolongations $c$ in all $Y$, 
          which are blocking in the limit, will also occur in the refusal set 
          of the limit. \<close>
    using A B chain
    proof (auto simp: DIVERGENCES_def FAILURES_def,
           case_tac "\<forall> x. x \<in> (range S) \<longrightarrow> (s, X \<union> Y) \<in> F x",
           simp_all add:DIVERGENCES_def FAILURES_def,rename_tac a,
           case_tac "s \<notin> D (S a)",simp_all add: is_processT8)
       fix a::nat 
       assume X: "\<forall>a. (s, X) \<in> F (S a)"
                  have X_ref_at_a: "(s, X) \<in> F (S a)"
                  using X by auto
       assume Y: "\<forall>c. c \<in> Y \<longrightarrow> (\<exists>a. (s @ [c], {}) \<notin> F (S a))"
       assume defined: "s \<notin> D (S a)"
       show   "(s::'a trace, X \<union> Y) \<in> F (S a)"
       proof(auto simp:X_ref_at_a
                  intro!: is_processT5[rule_format],
             frule Y[THEN spec, THEN mp], erule exE,
             erule_tac Q="(s @ [c], {}) \<in> F (S a)" in contrapos_pp)
          fix c::"'a event" fix a' :: nat
          assume s_c_trace_not_trace_somewhere: "(s @ [c], {}) \<notin> F (S a')"
          show "(s @ [c], {}) \<notin> F (S a)"
          proof(insert chain_lemma[OF chain, of "a" "a'"],erule disjE)
            assume before: "S a \<sqsubseteq> S a'"
            show "(s @ [c], {}) \<notin> F (S a)"
              using s_c_trace_not_trace_somewhere  before
              apply(case_tac "s @ [c] \<notin> D (S a)",
                    simp_all add: T_F_spec before[THEN le_approx2T,symmetric])
              apply(erule contrapos_nn)
              apply(simp only: T_F_spec[symmetric])
              apply(auto dest!:min_elems6[OF defined])
              done
          next
            assume after:"S a' \<sqsubseteq> S a"
            show "(s @ [c], {}) \<notin> F (S a)"
              using s_c_trace_not_trace_somewhere
              by(simp add:T_F_spec after[THEN le_approx2T]
                          s_c_trace_not_trace_somewhere[THEN NF_ND])
          qed
       qed
    qed
 next
    fix s::"'a trace"   fix X::"'a event set"
    assume "(s @ [tick], {}) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
    thus   "(s, X - {tick}) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp: DIVERGENCES_def FAILURES_def
                   intro! : is_processT6[rule_format])
 next
    fix s t ::"'a trace"
    assume "s : DIVERGENCES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
    and    "tickFree s" and " front_tickFree t"
    thus   "s @ t \<in> DIVERGENCES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp: DIVERGENCES_def FAILURES_def
                   intro: is_processT7[rule_format])
 next
    fix s::"'a trace"  fix X::"'a event set"
    assume "s \<in> DIVERGENCES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a)) "
    thus   "(s, X) \<in> FAILURES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp: DIVERGENCES_def FAILURES_def
                        intro: is_processT8[rule_format])
 next
    fix s::"'a trace"
    assume "s @ [tick] \<in> DIVERGENCES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a)) "
    thus   "s \<in> DIVERGENCES (\<Inter> a::nat. F (S a), \<Inter> a::nat. D (S a))"
           by(auto simp: DIVERGENCES_def FAILURES_def
                   intro: is_processT9[rule_format])
 qed
 
 
 
 lemmas Rep_Abs_LUB = Abs_process_inverse[simplified Rep_process, 
                                          simplified, OF is_process_REP_LUB,
                                          simplified]
 
-lemma F_LUB: "chain S \<Longrightarrow> F(lim_proc(range S)) = INTER (range S) F"
+lemma F_LUB: "chain S \<Longrightarrow> F(lim_proc(range S)) = \<Inter> (F ` range S)"
 by(simp add: lim_proc_def , subst F_def, auto simp: FAILURES_def Rep_Abs_LUB)
 
-lemma D_LUB: "chain S \<Longrightarrow> D(lim_proc(range S)) = INTER (range S) D"
+lemma D_LUB: "chain S \<Longrightarrow> D(lim_proc(range S)) = \<Inter> (D ` range S)"
 by(simp add: lim_proc_def , subst D_def, auto simp: DIVERGENCES_def Rep_Abs_LUB)
 
-lemma T_LUB: "chain S \<Longrightarrow> T(lim_proc(range S)) = INTER (range S) T"
+lemma T_LUB: "chain S \<Longrightarrow> T(lim_proc(range S)) = \<Inter> (T ` range S)"
 apply(simp add: lim_proc_def , subst T_def) 
 apply(simp add: TRACES_def FAILURES_def Rep_Abs_LUB)
 apply(auto intro: F_T, rule_tac x="{}" in exI, auto intro: T_F)
 done
 
 schematic_goal D_LUB_2: "chain S \<Longrightarrow> t \<in> D(lim_proc(range S)) =  ?X"
 apply(subst D_LUB, simp)
 apply(rule trans, simp)
 apply(simp)
 done
 
 schematic_goal T_LUB_2: "chain S \<Longrightarrow> (t \<in> T (lim_proc (range S))) = ?X"
 apply(subst T_LUB, simp)
 apply(rule trans, simp)
 apply(simp)
 done
 
 
 subsection\<open> Process Refinement is a Partial Ordering\<close>
 
 text\<open> The following type instantiation declares the refinement order
 $\_ \le \_ $ written \verb+_  <= _+. It captures the intuition that more
 concrete processes should be more deterministic and more defined.\<close>
 
 instantiation
    process :: (type) ord          
 begin
 
 definition  le_ref_def   : "P \<le> Q \<equiv> D Q \<subseteq> D P \<and> F Q \<subseteq> F P"
 
 definition  less_ref_def : "(P::'a process) < Q \<equiv> P \<le> Q \<and> P \<noteq> Q"
 
 instance ..
 
 end
 
 lemma le_approx_implies_le_ref:    "(P::'\<alpha> process) \<sqsubseteq> Q \<Longrightarrow> P \<le> Q"
 by(simp add: le_ref_def le_approx1 le_approx_lemma_F)
 
 lemma le_ref1:                     "P \<le> Q \<Longrightarrow> D Q \<subseteq> D P"
 by(simp add: le_ref_def) 
 
 
 lemma le_ref2:                     "P\<le>Q \<Longrightarrow> F Q \<subseteq> F P"
 by(simp add: le_ref_def) 
 
 lemma le_ref2T :                    "P\<le>Q \<Longrightarrow> T Q \<subseteq> T P"
   by (rule subsetI) (simp add: T_F_spec[symmetric] le_ref2[THEN subsetD])
 
 
 instance  process :: (type) order
 proof
    fix P Q R :: "'\<alpha> process"
    {
      show "(P < Q) = (P \<le> Q \<and> \<not> Q \<le>  P)"
        by(auto simp: le_ref_def less_ref_def Process_eq_spec)
    next
      show "P \<le> P"  by(simp add: le_ref_def)
    next
      assume "P \<le> Q" and "Q \<le> R" then show "P \<le> R"
        by (simp add: le_ref_def, auto)
    next
      assume "P \<le> Q" and "Q \<le> P" then show "P = Q"
        by(auto simp: le_ref_def Process_eq_spec)  
    }
 qed
 
 lemma lim_proc_is_ub:"chain S \<Longrightarrow> range S <| lim_proc (range S)" 
   apply(auto simp: is_ub_def le_approx_def F_LUB D_LUB T_LUB Ra_def) 
   using chain_lemma is_processT8 le_approx2 apply blast 
   using D_T chain_lemma le_approx2T le_approx_def by blast
 
 lemma lim_proc_is_lub1: "chain S \<Longrightarrow> \<forall> u . (range S <| u \<longrightarrow>  D u \<subseteq> D (lim_proc (range S)))"
   by(auto simp: D_LUB, frule_tac i=a in Porder.ub_rangeD, auto dest: le_approx1)
 
 lemma lim_proc_is_lub2: 
   "chain S \<Longrightarrow> \<forall> u . range S <| u \<longrightarrow> (\<forall> s.  s \<notin> D (lim_proc (range S))
    \<longrightarrow> Ra (lim_proc (range S)) s = Ra u s)" 
     apply(auto simp: is_ub_def D_LUB F_LUB Ra_def)
     using proc_ord2a apply blast
     using is_processT8_S proc_ord2a by blast
 
 
 lemma lim_proc_is_lub3a: "front_tickFree s \<Longrightarrow> s \<notin> D P \<longrightarrow> (\<forall>t. t \<in> D P \<longrightarrow> \<not> t < s @ [c])" 
 apply(rule impI, erule contrapos_np, auto)
 apply(auto simp: le_list_def  less_list_def)
 by (metis D_def butlast_append butlast_snoc 
           front_tickFree_mono is_process7 is_process_Rep self_append_conv)
 
 
 lemma lim_proc_is_lub3b:
 assumes 1 : "\<forall>x. x \<in> X \<longrightarrow> (\<forall>xa. xa \<in> D x \<and> (\<forall>t. t \<in> D x \<longrightarrow> \<not> t < xa) \<longrightarrow> xa \<in> T u)"
 and     2 : "xa \<in> X"
 and     3 : "\<forall>xa. xa \<in> X \<longrightarrow> x \<in> D xa"
 and     4 : "\<forall>t. (\<forall>x. x \<in> X \<longrightarrow> t \<in> D x) \<longrightarrow> \<not> t < x"
 shows       "x \<in> T u"
 proof (cases "\<forall>t. t \<in> D xa \<longrightarrow> \<not> t < x") 
       case True  from \<open>\<forall>t. t \<in> D xa \<longrightarrow> \<not> t < x\<close>  show ?thesis using 1 2 3  by simp
 next
       case False from \<open>\<not>(\<forall>t. t \<in> D xa \<longrightarrow> \<not> t < x)\<close> and 3 4
                  have A: "\<exists>y r c. y \<in> X \<and> r \<notin> D y \<and> r \<in> D xa \<and> r @ [c] = x" 
                          by (metis D_imp_front_tickFree front_tickFree_charn 
                                    less_self lim_proc_is_lub3a nil_less 
                                    tickFree_implies_front_tickFree)
            show ?thesis
               apply(insert A) apply(erule exE)+
               using "1" "3" D_imp_front_tickFree lim_proc_is_lub3a by blast
 qed
 
 lemma lim_proc_is_lub3c: 
 assumes *:"chain S"
 and     **:"X = range S"  \<comment>\<open>protection for range - otherwise auto unfolds and gets lost\<close>
 shows   "\<forall> u. X <| u \<longrightarrow>  min_elems(D(lim_proc X)) \<subseteq> T u"
 proof -
-  have B : "D (lim_proc X) = INTER X D" by(simp add: * ** D_LUB)
+  have B : "D (lim_proc X) = \<Inter> (D ` X)" by(simp add: * ** D_LUB)
   show ?thesis
      apply(auto simp: is_ub_def * **)
      apply(auto simp: B min_elems_def le_approx_def HOL.imp_conjR HOL.all_conj_distrib Ball_def)
       apply(simp add: subset_iff imp_conjL[symmetric])
     apply(rule lim_proc_is_lub3b[of "range S", simplified])
     using "**" B by auto
 qed
 
 lemma limproc_is_lub: "chain S \<Longrightarrow> range S <<| lim_proc (range S)"
 apply (auto simp: is_lub_def lim_proc_is_ub)
 apply (simp add: le_approx_def is_lub_def lim_proc_is_ub)
 by (simp add: lim_proc_is_lub1 lim_proc_is_lub2 lim_proc_is_lub3c)
 
 lemma limproc_is_thelub: "chain S \<Longrightarrow> Lub S = lim_proc (range S)"
 by (frule limproc_is_lub,frule Porder.po_class.lub_eqI, simp)
 
 
 instance
    process :: (type) cpo
 proof
    fix S ::"nat \<Rightarrow> '\<alpha> process"
    assume C:"chain S" 
    thus "\<exists> x. range S <<| x" using limproc_is_lub by blast
 qed
 
 instance
    process :: (type) pcpo
 proof
    show "\<exists> x::'a process. \<forall> y::'a process. x \<sqsubseteq> y" 
    proof -
       have is_process_witness : 
            "is_process({(s,X). front_tickFree s},{d. front_tickFree d})"
            apply(auto simp:is_process_def FAILURES_def DIVERGENCES_def)
            apply(auto elim!: tickFree_implies_front_tickFree front_tickFree_dw_closed
                              front_tickFree_append)
            done
       have bot_inverse : 
            "Rep_process(Abs_process({(s, X). front_tickFree s},Collect front_tickFree))=
                           ({(s, X). front_tickFree s}, Collect front_tickFree)"
            by(subst Abs_process_inverse, simp_all add: Rep_process is_process_witness)
       have divergences_frontTickFree:
            "\<And>y x. x \<in> snd (Rep_process y) \<Longrightarrow> front_tickFree x" 
            by(rule D_imp_front_tickFree, simp add: D_def DIVERGENCES_def)
       have failures_frontTickFree:
            "\<And>y s x. (s, x) \<in> fst (Rep_process y) \<Longrightarrow> front_tickFree s"
            by(rule is_processT2[rule_format], 
               simp add: F_def FAILURES_def)
       have minelems_contains_mt:
            "\<And>y x. x \<in> min_elems (Collect front_tickFree) \<Longrightarrow> x = []"
            by(simp add: min_elems_def front_tickFree_charn,safe, 
               auto simp: Nil_elem_T)
       show ?thesis 
       apply(rule_tac x="Abs_process ({(s,X). front_tickFree s},{d. front_tickFree d})" 
             in exI)
       apply(auto simp: le_approx_def bot_inverse Ra_def 
                        F_def D_def FAILURES_def DIVERGENCES_def
                        divergences_frontTickFree failures_frontTickFree)
       apply (metis minelems_contains_mt Nil_elem_T )
       done
    qed
 qed
 
 
 subsection\<open> Process Refinement is admissible \<close>
 
 lemma le_adm[simp]: "cont (u::('a::cpo) \<Rightarrow> 'b process) \<Longrightarrow> monofun v \<Longrightarrow> adm(\<lambda>x. u x \<le> v x)"
 proof(auto simp add:le_ref_def cont2contlubE adm_def, goal_cases)
   case (1 Y x)
   hence "v (Y i)  \<sqsubseteq> v (\<Squnion>i. Y i)" for i by (simp add: is_ub_thelub monofunE)
   hence "D (v (\<Squnion>i. Y i)) \<subseteq> D (u (Y i))" for i using "1"(4) le_approx1 by blast    
   then show ?case 
     using D_LUB[OF ch2ch_cont[OF 1(1) 1(3)]] limproc_is_thelub[OF ch2ch_cont[OF 1(1) 1(3)]] "1"(5) by force
 next
   case (2 Y a b)
   hence "v (Y i)  \<sqsubseteq> v (\<Squnion>i. Y i)" for i by (simp add: is_ub_thelub monofunE)
   hence "F (v (\<Squnion>i. Y i)) \<subseteq> F (u (Y i))" for i using "2"(4) le_approx_lemma_F by blast   
   then show ?case
     using F_LUB[OF ch2ch_cont[OF 2(1) 2(3)]] limproc_is_thelub[OF ch2ch_cont[OF 2(1) 2(3)]] "2"(5) by force
 qed
 
 lemmas le_adm_cont[simp] = le_adm[OF _ cont2mono]
 
 subsection\<open> Conditional statement is cont \<close>
 text\<open>The conditional operator of CSP is obtained by a direct shallow embedding. Here we prove it continuous\<close>
 
 lemma if_then_else_cont[simp]: 
   assumes *:"(\<And>x. P x \<Longrightarrow> cont ((f::'c \<Rightarrow> ('a::cpo) \<Rightarrow> 'b process) x))"
   and     **:"(\<And>x. \<not> P x \<Longrightarrow> cont (g x))"
   shows "\<And>x. cont(\<lambda>y. if P x then f x y else g x y)"
   using * ** by (auto simp:cont_def)
 
 end
diff --git a/thys/KD_Tree/Balanced.thy b/thys/KD_Tree/Balanced.thy
--- a/thys/KD_Tree/Balanced.thy
+++ b/thys/KD_Tree/Balanced.thy
@@ -1,594 +1,596 @@
 (*
   File:     Balanced.thy
   Author:   Martin Rau, TU München
 *)
 
 section "Building a balanced \<open>k\<close>-d Tree from a List of Points"
 
 theory Balanced
 imports
   KDTree
   Median_Of_Medians_Selection.Median_Of_Medians_Selection
 begin
 
 text \<open>
   Build a balanced \<open>k\<close>-d Tree by recursively partition the points into two lists.
   The partitioning criteria will be the median at a particular axis \<open>ws\<close>.
   The left list will contain all points \<open>p\<close> with @{term "p!ws \<le> median"}.
   The right list will contain all points with median at axis @{term "ws \<le> p!a"}.
   The left and right list differ in length by one or none.
   The axis \<open>ws\<close> will the widest spread axis. The axis which has the widest spread of point values.
 \<close>
 
 
 subsection "Widest Spread of a List of Points"
 
 definition spread_set :: "axis \<Rightarrow> point set \<Rightarrow> real" where
   "spread_set a ps = (
     let as = (\<lambda>p. p!a) ` ps in
     Max as - Min as
   )"
 
 definition spread :: "axis \<Rightarrow> point list \<Rightarrow> real" where
   "spread a ps = (
     let as = map (\<lambda>p. p!a) (tl ps) in
     fold max as (hd ps !a) - fold min as (hd ps!a)
   )"
 
 definition is_widest_spread :: "axis \<Rightarrow> dimension \<Rightarrow> point set \<Rightarrow> bool" where
   "is_widest_spread a k ps = (\<forall>a' < k. spread_set a' ps \<le> spread_set a ps)"
 
 fun widest_spread_rec :: "axis \<Rightarrow> point list \<Rightarrow> axis * real" where
   "widest_spread_rec 0 ps = (0, spread 0 ps)"
 | "widest_spread_rec a ps = (
     let (a', s') = widest_spread_rec (a - 1) ps in
     let s = spread a ps in
     if s \<le> s' then (a', s') else (a, s)
   )"
 
 definition widest_spread :: "point list \<Rightarrow> axis" where
   "widest_spread ps = (
     let (a, _) = widest_spread_rec (dim (hd ps) - 1) ps in
     a
   )"
 
 fun widest_spread_invar :: "dimension \<Rightarrow> kdt \<Rightarrow> bool" where
   "widest_spread_invar _ (Leaf _) \<longleftrightarrow> True"
 | "widest_spread_invar k (Node a s l r) \<longleftrightarrow> is_widest_spread a k (set_kdt l \<union> set_kdt r) \<and> widest_spread_invar k l \<and> widest_spread_invar k r"
 
 lemma spread_is_spread_set:
   "ps \<noteq> [] \<Longrightarrow> spread_set a (set ps) = spread a ps"
   using Max.set_eq_fold[of "hd ps !a" _] Min.set_eq_fold[of "hd ps !a"]
   apply (auto simp add: Let_def spread_def spread_set_def)
   by (metis (no_types, lifting) hd_Cons_tl list.simps(15) list.simps(9) set_map)
 
 lemma widest_spread_rec_is_spread:
   "(ws, s) = widest_spread_rec a ps \<Longrightarrow> s = spread ws ps"
   by (induction a) (auto simp add: Let_def split: prod.splits if_splits)
 
 lemma is_widest_spread_k_le_ws:
   "is_widest_spread ws k ps \<Longrightarrow> spread_set k ps \<le> spread_set ws ps \<Longrightarrow> is_widest_spread ws (k+1) ps"
   using is_widest_spread_def less_Suc_eq by auto
 
 lemma is_widest_spread_k_gt_ws:
   "is_widest_spread ws k ps \<Longrightarrow> \<not> (spread_set k ps \<le> spread_set ws ps) \<Longrightarrow> is_widest_spread k (k+1) ps"
   using is_widest_spread_def less_Suc_eq by auto
 
 lemma widest_spread_rec_le_a:
   "ps \<noteq> [] \<Longrightarrow> (ws, s) = widest_spread_rec a ps \<Longrightarrow> ws \<le> a"
   by (induction a arbitrary: ws s) (auto simp add: Let_def le_Suc_eq split: prod.splits if_splits)
 
 lemma widest_spread_rec_is_widest_spread:
   "ps \<noteq> [] \<Longrightarrow> (ws, s) = widest_spread_rec a ps \<Longrightarrow> is_widest_spread ws (a+1) (set ps)"
 proof (induction a arbitrary: ws s)
   case 0
   thus ?case
     using is_widest_spread_def by simp
 next
   case (Suc a)
   then obtain ws' s' where *: "(ws', s') = widest_spread_rec a ps"
     by (metis surj_pair)
   hence "is_widest_spread ws' (Suc a) (set ps)"
     using Suc.IH Suc.prems(1) by simp
   then show ?case 
     using Suc.prems * spread_is_spread_set widest_spread_rec_is_spread 
     is_widest_spread_k_le_ws[of ws' "Suc a" "set ps"] is_widest_spread_k_gt_ws[of ws' "Suc a" "set ps"]
     by (auto simp add: Let_def split: prod.splits if_splits)
 qed
 
 lemma widest_spread_lt_k:
   "\<forall>p \<in> set ps. dim p = k \<Longrightarrow> 0 < k \<Longrightarrow> ps \<noteq> [] \<Longrightarrow> widest_spread ps < k"
   using widest_spread_def widest_spread_rec_le_a
   apply (auto split: prod.splits)
   by (metis Suc_le_lessD Suc_le_mono Suc_pred)
 
 lemma widest_spread_is_widest_spread:
   assumes "ps \<noteq> []" "\<forall>p \<in> set ps. dim p = k"
   shows "is_widest_spread (widest_spread ps) k (set ps)"
 proof (cases k)
   case 0
   then show ?thesis
     using is_widest_spread_def by simp
 next
   case (Suc n)
   obtain ws s where *: "(ws, s) = widest_spread_rec (dim (hd ps) - 1) ps"
     using prod.collapse by blast
   moreover have "dim (hd ps) = k"
     using assms(1,2) by simp
   ultimately have "is_widest_spread ws (k - 1 + 1) (set ps)"
     using widest_spread_rec_is_widest_spread assms(1) by simp 
   hence "is_widest_spread ws k (set ps)"
     using Suc by simp
   thus ?thesis
     using * widest_spread_def by (auto split: prod.split)
 qed
 
 
 subsection "Partitioning a List of Points by Median"
 
 definition axis_median :: "axis \<Rightarrow> point list \<Rightarrow> real" where
   "axis_median a ps = (
     let n = (length ps - 1) div 2  in
     let ps' = map (\<lambda>p. p!a) ps in
     fast_select n ps'
   )"
 
 lemma size_mset_map_P:
   "size {# y \<in># mset (map f xs). P y #} = size {# x \<in># mset xs. P (f x) #}"
   by (induction xs) auto
 
 lemma size_axis_median_length:
   assumes "0 < length ps"
   shows "size {# p \<in># mset ps. p!a < axis_median a ps #} \<le> (length ps - 1) div 2" (is "?thesis1")
     and "size {# p \<in># mset ps. axis_median a ps < p!a #} \<le> length ps div 2"       (is "?thesis2")
 proof -
   let ?n = "(length ps - 1) div 2"
   let ?ps' = "map (\<lambda>p. p!a) ps"
   let ?m = "fast_select ?n ?ps'"
 
   have "length ps = length ?ps'"
     by simp
   moreover have "?n < length ?ps'"
     using assms calculation by linarith
   ultimately have *: "median ?ps' = ?m"
     using median_def fast_select_correct by metis
 
   have "size {# a \<in># mset ?ps'. a < ?m #} \<le> (length ps - 1) div 2"
     using * size_less_than_median[of ?ps'] by simp
   hence "size {# p \<in># mset ps. p!a < ?m #} \<le> (length ps - 1) div 2"
     using size_mset_map_P[of "\<lambda>a. a < ?m"] by metis
   thus ?thesis1
     using axis_median_def by metis
   
   have "size {# a \<in># mset ?ps'. ?m < a #} \<le> length ps div 2"
     using * size_greater_than_median[of ?ps'] by simp
   hence "size {# p \<in># mset ps. ?m < p!a #} \<le> length ps div 2"
     using size_mset_map_P[of "\<lambda>a. ?m < a"] by metis
   thus ?thesis2 
     using axis_median_def by metis
 qed
 
 
 subsubsection "Threeway Partitioning a List of Points"
 
 fun partition :: "axis \<Rightarrow> real \<Rightarrow> point list \<Rightarrow> point list * point list * point list" where
   "partition _ _ [] = ([], [], [])"
 | "partition a m (p # ps) = (
     let (lt, eq, gt) = partition a m ps in
     if p!a < m then 
       (p # lt, eq, gt)
     else if p!a = m then 
       (lt, p # eq, gt)
     else 
       (lt, eq, p # gt)
   )"
 
 lemma partition_set:
   assumes "(lt, eq, gt) = partition a m ps"
   shows "set ps = set lt \<union> set eq \<union> set gt"
   using assms by (induction ps arbitrary: lt eq gt) (auto split: prod.splits if_splits)
 
 lemma partition_mset:
   assumes "(lt, eq, gt) = partition a m ps"
   shows "mset lt = {# p \<in># mset ps. p!a < m #}"
     and "mset eq = {# p \<in># mset ps. p!a = m #}"
     and "mset gt = {# p \<in># mset ps. m < p!a #}"
   using assms by (induction ps arbitrary: lt eq gt) (auto split: prod.splits if_splits)
 
 lemma partition_filter:
   assumes "(lt, eq, gt) = partition a m ps"
   shows "\<forall>p \<in> set lt. p!a < m"
     and "\<forall>p \<in> set eq. p!a = m"
     and "\<forall>p \<in> set gt. m < p!a"
   using assms by (induction ps arbitrary: lt eq gt) (auto split: prod.splits if_splits)
 
 lemma partition_length:
   assumes "(lt, eq, gt) = partition a m ps"
   shows "length ps = length lt + length eq + length gt"
     and "length lt = size {# p \<in># mset ps. p!a < m #}"
     and "length eq = size {# p \<in># mset ps. p!a = m #}"
     and "length gt = size {# p \<in># mset ps. m < p!a #}"
   using assms by (induction ps arbitrary: lt eq gt) (auto split: prod.splits if_splits)
 
 
 subsubsection "Partitioning a List of Points balanced by Median"
 
 definition partition_by_median :: "axis \<Rightarrow> point list \<Rightarrow> point list * real * point list" where
   "partition_by_median a ps = (
      let m = axis_median a ps in
      let (lt, eq, gt) = partition a m ps in
      let rem = length ps div 2 - length lt in
      (lt @ take rem eq, m, drop rem eq @ gt)
   )"
 
 lemma set_take_drop: "set xs = set (take n xs) \<union> set (drop n xs)"
   by (metis append_take_drop_id set_append)
 
 lemma partition_by_median_set:
   assumes "(l, m, r) = partition_by_median a ps"
   shows "set ps = set l \<union> set r"
   using assms unfolding partition_by_median_def
   apply (simp add: Let_def split: prod.splits)
   using set_take_drop by (metis partition_set inf_sup_aci(6))
 
 lemma partition_by_median_filter:
   assumes "(l, m, r) = partition_by_median a ps"
   shows "\<forall>p \<in> set l. p!a \<le> m"
     and "\<forall>p \<in> set r. m \<le> p!a"
   using assms unfolding partition_by_median_def
   apply (auto simp add: Let_def split: prod.splits)
   by (metis le_less dual_order.refl in_set_takeD in_set_dropD partition_filter)+
 
 lemma partition_by_median_length_1:
   assumes "(l, m, r) = partition_by_median a ps"
   shows "length ps = length l + length r"
   using assms unfolding partition_by_median_def
   apply (simp add: Let_def min_def split: prod.splits)
   by (metis (no_types, lifting) add.assoc partition_length(1))
 
 lemma partition_by_median_length_2:
   assumes "(l, m, r) = partition_by_median a ps" "0 < length ps"
   shows "length r - length l \<le> 1"
     and "length l \<le> length r"
 proof -
   let ?m = "axis_median a ps"
   let ?leg = "partition a ?m ps"
   let ?lt = "fst ?leg"
   let ?eq = "fst (snd ?leg)"
   let ?gt = "snd (snd ?leg)"
   let ?rem = "length ps div 2 - length ?lt"
   let ?l = "?lt @ take ?rem ?eq"
   let ?r = "drop ?rem ?eq @ ?gt"
 
   have *: "(?lt, ?eq, ?gt) = partition a ?m ps"
     by simp
   have "length ?lt \<le> (length ps - 1) div 2"
     using assms * partition_length(2) size_axis_median_length(1) by presburger
   moreover have "length ?gt \<le> length ps div 2"
     using assms * partition_length(4) size_axis_median_length(2) by presburger
   moreover have "length ps = length ?lt + length ?eq + length ?gt"
     using * partition_length(1) by simp
   ultimately have L: "length ?l = length ps div 2"
     by simp
 
   have **: "(?l, ?m, ?r) = partition_by_median a ps"
     by (auto simp add: Let_def partition_by_median_def split: prod.splits)
   hence "length ps = length ?l + length ?r"
     using partition_by_median_length_1 by blast
   hence "length ?l \<le> length ?r" "length ?r - length ?l \<le> 1"
     using L by linarith+
 
   thus "length l \<le> length r" "length r - length l \<le> 1" 
     using ** by (metis Pair_inject assms(1))+
 qed
 
 lemma partition_by_median_length_3: 
   assumes "(l, m, r) = partition_by_median a ps" "0 < length ps"
   shows "length l < length ps"
 proof (rule ccontr)
   assume *: "\<not> (length l < length ps)"
   have "length ps = length l + length r"
     using partition_by_median_length_1 assms(1) by simp
   hence "length l = length ps" "length r = 0"
     using * by simp_all
   moreover have "length l \<le> length r"
     using partition_by_median_length_2 assms by fastforce+
   ultimately show "False" using assms(2) by simp
 qed
 
 lemma partition_by_median_length_4: 
   assumes "(l, m, r) = partition_by_median a ps" "1 < length ps"
   shows "length r < length ps"
 proof (rule ccontr)
   assume *: "\<not> (length r < length ps)"
   have "length ps = length l + length r"
     using partition_by_median_length_1 assms(1) by simp
   hence "length r = length ps" "length l = 0"
     using * by simp_all
   moreover have "length r - length l \<le> 1"
     using partition_by_median_length_2 assms by fastforce+
   ultimately show "False" using assms(2) by simp
 qed
 
 lemma partition_by_median_length_5:
   assumes "(l, m, r) = partition_by_median a ps" "1 < length ps"
   shows "0 < length l"
     and "0 < length r"
   using assms partition_by_median_length_1 partition_by_median_length_4 apply simp
   using assms partition_by_median_length_1 partition_by_median_length_3 by fastforce
 
 lemmas partition_by_median_length = 
   partition_by_median_length_1 partition_by_median_length_2
   partition_by_median_length_3 partition_by_median_length_4
   partition_by_median_length_5
 
 
 subsection \<open>Building the Tree\<close>
 
 function (sequential) build :: "dimension \<Rightarrow> point list \<Rightarrow> kdt" where
   "build _ [] = undefined" (* We never hit this case recursively. Only if the original input is really [].*)
 | "build k [p] = Leaf p" 
 | "build k ps = (
     let a = widest_spread ps in
     let (l, m, r) = partition_by_median a ps in
     Node a m (build k l) (build k r)
   )"
   by pat_completeness auto
 termination build
   using partition_by_median_length(4,5)
   apply (relation "measure (\<lambda>( _, ps). length ps)")
   apply (auto)
   apply fastforce+
   done
 
 
 text \<open>
   Setting up different build simps for length induct.
 \<close>
 
 lemma build_simp_1:
   "ps = [p] \<Longrightarrow> build k ps = Leaf p"
   by simp
 
 lemma build_simp_2:
   "ps = p\<^sub>0 # p\<^sub>1 # ps' \<Longrightarrow> a = widest_spread ps \<Longrightarrow> (l, m, r) = partition_by_median a ps \<Longrightarrow> build k ps = Node a m (build k l) (build k r)"
   using build.simps(3) by (auto simp add: Let_def split: prod.splits)
 
 lemma length_ps_gt_1:
   "1 < length ps \<Longrightarrow> \<exists>p\<^sub>0 p\<^sub>1 ps'. ps = p\<^sub>0 # p\<^sub>1 # ps'"
   by (induction ps) (auto simp add: neq_Nil_conv)
 
 lemma build_simp_3:
   "1 < length ps \<Longrightarrow> a = widest_spread ps \<Longrightarrow> (l, m, r) = partition_by_median a ps \<Longrightarrow> build k ps = Node a m (build k l) (build k r)"
   using build_simp_2 length_ps_gt_1 by fast
 
 lemmas build_simps[simp] = build_simp_1 build_simp_3
 
 declare build.simps[simp del]
 
 
 text \<open>
   The main theorems.
 \<close>
 
 theorem build_set:
   assumes "0 < length ps"
   shows "set ps = set_kdt (build k ps)"
   using assms
 proof (induction ps rule: length_induct)
   case (1 ps)
   then show ?case
   proof (cases "length ps \<le> 1")
     case True
     then obtain p where "ps = [p]"
       using "1.prems" by (cases ps) auto
     thus ?thesis
       by simp
   next
     case False
 
     let ?a = "widest_spread ps"
     let ?lmr = "partition_by_median ?a ps"
     let ?l = "fst ?lmr"
     let ?m = "fst (snd ?lmr)"
     let ?r = "snd (snd ?lmr)"
 
     have "set ?l = set_kdt (build k ?l)" "set ?r = set_kdt (build k ?r)" 
       using False partition_by_median_length(4,5,6,7)[of ?l ?m ?r ?a ps] "1.IH" by force+
     moreover have "set ps = set ?l \<union> set ?r"
       using partition_by_median_set by (metis prod.collapse)
     moreover have "build k ps = Node ?a ?m (build k ?l) (build k ?r)"
       using False by simp
     ultimately show ?thesis
       by auto
   qed
 qed
 
 theorem build_invar:
   assumes "0 < length ps" "\<forall>p \<in> set ps. dim p = k" "distinct ps" "0 < k"
   shows "invar k (build k ps)"
   using assms
 proof (induction ps rule: length_induct)
   case (1 ps)
   then show ?case
   proof (cases "length ps \<le> 1")
     case True
     then obtain p where P: "ps = [p]"
       using "1.prems"(1) by (cases ps) auto
     hence "dim p = k"
       using "1.prems"(2) by simp
     thus ?thesis
       using P by simp
   next
     case False
 
     let ?a = "widest_spread ps"
     let ?lmr = "partition_by_median ?a ps"
     let ?l = "fst ?lmr"
     let ?m = "fst (snd ?lmr)"
     let ?r = "snd (snd ?lmr)"
 
     have 1: "length ps = length ?l + length ?r"
       using partition_by_median_length(1) by (metis prod.collapse)+
     hence 2: "length ?l < length ps" "length ?r < length ps"
       using False partition_by_median_length(4,5) not_le_imp_less "1.prems" by (metis prod.collapse)+
     hence 3: "0 < length ?l" "0 < length ?r"
       using 1 False partition_by_median_length(6,7) by simp_all
     moreover have 4: "set ps = set ?l \<union> set ?r"
       using partition_by_median_set by (metis prod.collapse)
     moreover have "distinct ?l" "distinct ?r" and 5: "set ?l \<inter> set ?r = {}"
       using "1.prems"(3) 1 4 by (metis card_distinct distinct_append distinct_card length_append set_append)+
     moreover have "\<forall>p \<in> set ?l .dim p = k" "\<forall>p \<in> set ?r .dim p = k"
       using "1.prems"(2) 4 5 by simp_all
     ultimately have "invar k (build k ?l)" "invar k (build k ?r)"
       using "1.IH" 2 by (simp_all add: "1.prems"(4))
     moreover have "\<forall>p \<in> set ?l. p ! ?a \<le> ?m" "\<forall>p \<in> set ?r. ?m \<le> p ! ?a"
       using partition_by_median_filter by (metis prod.collapse)+
     moreover have "build k ps = Node ?a ?m (build k ?l) (build k ?r)"
       using False by simp
     moreover have "?a < k"
       using "1.prems"(1,2,4) widest_spread_lt_k by auto
     ultimately show ?thesis 
       using 3 5 build_set by auto
   qed
 qed
 
 theorem build_widest_spread:
   assumes "0 < length ps" "\<forall>p \<in> set ps. dim p = k"
   shows "widest_spread_invar k (build k ps)"
   using assms
 proof (induction ps rule: length_induct)
   case (1 ps)
   then show ?case
   proof (cases "length ps \<le> 1")
     case True
     then obtain p where "ps = [p]"
       using "1.prems" by (cases ps) auto
     thus ?thesis by simp
   next
     case False
 
     let ?a = "widest_spread ps"
     let ?lmr = "partition_by_median ?a ps"
     let ?l = "fst ?lmr"
     let ?m = "fst (snd ?lmr)"
     let ?r = "snd (snd ?lmr)"
 
     have 1: "length ps = length ?l + length ?r"
       using partition_by_median_length(1) by (metis prod.collapse)+
     hence 2: "length ?l < length ps" "length ?r < length ps"
-      using False partition_by_median_length(4,5) not_le_imp_less "1.prems" by (metis prod.collapse)+
+      using False partition_by_median_length(4,5) not_le_imp_less "1.prems"
+      apply auto
+      by (metis prod.collapse)+
     hence 3: "0 < length ?l" "0 < length ?r"
       using 1 False partition_by_median_length(6,7) by simp_all
     moreover have 4: "set ps = set ?l \<union> set ?r"
       using partition_by_median_set by (metis prod.collapse)
     moreover have "\<forall>p \<in> set ?l .dim p = k" "\<forall>p \<in> set ?r .dim p = k"
       using "1.prems"(2) 4 by simp_all
     ultimately have "widest_spread_invar k (build k ?l)" "widest_spread_invar k (build k ?r)"
       using "1.IH" 2 by simp_all
     moreover have "is_widest_spread ?a k (set_kdt (build k ?l) \<union> set_kdt (build k ?r))"
       using widest_spread_is_widest_spread "1.prems" 3 4 build_set by fastforce
     moreover have "build k ps = Node ?a ?m (build k ?l) (build k ?r)"
       using False by simp
     ultimately show ?thesis
       by auto
   qed
 qed
 
 theorem build_size:
   assumes "0 < length ps"
   shows "size_kdt (build k ps) = length ps"
   using assms
 proof (induction ps rule: length_induct)
   case (1 ps)
   then show ?case
   proof (cases "length ps \<le> 1")
     case True
     then obtain p where "ps = [p]"
       using "1.prems" by (cases ps) auto
     thus ?thesis by simp
   next
     case False
 
     let ?a = "widest_spread ps"
     let ?lmr = "partition_by_median ?a ps"
     let ?l = "fst ?lmr"
     let ?m = "fst (snd ?lmr)"
     let ?r = "snd (snd ?lmr)"
 
     have "size_kdt (build k ?l) = length ?l" "size_kdt (build k ?r) = length ?r" 
       using False partition_by_median_length(4,5,6,7)[of ?l ?m ?r ?a ps] "1.IH" by force+
     moreover have "build k ps = Node ?a ?m (build k ?l) (build k ?r)"
       using False by simp
     ultimately show ?thesis
       using partition_by_median_length(1) by (metis prod.collapse size_kdt.simps(2))
   qed
 qed
 
 theorem build_balanced:
   assumes "0 < length ps"
   shows "balanced (build k ps)"
   using assms
 proof (induction ps rule: length_induct)
   case (1 ps)
   show ?case
   proof (cases "length ps \<le> 1")
     case True
     then obtain p where "ps = [p]"
       using "1.prems" by (cases ps) auto
     thus ?thesis 
       unfolding balanced_def by simp
   next
     case False
 
     let ?a = "widest_spread ps"
     let ?lmr = "partition_by_median ?a ps"
     let ?l = "fst ?lmr"
     let ?m = "fst (snd ?lmr)"
     let ?r = "snd (snd ?lmr)"
 
     have 0: "length ps = length ?l + length ?r" "length ?r - length ?l \<le> 1" "length ?l \<le> length ?r"
       using partition_by_median_length(1,2,3) "1.prems" by (metis prod.collapse)+
     hence 1: "length ?l + 1 = length ?r \<or> length ?l = length ?r"
       by linarith
     moreover have 2: "length ?l < length ps" "length ?r < length ps"
       using False 0 by auto
     moreover have 3: "0 < length ?l" "0 < length ?r"
       using "1.prems" 0 1 2 by linarith+
     ultimately have 4: "balanced (build k ?l)" "balanced (build k ?r)"
       using "1.IH" by simp_all
     have "build k ps = Node ?a ?m (build k ?l) (build k ?r)"
       using False by simp
     moreover have "size_kdt (build k ?l) + 1 = size_kdt (build k ?r) \<or> size_kdt (build k ?l) = size_kdt (build k ?r)"
       using 1 3 build_size by simp
     ultimately show ?thesis
       using 4 balanced_Node_if_wbal2 by auto
   qed
 qed
 
 lemma complete_if_balanced_size_2powh:
   assumes "balanced kdt" "size_kdt kdt = 2 ^ h"
   shows "complete kdt"
 proof (rule ccontr)
   assume "\<not> complete kdt"
   hence "2 ^ (min_height kdt) < size_kdt kdt" "size_kdt kdt < 2 ^ height kdt"
     by (simp_all add: min_height_size_if_incomplete size_height_if_incomplete)
   hence "height kdt - min_height kdt > 1"
     using assms(2) by simp
   hence "\<not> balanced kdt"
     using balanced_def by simp
   thus "False"
     using assms(1) by simp
 qed
 
 theorem build_complete:
   assumes "length ps = 2 ^ h"
   shows "complete (build k ps)"
   using assms complete_if_balanced_size_2powh
   by (simp add: build_balanced build_size)
 
 corollary build_height:
   "length ps = 2 ^ h \<Longrightarrow> length ps = 2 ^ (height (build k ps))"
   using build_complete build_size complete_iff_size by auto
 
 end
\ No newline at end of file
diff --git a/thys/Kruskal/UGraph_Impl.thy b/thys/Kruskal/UGraph_Impl.thy
--- a/thys/Kruskal/UGraph_Impl.thy
+++ b/thys/Kruskal/UGraph_Impl.thy
@@ -1,349 +1,349 @@
 section "Kruskal on UGraphs"
 
 theory UGraph_Impl
 imports
  Kruskal_Impl UGraph
 begin
 
 definition "\<alpha> = (\<lambda>(u,w,v). Upair u v)"
 
 subsection "Interpreting \<open>Kruskl_Impl\<close> with a UGraph"
 
 abbreviation (in uGraph)
   "getEdges_SPEC csuper_E
     \<equiv> (SPEC (\<lambda>L. distinct (map \<alpha> L) \<and> \<alpha> ` set L = E 
                 \<and> (\<forall>(a, wv, b)\<in>set L. w (\<alpha> (a, wv, b)) = wv) \<and> set L \<subseteq> csuper_E))"
 
 locale uGraph_impl = uGraph E w for E :: "nat uprod set" and w :: "nat uprod \<Rightarrow> int" +
   fixes getEdges_impl :: "(nat \<times> int \<times> nat) list Heap" and csuper_E :: "(nat \<times> int \<times> nat) set" 
   assumes getEdges_impl:
     "(uncurry0 getEdges_impl, uncurry0 (getEdges_SPEC csuper_E))
        \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
 begin
 
  
 
-  abbreviation "V \<equiv> (UNION E set_uprod)"
+  abbreviation "V \<equiv> \<Union> (set_uprod ` E)"
 
 
   lemma max_node_is_Max_V: " E = \<alpha> ` set la \<Longrightarrow>  max_node la = Max (insert 0 V)"
   proof -
     assume E: "E = \<alpha> ` set la"
     have *: "fst ` set la \<union> (snd \<circ> snd) ` set la = (\<Union>x\<in>set la. case x of (x1, x1a, x2a) \<Rightarrow> {x1, x2a})"
       by auto force 
     show ?thesis  
     unfolding E using *
     by (auto simp add: \<alpha>_def  max_node_def prod.case_distrib) 
   qed
 
 
 
 
 sublocale s: Kruskal_Impl E "\<Union>(set_uprod ` E)" set_uprod "\<lambda>u v e. Upair u v = e"
   "subforest" "uconnectedV"  w \<alpha> "PR_CONST (\<lambda>(u,w,v). RETURN (u,v))"
   "PR_CONST (getEdges_SPEC csuper_E)"
  getEdges_impl "csuper_E" " (\<lambda>(u,w,v). return (u,v))" 
   unfolding subforest_def
 proof (unfold_locales, goal_cases) 
   show "finite E" by simp
 next
   fix E'
   assume "forest E' \<and> E' \<subseteq> E"
   then show "E' \<subseteq> E" by auto
 next
   show "forest {} \<and> {} \<subseteq> E" apply (auto simp: decycle_def forest_def)
     using epath.elims(2) by fastforce 
 next
   fix X Y
   assume "forest X \<and> X \<subseteq> E" "Y \<subseteq> X" 
   then show "forest Y \<and> Y \<subseteq> E" using forest_mono by auto
 next
   case (5 u v)
   then show ?case unfolding uconnected_def apply auto 
     using epath.elims(2) by force 
 next
-  case (6 E1 E2 u v) 
-  then have "(u, v) \<in> (uconnected E1)" and uv: "u \<in> (UNION E set_uprod)" "v\<in>(UNION E set_uprod)"
+  case (6 E1 E2 u v)
+  then have "(u, v) \<in> (uconnected E1)" and uv: "u \<in> V" "v \<in> V"
     by auto
   then obtain p where 1: "epath E1 u p v" unfolding uconnected_def by auto 
   from 6 uv have 2: "\<not>(\<exists>p.  epath E2 u p v)" unfolding uconnected_def by auto
   from 1 2 have "\<exists>a b. (a, b) \<notin> uconnected E2
            \<and> Upair a b \<notin> E2 \<and> Upair a b \<in> E1" by(rule findaugmenting_edge)
   then show ?case by auto
 next
   case (7 F e u v)
   note f = \<open>forest F \<and> F \<subseteq> E\<close>
   note notin = \<open>e \<in> E - F\<close> \<open>Upair u v = e\<close>
   from notin ecard2 have unv: "u\<noteq>v" by fastforce
   show "(forest (insert e F) \<and> insert e F \<subseteq> E) = ((u, v) \<notin> uconnectedV F)"
   proof
     assume a: "forest (insert e F) \<and> insert e F \<subseteq> E "
     have "(u, v) \<notin> uconnected F" apply(rule insert_stays_forest_means_not_connected)
       using notin a unv by auto
-    then show "((u, v) \<notin> Restr (uconnected F) (UNION E set_uprod))" by auto
+    then show "((u, v) \<notin> Restr (uconnected F) V)" by auto
   next 
-    assume a: "(u, v) \<notin> Restr (uconnected F) (UNION E set_uprod)"
+    assume a: "(u, v) \<notin> Restr (uconnected F) V"
     have "forest (insert (Upair u v) F)" apply(rule augment_forest_overedges[where E=E])
       using notin f a unv  by auto 
     moreover have "insert e F \<subseteq> E"
       using notin f by auto
     ultimately show "forest (insert e F) \<and> insert e F \<subseteq> E" using notin by auto
   qed
 next      
   fix F
   assume "F\<subseteq>E"
   show "equiv V (uconnectedV F)" by(rule equiv_vert_uconnected)
 next                                 
   case (9 F)
   then show ?case  by auto
 next
   case (10 x y F)
   then show ?case using insert_uconnectedV_per' by metis
 next
   case (11 x)
   then show ?case apply(cases x) by auto
 next
   case (12 u v e)
   then show ?case by auto
 next
   case (13 u v e)
   then show ?case by auto
 next
   case (14 a F e)
   then show ?case using ecard2 by force
 next
   case (15 v)
   then show ?case using ecard2 by auto
 next
   case 16
   show "V \<subseteq> V" by auto
 next
   case 17
   show "finite V" by simp
 next
   case (18 a b e T)
   then show ?case 
     apply auto
     subgoal unfolding uconnected_def apply auto apply(rule exI[where x="[e]"]) apply simp
         using ecard2 by force
     subgoal by force
     subgoal by force 
     done
 next
   case (19 xi x)
   then show ?case by (auto split: prod.splits simp: \<alpha>_def)
 next
   case 20
   show ?case by auto
 next
   case 21
   show ?case using getEdges_impl by simp
 next
   case (22 l)
   from max_node_is_Max_V[OF 22] show "max_node l = Max (insert 0 V)" .
 next
   case (23)
   then show ?case
     apply sepref_to_hoare by sep_auto 
 qed
  
 lemma spanningForest_eq_basis: "spanningForest = s.basis"
   unfolding spanningForest_def  s.basis_def by auto
 
 lemma minSpanningForest_eq_minbasis: "minSpanningForest = s.minBasis"
   unfolding minSpanningForest_def  s.MSF_def spanningForest_eq_basis by auto
 
 lemma kruskal_correct': 
   "<emp> kruskal getEdges_impl (\<lambda>(u,w,v). return (u,v)) ()
     <\<lambda>r. \<up> (distinct r \<and> set r \<subseteq> csuper_E \<and> s.MSF (set (map \<alpha> r)))>\<^sub>t"
   using s.kruskal_correct_forest   by auto
 
 lemma kruskal_correct:
   "<emp> kruskal getEdges_impl (\<lambda>(u,w,v). return (u,v)) ()
     <\<lambda>r. \<up> (distinct r \<and> set r \<subseteq> csuper_E \<and> minSpanningForest (set (map \<alpha> r)))>\<^sub>t"
   using s.kruskal_correct_forest minSpanningForest_eq_minbasis  by auto
 
 end
 
 subsection "Kruskal on UGraph from list of concrete edges"
 
 
 definition "uGraph_from_list_\<alpha>_weight L e = (THE w. \<exists>a' b'. Upair a' b' = e \<and> (a', w, b') \<in> set L)"
 abbreviation "uGraph_from_list_\<alpha>_edges L \<equiv> \<alpha> ` set L"
 
 locale fromlist = fixes
   L :: "(nat \<times> int \<times> nat) list"
 assumes dist: "distinct (map \<alpha> L)" and no_selfloop: "\<forall>u w v. (u,w,v)\<in>set L \<longrightarrow> u\<noteq>v"
 begin
 
 lemma not_distinct_map: "a\<in>set l \<Longrightarrow> b\<in>set l \<Longrightarrow> a\<noteq>b \<Longrightarrow> \<alpha> a = \<alpha> b \<Longrightarrow> \<not> distinct (map \<alpha> l)"
    
   by (meson distinct_map_eq)  
 
 lemma ii: "(a, aa, b) \<in> set L \<Longrightarrow> uGraph_from_list_\<alpha>_weight L (Upair a b) = aa"
   unfolding uGraph_from_list_\<alpha>_weight_def
   apply rule
   subgoal by auto
   apply clarify
   subgoal for w a' b'
     apply(auto) 
     subgoal using distinct_map_eq[OF dist, of "(a, aa, b)" "(a, w, b)"]
       unfolding \<alpha>_def by auto
     subgoal using distinct_map_eq[OF dist, of "(a, aa, b)" "(a', w, b')"]
       unfolding \<alpha>_def by fastforce
     done
   done
  
 sublocale uGraph_impl "\<alpha> ` set L" "uGraph_from_list_\<alpha>_weight L" "return L" "set L" 
 proof (unfold_locales)
   fix e assume *: "e \<in> \<alpha> ` set L"
   from * obtain u w v where "(u,w,v) \<in> set L" "e = \<alpha> (u, w, v)" by auto
   then show "proper_uprod e" using no_selfloop unfolding \<alpha>_def by auto
 next
   show "finite (\<alpha> ` set L)" by auto
 next
   show "(uncurry0 (return L),uncurry0((SPEC
           (\<lambda>La. distinct (map \<alpha> La) \<and> \<alpha> ` set La = \<alpha> ` set L 
       \<and> (\<forall>(aa, wv, ba)\<in>set La. uGraph_from_list_\<alpha>_weight L (\<alpha> (aa, wv, ba)) = wv)
       \<and> set La \<subseteq> set L))))
     \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
     apply sepref_to_hoare using dist  apply sep_auto
     subgoal using ii unfolding \<alpha>_def by auto
     subgoal by simp
     subgoal by (auto simp: pure_fold list_assn_emp)   
     done
 qed
   
 lemmas kruskal_correct = kruskal_correct
 
 definition (in -) "kruskal_algo L = kruskal (return L) (\<lambda>(u,w,v). return (u,v)) ()"
 
 end 
 
 subsection \<open>Outside the locale\<close>
 
 definition uGraph_from_list_invar :: "(nat\<times>int\<times>nat) list \<Rightarrow> bool" where
   "uGraph_from_list_invar L = (distinct (map \<alpha> L) \<and> (\<forall>p\<in>set L. case p of (u,w,v) \<Rightarrow>u\<noteq>v))"
 
 lemma uGraph_from_list_invar_conv: "uGraph_from_list_invar L = fromlist L"
   by(auto simp add: uGraph_from_list_invar_def fromlist_def)
 
 lemma uGraph_from_list_invar_subset: 
   "uGraph_from_list_invar L \<Longrightarrow> set L'\<subseteq> set L \<Longrightarrow> distinct L' \<Longrightarrow> uGraph_from_list_invar L'"
   unfolding uGraph_from_list_invar_def by (auto simp: distinct_map inj_on_subset)  
 
 
 lemma  uGraph_from_list_\<alpha>_inj_on: "uGraph_from_list_invar E \<Longrightarrow> inj_on \<alpha> (set E)"
   by(auto simp: distinct_map uGraph_from_list_invar_def  )
 
 lemma sum_easier: "uGraph_from_list_invar L 
     \<Longrightarrow> set E \<subseteq> set L
     \<Longrightarrow> sum (uGraph_from_list_\<alpha>_weight L) (uGraph_from_list_\<alpha>_edges E) = sum (\<lambda>(u,w,v). w) (set E)"
  proof -
   assume a: "uGraph_from_list_invar L"
   assume b: "set E \<subseteq> set L" 
 
   have *: "\<And>e. e\<in>set E \<Longrightarrow>
    ((\<lambda>e. THE w. \<exists>a' b'. Upair a' b' = e \<and> (a', w, b') \<in> set L) \<circ> \<alpha>) e
        = (case e of (u, w, v) \<Rightarrow> w)"
     apply simp
     apply(rule the_equality) 
     subgoal using b by(auto simp: \<alpha>_def split: prod.splits)   
     subgoal using a b apply(auto simp: uGraph_from_list_invar_def distinct_map split: prod.splits)  
       using \<alpha>_def 
       by (smt \<alpha>_def inj_onD old.prod.case prod.inject set_mp)  
     done
  
   have inj_on_E: "inj_on \<alpha> (set E)"
     apply(rule inj_on_subset)
     apply(rule uGraph_from_list_\<alpha>_inj_on) by fact+ 
 
   show ?thesis
     unfolding uGraph_from_list_\<alpha>_weight_def
     apply(subst sum.reindex[OF inj_on_E] ) 
     using * by auto 
 qed
  
 
 
 lemma corr: "uGraph_from_list_invar L \<Longrightarrow>
   <emp> kruskal_algo L
      <\<lambda>F. \<up> (uGraph_from_list_invar F \<and> set F \<subseteq> set L \<and>               
        uGraph.minSpanningForest (uGraph_from_list_\<alpha>_edges L)
          (uGraph_from_list_\<alpha>_weight L) (uGraph_from_list_\<alpha>_edges F))>\<^sub>t"
   apply(sep_auto heap: fromlist.kruskal_correct
           simp: uGraph_from_list_invar_conv kruskal_algo_def  ) 
   using uGraph_from_list_invar_subset uGraph_from_list_invar_conv by simp
 
 
 
 lemma "uGraph_from_list_invar L \<Longrightarrow>
   <emp> kruskal_algo L
      <\<lambda>F. \<up> (uGraph_from_list_invar F \<and> set F \<subseteq> set L \<and>
        uGraph.spanningForest (uGraph_from_list_\<alpha>_edges L) (uGraph_from_list_\<alpha>_edges F)
       \<and> (\<forall>F'. uGraph.spanningForest (uGraph_from_list_\<alpha>_edges L) (uGraph_from_list_\<alpha>_edges F')
           \<longrightarrow> set F' \<subseteq> set L \<longrightarrow>  sum (\<lambda>(u,w,v). w) (set F) \<le> sum (\<lambda>(u,w,v). w) (set F')))>\<^sub>t"
 proof -
   assume a: "uGraph_from_list_invar L"
   then interpret fromlist L apply unfold_locales by (auto simp: uGraph_from_list_invar_def)
   from a show ?thesis
     by(sep_auto heap: corr simp: minSpanningForest_def sum_easier)
 qed
 
 
 subsection \<open>Kruskal with input check\<close>
 
 definition "kruskal' L = kruskal (return L)  (\<lambda>(u,w,v). return (u,v)) ()"
 
 definition "kruskal_checked L = (if uGraph_from_list_invar L
                              then do { F \<leftarrow> kruskal' L; return (Some F) }
                              else return None)"
 
  
 lemma "<emp> kruskal_checked L <\<lambda>
     Some F \<Rightarrow> \<up> (uGraph_from_list_invar L \<and> set F \<subseteq> set L
        \<and> uGraph.minSpanningForest (uGraph_from_list_\<alpha>_edges L) (uGraph_from_list_\<alpha>_weight L)
            (uGraph_from_list_\<alpha>_edges F))
   | None \<Rightarrow> \<up> (\<not> uGraph_from_list_invar L)>\<^sub>t"
   unfolding kruskal_checked_def
   apply(cases "uGraph_from_list_invar L") apply simp_all
   subgoal proof -
     assume [simp]: "uGraph_from_list_invar L"
     then interpret fromlist L apply unfold_locales by(auto simp: uGraph_from_list_invar_def)
     show ?thesis unfolding kruskal'_def by (sep_auto heap: kruskal_correct)   
   qed
   subgoal by sep_auto
   done 
 
 subsection \<open>Code export\<close>
 
 export_code uGraph_from_list_invar checking SML_imp
 export_code kruskal_checked checking SML_imp
 
 ML_val \<open>
   val export_nat = @{code integer_of_nat}
   val import_nat = @{code nat_of_integer}
   val export_int = @{code integer_of_int}
   val import_int = @{code int_of_integer}
   val import_list = map (fn (a,b,c) => (import_nat a, (import_int b, import_nat c)))
   val export_list = map (fn (a,(b,c)) => (export_nat a, export_int b, export_nat c))
   val export_Some_list = (fn SOME l => SOME (export_list l) | NONE => NONE)
 
   fun kruskal l = @{code kruskal} (fn () => import_list l) (fn (a,(_,c)) => fn () => (a,c)) () ()
                      |> export_list 
   fun kruskal_checked l = @{code kruskal_checked} (import_list l) ()  |> export_Some_list
 
 
   val result = kruskal [(1,~9,2),(2,~3,3),(3,~4,1)]
   val result4 = kruskal [(1,~100,4), (3,64,5), (1,13,2), (3,20,2), (2,5,5), (4,80,3), (4,40,5)]
 
   val result' = kruskal_checked [(1,~9,2),(2,~3,3),(3,~4,1)]
   val result1' = kruskal_checked [(1,~9,2),(2,~3,3),(3,~4,1),(1,5,3)]
   val result2' = kruskal_checked [(1,~9,2),(2,~3,3),(3,~4,1),(3,~4,1)]
   val result3' = kruskal_checked [(1,~9,2),(2,~3,3),(3,~4,1),(1,~4,1)]
   val result4' = kruskal_checked [(1,~100,4), (3,64,5), (1,13,2), (3,20,2),
                                    (2,5,5), (4,80,3), (4,40,5)]
 \<close>
 
 
 end
\ No newline at end of file
diff --git a/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Construction.thy b/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Construction.thy
--- a/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Construction.thy
+++ b/thys/LTL_Master_Theorem/LTL_to_DRA/DRA_Construction.thy
@@ -1,440 +1,443 @@
 (*
     Author:   Benedikt Seidl
     License:  BSD
 *)
 
 section \<open>Constructing DRAs for LTL Formulas\<close>
 
 theory DRA_Construction
   imports
     Transition_Functions
 
     "../Quotient_Type"
     "../Omega_Words_Fun_Stream"
 
     "../Logical_Characterization/Master_Theorem"
 
     Transition_Systems_and_Automata.DBA_Combine
     Transition_Systems_and_Automata.DCA_Combine
     Transition_Systems_and_Automata.DRA_Combine
 begin
 
 \<comment> \<open>We use prefix and suffix on infinite words.\<close>
 hide_const Sublist.prefix Sublist.suffix
 
 locale dra_construction = transition_functions eq + quotient eq Rep Abs
   for
     eq :: "'a ltln \<Rightarrow> 'a ltln \<Rightarrow> bool" (infix "\<sim>" 75)
   and
     Rep :: "'ltlq \<Rightarrow> 'a ltln"
   and
     Abs :: "'a ltln \<Rightarrow> 'ltlq"
 begin
 
 subsection \<open>Lifting Setup\<close>
 
 abbreviation true\<^sub>n_lifted :: "'ltlq" ("\<up>true\<^sub>n") where
   "\<up>true\<^sub>n \<equiv> Abs true\<^sub>n"
 
 abbreviation false\<^sub>n_lifted :: "'ltlq" ("\<up>false\<^sub>n") where
   "\<up>false\<^sub>n \<equiv> Abs false\<^sub>n"
 
 abbreviation af_letter_lifted :: "'a set \<Rightarrow> 'ltlq \<Rightarrow> 'ltlq" ("\<up>afletter") where
   "\<up>afletter \<nu> \<phi> \<equiv> Abs (af_letter (Rep \<phi>) \<nu>)"
 
 abbreviation af_lifted :: "'ltlq \<Rightarrow> 'a set list \<Rightarrow> 'ltlq" ("\<up>af") where
   "\<up>af \<phi> w \<equiv> fold \<up>afletter w \<phi>"
 
 abbreviation GF_advice_lifted :: "'ltlq \<Rightarrow> 'a ltln set \<Rightarrow> 'ltlq" ("_\<up>[_]\<^sub>\<nu>" [90,60] 89) where
   "\<phi>\<up>[X]\<^sub>\<nu> \<equiv> Abs ((Rep \<phi>)[X]\<^sub>\<nu>)"
 
 
 lemma af_letter_lifted_semantics:
   "\<up>afletter \<nu> (Abs \<phi>) = Abs (af_letter \<phi> \<nu>)"
   by (metis Rep_Abs_eq af_letter_congruent Abs_eq)
 
 lemma af_lifted_semantics:
   "\<up>af (Abs \<phi>) w = Abs (af \<phi> w)"
   by (induction w rule: rev_induct) (auto simp: Abs_eq, insert Rep_Abs_eq af_letter_congruent eq_sym, blast)
 
 lemma af_lifted_range:
   "range (\<up>af (Abs \<phi>)) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
   using af_lifted_semantics af_nested_prop_atoms by blast
 
 
 definition af_letter\<^sub>F_lifted :: "'a ltln \<Rightarrow> 'a set \<Rightarrow> 'ltlq \<Rightarrow> 'ltlq" ("\<up>afletter\<^sub>F")
 where
   "\<up>afletter\<^sub>F \<phi> \<nu> \<psi> \<equiv> Abs (af_letter\<^sub>F \<phi> (Rep \<psi>) \<nu>)"
 
 definition af_letter\<^sub>G_lifted :: "'a ltln \<Rightarrow> 'a set \<Rightarrow> 'ltlq \<Rightarrow> 'ltlq" ("\<up>afletter\<^sub>G")
 where
   "\<up>afletter\<^sub>G \<phi> \<nu> \<psi> \<equiv> Abs (af_letter\<^sub>G \<phi> (Rep \<psi>) \<nu>)"
 
 lemma af_letter\<^sub>F_lifted_semantics:
   "\<up>afletter\<^sub>F \<phi> \<nu> (Abs \<psi>) = Abs (af_letter\<^sub>F \<phi> \<psi> \<nu>)"
   by (metis af_letter\<^sub>F_lifted_def Rep_inverse af_letter\<^sub>F_def af_letter_congruent Abs_eq)
 
 lemma af_letter\<^sub>G_lifted_semantics:
   "\<up>afletter\<^sub>G \<phi> \<nu> (Abs \<psi>) = Abs (af_letter\<^sub>G \<phi> \<psi> \<nu>)"
   by (metis af_letter\<^sub>G_lifted_def Rep_inverse af_letter\<^sub>G_def af_letter_congruent Abs_eq)
 
 abbreviation af\<^sub>F_lifted :: "'a ltln \<Rightarrow> 'ltlq \<Rightarrow> 'a set list \<Rightarrow> 'ltlq" ("\<up>af\<^sub>F")
 where
   "\<up>af\<^sub>F \<phi> \<psi> w \<equiv> fold (\<up>afletter\<^sub>F \<phi>) w \<psi>"
 
 abbreviation af\<^sub>G_lifted :: "'a ltln \<Rightarrow> 'ltlq \<Rightarrow> 'a set list \<Rightarrow> 'ltlq" ("\<up>af\<^sub>G")
 where
   "\<up>af\<^sub>G \<phi> \<psi> w \<equiv> fold (\<up>afletter\<^sub>G \<phi>) w \<psi>"
 
 lemma af\<^sub>F_lifted_semantics:
   "\<up>af\<^sub>F \<phi> (Abs \<psi>) w = Abs (af\<^sub>F \<phi> \<psi> w)"
   by (induction w rule: rev_induct) (auto simp: af_letter\<^sub>F_lifted_semantics)
 
 lemma af\<^sub>G_lifted_semantics:
   "\<up>af\<^sub>G \<phi> (Abs \<psi>) w = Abs (af\<^sub>G \<phi> \<psi> w)"
   by (induction w rule: rev_induct) (auto simp: af_letter\<^sub>G_lifted_semantics)
 
 lemma af\<^sub>F_lifted_range:
   "nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (F\<^sub>n \<phi>) \<Longrightarrow> range (\<up>af\<^sub>F \<phi> (Abs \<psi>)) \<subseteq>  {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (F\<^sub>n \<phi>)}"
   using af\<^sub>F_lifted_semantics af\<^sub>F_nested_prop_atoms by blast
 
 lemma af\<^sub>G_lifted_range:
   "nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (G\<^sub>n \<phi>) \<Longrightarrow> range (\<up>af\<^sub>G \<phi> (Abs \<psi>)) \<subseteq>  {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (G\<^sub>n \<phi>)}"
   using af\<^sub>G_lifted_semantics af\<^sub>G_nested_prop_atoms by blast
 
 
 definition af_letter\<^sub>\<nu>_lifted :: "'a ltln set \<Rightarrow> 'a set \<Rightarrow> 'ltlq \<times> 'ltlq \<Rightarrow> 'ltlq \<times> 'ltlq" ("\<up>afletter\<^sub>\<nu>")
 where
   "\<up>afletter\<^sub>\<nu> X \<nu> p \<equiv>
     (Abs (fst (af_letter\<^sub>\<nu> X (Rep (fst p), Rep (snd p)) \<nu>)),
      Abs (snd (af_letter\<^sub>\<nu> X (Rep (fst p), Rep (snd p)) \<nu>)))"
 
 abbreviation af\<^sub>\<nu>_lifted :: "'a ltln set \<Rightarrow> 'ltlq \<times> 'ltlq \<Rightarrow> 'a set list \<Rightarrow> 'ltlq \<times> 'ltlq" ("\<up>af\<^sub>\<nu>")
 where
   "\<up>af\<^sub>\<nu> X p w \<equiv> fold (\<up>afletter\<^sub>\<nu> X) w p"
 
 lemma af_letter\<^sub>\<nu>_lifted_semantics:
   "\<up>afletter\<^sub>\<nu> X \<nu> (Abs x, Abs y) = (Abs (fst (af_letter\<^sub>\<nu> X (x, y) \<nu>)), Abs (snd (af_letter\<^sub>\<nu> X (x, y) \<nu>)))"
   by (simp add: af_letter\<^sub>\<nu>_def af_letter\<^sub>\<nu>_lifted_def) (insert GF_advice_congruent Rep_Abs_eq Rep_inverse af_letter_lifted_semantics eq_trans Abs_eq, blast)
 
 lemma af\<^sub>\<nu>_lifted_semantics:
   "\<up>af\<^sub>\<nu> X (Abs \<xi>, Abs \<zeta>) w = (Abs (fst (af\<^sub>\<nu> X (\<xi>, \<zeta>) w)), Abs (snd (af\<^sub>\<nu> X (\<xi>, \<zeta>) w)))"
   apply (induction w rule: rev_induct) 
    apply (auto simp: af_letter\<^sub>\<nu>_lifted_def af_letter\<^sub>\<nu>_lifted_semantics af_letter_lifted_semantics)
   by (metis (no_types, hide_lams) af_letter\<^sub>\<nu>_lifted_def af\<^sub>\<nu>_fst af_letter\<^sub>\<nu>_lifted_semantics eq_fst_iff prod.sel(2))
 
 
 
 subsection \<open>Büchi automata for basic languages\<close>
 
 definition \<AA>\<^sub>\<mu> :: "'a ltln \<Rightarrow> ('a set, 'ltlq) dba" where
   "\<AA>\<^sub>\<mu> \<phi> = dba UNIV (Abs \<phi>) \<up>afletter (\<lambda>\<psi>. \<psi> = \<up>true\<^sub>n)"
 
 definition \<AA>\<^sub>\<mu>_GF :: "'a ltln \<Rightarrow> ('a set, 'ltlq) dba" where
   "\<AA>\<^sub>\<mu>_GF \<phi> = dba UNIV (Abs (F\<^sub>n \<phi>)) (\<up>afletter\<^sub>F \<phi>) (\<lambda>\<psi>. \<psi> = \<up>true\<^sub>n)"
 
 definition \<AA>\<^sub>\<nu> :: "'a ltln \<Rightarrow> ('a set, 'ltlq) dca" where
   "\<AA>\<^sub>\<nu> \<phi> = dca UNIV (Abs \<phi>) \<up>afletter (\<lambda>\<psi>. \<psi> = \<up>false\<^sub>n)"
 
 definition \<AA>\<^sub>\<nu>_FG :: "'a ltln \<Rightarrow> ('a set, 'ltlq) dca" where
   "\<AA>\<^sub>\<nu>_FG \<phi> = dca UNIV (Abs (G\<^sub>n \<phi>)) (\<up>afletter\<^sub>G \<phi>) (\<lambda>\<psi>. \<psi> = \<up>false\<^sub>n)"
 
 
 lemma dba_run:
   "DBA.run (dba UNIV p \<delta> \<alpha>) (to_stream w) p"
   unfolding DBA.run_def by (rule transition_system.snth_run) fastforce
 
 lemma dca_run:
   "DCA.run (dca UNIV p \<delta> \<alpha>) (to_stream w) p"
   unfolding DCA.run_def by (rule transition_system.snth_run) fastforce
 
 
 lemma \<AA>\<^sub>\<mu>_language:
   "\<phi> \<in> \<mu>LTL \<Longrightarrow> to_stream w \<in> DBA.language (\<AA>\<^sub>\<mu> \<phi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
 proof -
   assume "\<phi> \<in> \<mu>LTL"
 
   then have "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<forall>n. \<exists>k\<ge>n. af \<phi> (w[0 \<rightarrow> k]) \<sim> true\<^sub>n)"
     by (meson af_\<mu>LTL af_prefix_true le_cases)
 
   also have "\<dots> \<longleftrightarrow> (\<forall>n. \<exists>k\<ge>n. af \<phi> (w[0 \<rightarrow> Suc k]) \<sim> true\<^sub>n)"
     by (meson af_prefix_true le_SucI order_refl)
 
   also have "\<dots> \<longleftrightarrow> infs (\<lambda>\<psi>. \<psi> = \<up>true\<^sub>n) (DBA.trace (\<AA>\<^sub>\<mu> \<phi>) (to_stream w) (Abs \<phi>))"
     by (simp add: infs_snth \<AA>\<^sub>\<mu>_def DBA.transition_def af_lifted_semantics Abs_eq[symmetric] af_letter_lifted_semantics)
 
   also have "\<dots> \<longleftrightarrow> to_stream w \<in> DBA.language (\<AA>\<^sub>\<mu> \<phi>)"
     unfolding \<AA>\<^sub>\<mu>_def dba.initial_def dba.accepting_def
     by (metis dba_run DBA.language DBA.language_elim dba.sel(2) dba.sel(4))
 
   finally show ?thesis
     by simp
 qed
 
 lemma \<AA>\<^sub>\<mu>_GF_language:
   "\<phi> \<in> \<mu>LTL \<Longrightarrow> to_stream w \<in> DBA.language (\<AA>\<^sub>\<mu>_GF \<phi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>)"
 proof -
   assume "\<phi> \<in> \<mu>LTL"
 
   then have "w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>) \<longleftrightarrow> (\<forall>n. \<exists>k. af (F\<^sub>n \<phi>) (w[n \<rightarrow> k]) \<sim>\<^sub>L true\<^sub>n)"
     using ltl_lang_equivalence.af_\<mu>LTL_GF by blast
 
   also have "\<dots> \<longleftrightarrow> (\<forall>n. \<exists>k>n. af\<^sub>F \<phi> (F\<^sub>n \<phi>) (w[0 \<rightarrow> k]) \<sim> true\<^sub>n)"
     using af\<^sub>F_semantics_ltr af\<^sub>F_semantics_rtl
     using \<open>\<phi> \<in> \<mu>LTL\<close> af_\<mu>LTL_GF calculation by blast
 
   also have "\<dots> \<longleftrightarrow> (\<forall>n. \<exists>k\<ge>n. af\<^sub>F \<phi> (F\<^sub>n \<phi>) (w[0 \<rightarrow> Suc k]) \<sim> true\<^sub>n)"
     by (metis less_Suc_eq_le less_imp_Suc_add)
 
   also have "\<dots> \<longleftrightarrow> infs (\<lambda>\<psi>. \<psi> = \<up>true\<^sub>n) (DBA.trace (\<AA>\<^sub>\<mu>_GF \<phi>) (to_stream w) (Abs (F\<^sub>n \<phi>)))"
     by (simp add: infs_snth \<AA>\<^sub>\<mu>_GF_def DBA.transition_def af\<^sub>F_lifted_semantics Abs_eq[symmetric] af_letter\<^sub>F_lifted_semantics)
 
   also have "\<dots> \<longleftrightarrow> to_stream w \<in> DBA.language (\<AA>\<^sub>\<mu>_GF \<phi>)"
     unfolding \<AA>\<^sub>\<mu>_GF_def dba.initial_def dba.accepting_def
     by (metis dba_run DBA.language DBA.language_elim dba.sel(2) dba.sel(4))
 
   finally show ?thesis
     by simp
 qed
 
 lemma \<AA>\<^sub>\<nu>_language:
   "\<phi> \<in> \<nu>LTL \<Longrightarrow> to_stream w \<in> DCA.language (\<AA>\<^sub>\<nu> \<phi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
 proof -
   assume "\<phi> \<in> \<nu>LTL"
 
   then have "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<exists>n. \<forall>k\<ge>n. \<not> af \<phi> (w[0 \<rightarrow> k]) \<sim> false\<^sub>n)"
     by (meson af_\<nu>LTL af_prefix_false le_cases order_refl)
 
   also have "\<dots> \<longleftrightarrow> (\<exists>n. \<forall>k\<ge>n. \<not> af \<phi> (w[0 \<rightarrow> Suc k]) \<sim> false\<^sub>n)"
     by (meson af_prefix_false le_SucI order_refl)
 
   also have "\<dots> \<longleftrightarrow> fins (\<lambda>\<psi>. \<psi> = \<up>false\<^sub>n) (DCA.trace (\<AA>\<^sub>\<nu> \<phi>) (to_stream w) (Abs \<phi>))"
     by (simp add: infs_snth \<AA>\<^sub>\<nu>_def DBA.transition_def af_lifted_semantics Abs_eq[symmetric] af_letter_lifted_semantics)
 
   also have "\<dots> \<longleftrightarrow> to_stream w \<in> DCA.language (\<AA>\<^sub>\<nu> \<phi>)"
     unfolding \<AA>\<^sub>\<nu>_def dca.initial_def dca.rejecting_def
     by (metis dca_run DCA.language DCA.language_elim dca.sel(2) dca.sel(4))
 
   finally show ?thesis
     by simp
 qed
 
 lemma \<AA>\<^sub>\<nu>_FG_language:
   "\<phi> \<in> \<nu>LTL \<Longrightarrow> to_stream w \<in> DCA.language (\<AA>\<^sub>\<nu>_FG \<phi>) \<longleftrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<phi>)"
 proof -
   assume "\<phi> \<in> \<nu>LTL"
 
   then have "w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<phi>) \<longleftrightarrow> (\<exists>k. \<forall>j. \<not> af (G\<^sub>n \<phi>) (w[k \<rightarrow> j]) \<sim>\<^sub>L false\<^sub>n)"
     using ltl_lang_equivalence.af_\<nu>LTL_FG by blast
 
   also have "\<dots> \<longleftrightarrow> (\<exists>n. \<forall>k>n. \<not> af\<^sub>G \<phi> (G\<^sub>n \<phi>) (w[0 \<rightarrow> k]) \<sim> false\<^sub>n)"
     using af\<^sub>G_semantics_ltr af\<^sub>G_semantics_rtl
     using \<open>\<phi> \<in> \<nu>LTL\<close> af_\<nu>LTL_FG calculation by blast
 
   also have "\<dots> \<longleftrightarrow> (\<exists>n. \<forall>k\<ge>n. \<not> af\<^sub>G \<phi> (G\<^sub>n \<phi>) (w[0 \<rightarrow> Suc k]) \<sim> false\<^sub>n)"
     by (metis less_Suc_eq_le less_imp_Suc_add)
 
   also have "\<dots> \<longleftrightarrow> fins (\<lambda>\<psi>. \<psi> = \<up>false\<^sub>n) (DCA.trace (\<AA>\<^sub>\<nu>_FG \<phi>) (to_stream w) (Abs (G\<^sub>n \<phi>)))"
     by (simp add: infs_snth \<AA>\<^sub>\<nu>_FG_def DBA.transition_def af\<^sub>G_lifted_semantics Abs_eq[symmetric] af_letter\<^sub>G_lifted_semantics)
 
   also have "\<dots> \<longleftrightarrow> to_stream w \<in> DCA.language (\<AA>\<^sub>\<nu>_FG \<phi>)"
     unfolding \<AA>\<^sub>\<nu>_FG_def dca.initial_def dca.rejecting_def
     by (metis dca_run DCA.language DCA.language_elim dca.sel(2) dca.sel(4))
 
   finally show ?thesis
     by simp
 qed
 
 
 lemma \<AA>\<^sub>\<mu>_nodes:
   "DBA.nodes (\<AA>\<^sub>\<mu> \<phi>) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
   unfolding \<AA>\<^sub>\<mu>_def transition_system_initial.nodes_alt_def
   using af_lifted_semantics af_nested_prop_atoms by fastforce
 
 lemma \<AA>\<^sub>\<mu>_GF_nodes:
   "DBA.nodes (\<AA>\<^sub>\<mu>_GF \<phi>) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (F\<^sub>n \<phi>)}"
   unfolding \<AA>\<^sub>\<mu>_GF_def DBA.nodes_def transition_system_initial.nodes_alt_def transition_system.reachable_alt_def
   using af\<^sub>F_nested_prop_atoms[of "F\<^sub>n \<phi>"] by (auto simp: af\<^sub>F_lifted_semantics)
 
 lemma \<AA>\<^sub>\<nu>_nodes:
   "DCA.nodes (\<AA>\<^sub>\<nu> \<phi>) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>}"
   unfolding \<AA>\<^sub>\<nu>_def transition_system_initial.nodes_alt_def
   using af_lifted_semantics af_nested_prop_atoms by fastforce
 
 lemma \<AA>\<^sub>\<nu>_FG_nodes:
   "DCA.nodes (\<AA>\<^sub>\<nu>_FG \<phi>) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms (G\<^sub>n \<phi>)}"
   unfolding \<AA>\<^sub>\<nu>_FG_def DCA.nodes_def transition_system_initial.nodes_alt_def transition_system.reachable_alt_def
   using af\<^sub>G_nested_prop_atoms[of "G\<^sub>n \<phi>"] by (auto simp: af\<^sub>G_lifted_semantics)
 
 
 
 subsection \<open>A DCA checking the GF-advice Function\<close>
 
 definition \<CC> :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> ('a set, 'ltlq \<times> 'ltlq) dca" where
   "\<CC> \<phi> X = dca UNIV (Abs \<phi>, Abs (\<phi>[X]\<^sub>\<nu>)) (\<up>afletter\<^sub>\<nu> X) (\<lambda>p. snd p = \<up>false\<^sub>n)"
 
 lemma \<CC>_language:
   "to_stream w \<in> DCA.language (\<CC> \<phi> X) \<longleftrightarrow> (\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>)"
 proof -
 
   have "(\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>)
         \<longleftrightarrow> (\<exists>m. \<forall>k\<ge>m. \<not> snd (af\<^sub>\<nu> X (\<phi>, \<phi>[X]\<^sub>\<nu>) (prefix (Suc k) w)) \<sim> false\<^sub>n)"
     using af\<^sub>\<nu>_semantics_ltr af\<^sub>\<nu>_semantics_rtl by blast
 
   also have "\<dots> \<longleftrightarrow> fins (\<lambda>p. snd p = \<up>false\<^sub>n) (DCA.trace (\<CC> \<phi> X) (to_stream w) (Abs \<phi>, Abs (\<phi>[X]\<^sub>\<nu>)))"
     by(simp add: infs_snth \<CC>_def DCA.transition_def af\<^sub>\<nu>_lifted_semantics af_letter\<^sub>\<nu>_lifted_semantics Abs_eq)
 
   also have "\<dots> \<longleftrightarrow> to_stream w \<in> DCA.language (\<CC> \<phi> X)"
     by (simp add: \<CC>_def dca.initial_def dca.rejecting_def DCA.language_def dca_run)
 
   finally show ?thesis
     by blast
 qed
 
 
 lemma \<CC>_nodes:
   "DCA.nodes (\<CC> \<phi> X) \<subseteq> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms \<phi>} \<times> {Abs \<psi> | \<psi>. nested_prop_atoms \<psi> \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> X}"
   unfolding \<CC>_def DCA.nodes_def transition_system_initial.nodes_alt_def transition_system.reachable_alt_def
   apply (auto simp add: af\<^sub>\<nu>_lifted_semantics af_letter\<^sub>\<nu>_lifted_semantics)
   using af\<^sub>\<nu>_fst_nested_prop_atoms apply force
   using GF_advice_nested_prop_atoms\<^sub>\<nu> af\<^sub>\<nu>_snd_nested_prop_atoms dra_construction_axioms by fastforce
 
 
 
 subsection \<open>A DRA for each combination of sets X and Y\<close>
 
 lemma dba_language:
   "(\<And>w. to_stream w \<in> DBA.language \<AA> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>) \<Longrightarrow> DBA.language \<AA> = {w. to_omega w \<Turnstile>\<^sub>n \<phi>}"
   by (metis (mono_tags, lifting) Collect_cong DBA.language_def mem_Collect_eq to_stream_to_omega)
 
 lemma dca_language:
   "(\<And>w. to_stream w \<in> DCA.language \<AA> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>) \<Longrightarrow> DCA.language \<AA> = {w. to_omega w \<Turnstile>\<^sub>n \<phi>}"
   by (metis (mono_tags, lifting) Collect_cong DCA.language_def mem_Collect_eq to_stream_to_omega)
 
 
 definition \<AA>\<^sub>1 :: "'a ltln \<Rightarrow> 'a ltln list \<Rightarrow> ('a set, 'ltlq \<times> 'ltlq) dca" where
   "\<AA>\<^sub>1 \<phi> xs = \<CC> \<phi> (set xs)"
 
 lemma \<AA>\<^sub>1_language:
   "to_omega ` DCA.language (\<AA>\<^sub>1 \<phi> xs) = L\<^sub>1 \<phi> (set xs)"
   by (simp add: \<AA>\<^sub>1_def L\<^sub>1_def set_eq_iff \<CC>_language)
 
 lemma \<AA>\<^sub>1_alphabet:
   "DCA.alphabet (\<AA>\<^sub>1 \<phi> xs) = UNIV"
   unfolding \<AA>\<^sub>1_def \<CC>_def by simp
 
 
 definition \<AA>\<^sub>2 :: "'a ltln list \<Rightarrow> 'a ltln list \<Rightarrow> ('a set, 'ltlq list degen) dba" where
   "\<AA>\<^sub>2 xs ys = dbail (map (\<lambda>\<psi>. \<AA>\<^sub>\<mu>_GF (\<psi>[set ys]\<^sub>\<mu>)) xs)"
 
 lemma \<AA>\<^sub>2_language:
   "to_omega ` DBA.language (\<AA>\<^sub>2 xs ys) = L\<^sub>2 (set xs) (set ys)"
   by (simp add: \<AA>\<^sub>2_def L\<^sub>2_def set_eq_iff dba_language[OF \<AA>\<^sub>\<mu>_GF_language[OF FG_advice_\<mu>LTL(1)]])
 
 lemma \<AA>\<^sub>2_alphabet:
   "DBA.alphabet (\<AA>\<^sub>2 xs ys) = UNIV"
   by (simp add: \<AA>\<^sub>2_def \<AA>\<^sub>\<mu>_GF_def dbail_def dbgail_def)
 
 
 definition \<AA>\<^sub>3 :: "'a ltln list \<Rightarrow> 'a ltln list \<Rightarrow> ('a set, 'ltlq list) dca" where
   "\<AA>\<^sub>3 xs ys = dcail (map (\<lambda>\<psi>. \<AA>\<^sub>\<nu>_FG (\<psi>[set xs]\<^sub>\<nu>)) ys)"
 
 lemma \<AA>\<^sub>3_language:
   "to_omega ` DCA.language (\<AA>\<^sub>3 xs ys) = L\<^sub>3 (set xs) (set ys)"
   by (simp add: \<AA>\<^sub>3_def L\<^sub>3_def set_eq_iff dca_language[OF \<AA>\<^sub>\<nu>_FG_language[OF GF_advice_\<nu>LTL(1)]])
 
 lemma \<AA>\<^sub>3_alphabet:
   "DCA.alphabet (\<AA>\<^sub>3 xs ys) = UNIV"
   by (simp add: \<AA>\<^sub>3_def \<AA>\<^sub>\<nu>_FG_def dcail_def)
 
 
 definition "\<AA>' \<phi> xs ys = dbcrai (\<AA>\<^sub>2 xs ys) (dcai (\<AA>\<^sub>1 \<phi> xs) (\<AA>\<^sub>3 xs ys))"
 
 lemma \<AA>'_language:
   "to_omega ` DRA.language (\<AA>' \<phi> xs ys) = (L\<^sub>1 \<phi> (set xs) \<inter> L\<^sub>2 (set xs) (set ys) \<inter> L\<^sub>3 (set xs) (set ys))"
   by (simp add: \<AA>'_def \<AA>\<^sub>1_language \<AA>\<^sub>2_language \<AA>\<^sub>3_language) fastforce
 
 lemma \<AA>'_alphabet:
   "DRA.alphabet (\<AA>' \<phi> xs ys) = UNIV"
   by (simp add: \<AA>'_def dbcrai_def dcai_def \<AA>\<^sub>1_alphabet \<AA>\<^sub>2_alphabet \<AA>\<^sub>3_alphabet)
 
 
 
 subsection \<open>A DRA for @{term "L(\<phi>)"}\<close>
 
 definition "ltl_to_dra \<phi> = draul (map (\<lambda>(xs, ys). \<AA>' \<phi> xs ys) (advice_sets \<phi>))"
 
 lemma ltl_to_dra_language:
   "to_omega ` DRA.language (ltl_to_dra \<phi>) = language_ltln \<phi>"
 proof -
-  have 1: "INTER (set (map (\<lambda>(x, y). \<AA>' \<phi> x y) (advice_sets \<phi>))) dra.alphabet = UNION (set (map (\<lambda>(x, y). \<AA>' \<phi> x y) (advice_sets \<phi>))) dra.alphabet"
-    by (induction "advice_sets \<phi>") (metis advice_sets_not_empty, simp add: \<AA>'_alphabet split_def advice_sets_not_empty)
-
+  have "(\<Inter>(a, b)\<in>set (advice_sets \<phi>). dra.alphabet (\<AA>' \<phi> a b)) =
+    (\<Union>(a, b)\<in>set (advice_sets \<phi>). dra.alphabet (\<AA>' \<phi> a b))"
+    using advice_sets_not_empty by (simp add: \<AA>'_alphabet)
+  then have *: "DRA.language (draul (map (\<lambda>(x, y). \<AA>' \<phi> x y) (advice_sets \<phi>))) =
+    \<Union> (DRA.language ` set (map (\<lambda>(x, y). \<AA>' \<phi> x y) (advice_sets \<phi>)))"
+    by (simp add: split_def)
   have "language_ltln \<phi> = \<Union> {(L\<^sub>1 \<phi> X \<inter> L\<^sub>2 X Y \<inter> L\<^sub>3 X Y) | X Y. X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi>}"
     unfolding master_theorem_language by auto
   also have "\<dots> = \<Union> {L\<^sub>1 \<phi> (set xs) \<inter> L\<^sub>2 (set xs) (set ys) \<inter> L\<^sub>3 (set xs) (set ys) | xs ys. (xs, ys) \<in> set (advice_sets \<phi>)}"
     unfolding advice_sets_subformulas by (metis (no_types, lifting))
   also have "\<dots> = \<Union> {to_omega ` DRA.language (\<AA>' \<phi> xs ys) | xs ys. (xs, ys) \<in> set (advice_sets \<phi>)}"
     by (simp add: \<AA>'_language)
   finally show ?thesis
-    unfolding ltl_to_dra_def draul_language[OF 1] by auto
+    using * by (auto simp add: ltl_to_dra_def)
 qed
 
 lemma ltl_to_dra_alphabet:
   "alphabet (ltl_to_dra \<phi>) = UNIV"
   by (auto simp: ltl_to_dra_def draul_def \<AA>'_alphabet split: prod.split)
      (insert advice_sets_subformulas, blast)
 
 
 
 subsection \<open>Setting the Alphabet of a DRA\<close>
 
 definition dra_set_alphabet :: "('a set, 'b) dra \<Rightarrow> 'a set set \<Rightarrow> ('a set, 'b) dra"
 where
   "dra_set_alphabet \<AA> \<Sigma> = dra \<Sigma> (initial \<AA>) (transition \<AA>) (accepting \<AA>)"
 
 lemma dra_set_alphabet_language:
   "\<Sigma> \<subseteq> alphabet \<AA> \<Longrightarrow> language (dra_set_alphabet \<AA> \<Sigma>) = language \<AA> \<inter> {s. sset s \<subseteq> \<Sigma>}"
   by (auto simp add: dra_set_alphabet_def language_def set_eq_iff DRA.run_alt_def)
 
 lemma dra_set_alphabet_alphabet[simp]:
   "alphabet (dra_set_alphabet \<AA> \<Sigma>) = \<Sigma>"
   unfolding dra_set_alphabet_def by simp
 
 lemma dra_set_alphabet_nodes:
   "\<Sigma> \<subseteq> alphabet \<AA> \<Longrightarrow> DRA.nodes (dra_set_alphabet \<AA> \<Sigma>) \<subseteq> DRA.nodes \<AA>"
   unfolding dra_set_alphabet_def DRA.nodes_def transition_system_initial.nodes_alt_def transition_system.reachable_alt_def
   by auto (metis DRA.path_alt_def DRA.path_def dra.sel(1) dra.sel(3) subset_trans)
 
 
 
 subsection \<open>A DRA for @{term "L(\<phi>)"} with a finite alphabet\<close>
 
 definition "ltl_to_dra_alphabet \<phi> Ap = dra_set_alphabet (ltl_to_dra \<phi>) (Pow Ap)"
 
 lemma ltl_to_dra_alphabet_language:
   assumes
     "atoms_ltln \<phi> \<subseteq> Ap"
   shows
     "to_omega ` language (ltl_to_dra_alphabet \<phi> Ap) = language_ltln \<phi> \<inter> {w. range w \<subseteq> Pow Ap}"
 proof -
   have 1: "Pow Ap \<subseteq> alphabet (ltl_to_dra \<phi>)"
     unfolding ltl_to_dra_alphabet by simp
 
   show ?thesis
     unfolding ltl_to_dra_alphabet_def dra_set_alphabet_language[OF 1]
     by (simp add: ltl_to_dra_language sset_range) force
 qed
 
 lemma ltl_to_dra_alphabet_alphabet[simp]:
   "alphabet (ltl_to_dra_alphabet \<phi> Ap) = Pow Ap"
   unfolding ltl_to_dra_alphabet_def by simp
 
 lemma ltl_to_dra_alphabet_nodes:
   "DRA.nodes (ltl_to_dra_alphabet \<phi> Ap) \<subseteq> DRA.nodes (ltl_to_dra \<phi>)"
   unfolding ltl_to_dra_alphabet_def
   by (rule dra_set_alphabet_nodes) (simp add: ltl_to_dra_alphabet)
 
 end
 
 end
diff --git a/thys/Polynomials/MPoly_PM.thy b/thys/Polynomials/MPoly_PM.thy
--- a/thys/Polynomials/MPoly_PM.thy
+++ b/thys/Polynomials/MPoly_PM.thy
@@ -1,4394 +1,4394 @@
 (* Author: Alexander Maletzky *)
 
 section \<open>Multivariate Polynomials with Power-Products Represented by Polynomial Mappings\<close>
 
 theory MPoly_PM
   imports Quasi_PM_Power_Products
 begin
 
 text \<open>Many notions introduced in this theory for type @{typ "('x \<Rightarrow>\<^sub>0 'a) \<Rightarrow>\<^sub>0 'b"} closely resemble
   those introduced in @{theory Polynomials.MPoly_Type} for type @{typ "'a mpoly"}.\<close>
 
 lemma monomial_single_power:
   "(monomial c (Poly_Mapping.single x k)) ^ n = monomial (c ^ n) (Poly_Mapping.single x (k * n))"
 proof -
   have eq: "(\<Sum>i = 0..<n. Poly_Mapping.single x k) = Poly_Mapping.single x (k * n)"
     by (induct n, simp_all add: add.commute single_add)
   show ?thesis by (simp add: punit.monomial_power eq)
 qed
 
 lemma monomial_power_map_scale: "(monomial c t) ^ n = monomial (c ^ n) (n \<cdot> t)"
 proof -
   have "(\<Sum>i = 0..<n. t) = (\<Sum>i = 0..<n. 1) \<cdot> t"
     by (simp only: map_scale_sum_distrib_right map_scale_one_left)
   thus ?thesis by (simp add: punit.monomial_power)
 qed
 
 lemma times_canc_left:
   assumes "h * p = h * q" and "h \<noteq> (0::('x::linorder \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::ring_no_zero_divisors)"
   shows "p = q"
 proof (rule ccontr)
   assume "p \<noteq> q"
   hence "p - q \<noteq> 0" by simp
   with assms(2) have "h * (p - q) \<noteq> 0" by simp
   hence "h * p \<noteq> h * q" by (simp add: algebra_simps)
   thus False using assms(1) ..
 qed
 
 lemma times_canc_right:
   assumes "p * h = q * h" and "h \<noteq> (0::('x::linorder \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::ring_no_zero_divisors)"
   shows "p = q"
 proof (rule ccontr)
   assume "p \<noteq> q"
   hence "p - q \<noteq> 0" by simp
   hence "(p - q) * h \<noteq> 0" using assms(2) by simp
   hence "p * h \<noteq> q * h" by (simp add: algebra_simps)
   thus False using assms(1) ..
 qed
 
 subsection \<open>Degree\<close>
 
 lemma plus_minus_assoc_pm_nat_1: "s + t - u = (s - (u - t)) + (t - (u::_ \<Rightarrow>\<^sub>0 nat))"
   by (rule poly_mapping_eqI, simp add: lookup_add lookup_minus)
 
 lemma plus_minus_assoc_pm_nat_2:
   "s + (t - u) = (s + (except (u - t) (- keys s))) + t - (u::_ \<Rightarrow>\<^sub>0 nat)"
 proof (rule poly_mapping_eqI)
   fix x
   show "lookup (s + (t - u)) x = lookup (s + except (u - t) (- keys s) + t - u) x"
   proof (cases "x \<in> keys s")
     case True
     thus ?thesis
       by (simp add: plus_minus_assoc_pm_nat_1 lookup_add lookup_minus lookup_except)
   next
     case False
     hence "lookup s x = 0" by (simp add: in_keys_iff)
     with False show ?thesis
       by (simp add: lookup_add lookup_minus lookup_except)
   qed
 qed
 
 lemma deg_pm_sum: "deg_pm (sum t A) = (\<Sum>a\<in>A. deg_pm (t a))"
   by (induct A rule: infinite_finite_induct) (auto simp: deg_pm_plus)
 
 lemma deg_pm_mono: "s adds t \<Longrightarrow> deg_pm s \<le> deg_pm (t::_ \<Rightarrow>\<^sub>0 _::add_linorder_min)"
   by (metis addsE deg_pm_plus le_iff_add)
 
 lemma adds_deg_pm_antisym: "s adds t \<Longrightarrow> deg_pm t \<le> deg_pm (s::_ \<Rightarrow>\<^sub>0 _::add_linorder_min) \<Longrightarrow> s = t"
   by (metis (no_types, lifting) add.right_neutral add.right_neutral add_left_cancel addsE
       deg_pm_eq_0_iff deg_pm_mono deg_pm_plus dual_order.antisym)
 
 lemma deg_pm_minus:
   assumes "s adds (t::_ \<Rightarrow>\<^sub>0 _::comm_monoid_add)"
   shows "deg_pm (t - s) = deg_pm t - deg_pm s"
 proof -
   from assms have "(t - s) + s = t" by (rule adds_minus)
   hence "deg_pm t = deg_pm ((t - s) + s)" by simp
   also have "\<dots> = deg_pm (t - s) + deg_pm s" by (simp only: deg_pm_plus)
   finally show ?thesis by simp
 qed
 
 lemma adds_group [simp]: "s adds (t::'a \<Rightarrow>\<^sub>0 'b::ab_group_add)"
 proof (rule addsI)
   show "t = s + (t - s)" by simp
 qed
 
 lemmas deg_pm_minus_group = deg_pm_minus[OF adds_group]
 
 lemma deg_pm_minus_le: "deg_pm (t - s) \<le> deg_pm (t::_ \<Rightarrow>\<^sub>0 nat)"
 proof -
   have "keys (t - s) \<subseteq> keys t" by (rule, simp add: lookup_minus in_keys_iff)
   hence "deg_pm (t - s) = (\<Sum>x\<in>keys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
   also have "\<dots> \<le> (\<Sum>x\<in>keys t. lookup t x)" by (rule sum_mono) (simp add: lookup_minus)
   also have "\<dots> = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
   finally show ?thesis .
 qed
 
 lemma minus_id_iff: "t - s = t \<longleftrightarrow> keys t \<inter> keys (s::_ \<Rightarrow>\<^sub>0 nat) = {}"
 proof
   assume "t - s = t"
   {
     fix x
     assume "x \<in> keys t" and "x \<in> keys s"
     hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
     hence "lookup (t - s) x \<noteq> lookup t x" by (simp add: lookup_minus)
     with \<open>t - s = t\<close> have False by simp
   }
   thus "keys t \<inter> keys s = {}" by blast
 next
   assume *: "keys t \<inter> keys s = {}"
   show "t - s = t"
   proof (rule poly_mapping_eqI)
     fix x
     have "lookup t x - lookup s x = lookup t x"
     proof (cases "x \<in> keys t")
       case True
       with * have "x \<notin> keys s" by blast
       thus ?thesis by (simp add: in_keys_iff)
     next
       case False
       thus ?thesis by (simp add: in_keys_iff)
     qed
     thus "lookup (t - s) x = lookup t x" by (simp only: lookup_minus)
   qed
 qed
 
 lemma deg_pm_minus_id_iff: "deg_pm (t - s) = deg_pm t \<longleftrightarrow> keys t \<inter> keys (s::_ \<Rightarrow>\<^sub>0 nat) = {}"
 proof
   assume eq: "deg_pm (t - s) = deg_pm t"
   {
     fix x
     assume "x \<in> keys t" and "x \<in> keys s"
     hence "0 < lookup t x" and "0 < lookup s x" by (simp_all add: in_keys_iff)
     hence *: "lookup (t - s) x < lookup t x" by (simp add: lookup_minus)
     have "keys (t - s) \<subseteq> keys t" by (rule, simp add: lookup_minus in_keys_iff)
     hence "deg_pm (t - s) = (\<Sum>x\<in>keys t. lookup (t - s) x)" using finite_keys by (rule deg_pm_superset)
     also from finite_keys have "\<dots> < (\<Sum>x\<in>keys t. lookup t x)"
     proof (rule sum_strict_mono_ex1)
       show "\<forall>x\<in>keys t. lookup (t - s) x \<le> lookup t x" by (simp add: lookup_minus)
     next
       from \<open>x \<in> keys t\<close> * show "\<exists>x\<in>keys t. lookup (t - s) x < lookup t x" ..
     qed
     also have "\<dots> = deg_pm t" by (rule sym, rule deg_pm_superset, fact subset_refl, fact finite_keys)
     finally have False by (simp add: eq)
   }
   thus "keys t \<inter> keys s = {}" by blast
 next
   assume "keys t \<inter> keys s = {}"
   hence "t - s = t" by (simp only: minus_id_iff)
   thus "deg_pm (t - s) = deg_pm t" by (simp only:)
 qed
 
 definition poly_deg :: "(('x \<Rightarrow>\<^sub>0 'a::add_linorder) \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'a" where
   "poly_deg p = (if keys p = {} then 0 else Max (deg_pm ` keys p))"
 
 definition maxdeg :: "(('x \<Rightarrow>\<^sub>0 'a::add_linorder) \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> 'a" where
   "maxdeg A = Max (poly_deg ` A)"
   
 definition mindeg :: "(('x \<Rightarrow>\<^sub>0 'a::add_linorder) \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> 'a" where
   "mindeg A = Min (poly_deg ` A)"
 
 lemma poly_deg_monomial: "poly_deg (monomial c t) = (if c = 0 then 0 else deg_pm t)"
   by (simp add: poly_deg_def)
 
 lemma poly_deg_monomial_zero [simp]: "poly_deg (monomial c 0) = 0"
   by (simp add: poly_deg_monomial)
 
 lemma poly_deg_zero [simp]: "poly_deg 0 = 0"
   by (simp only: single_zero[of 0, symmetric] poly_deg_monomial_zero)
 
 lemma poly_deg_one [simp]: "poly_deg 1 = 0"
   by (simp only: single_one[symmetric] poly_deg_monomial_zero)
 
 lemma poly_degE:
   assumes "p \<noteq> 0"
   obtains t where "t \<in> keys p" and "poly_deg p = deg_pm t"
 proof -
   from assms have "poly_deg p = Max (deg_pm ` keys p)" by (simp add: poly_deg_def)
   also have "\<dots> \<in> deg_pm ` keys p"
   proof (rule Max_in)
     from assms show "deg_pm ` keys p \<noteq> {}" by simp
   qed simp
   finally obtain t where "t \<in> keys p" and "poly_deg p = deg_pm t" ..
   thus ?thesis ..
 qed
 
 lemma poly_deg_max_keys: "t \<in> keys p \<Longrightarrow> deg_pm t \<le> poly_deg p"
   using finite_keys by (auto simp: poly_deg_def)
 
 lemma poly_deg_leI: "(\<And>t. t \<in> keys p \<Longrightarrow> deg_pm t \<le> (d::'a::add_linorder_min)) \<Longrightarrow> poly_deg p \<le> d"
   using finite_keys by (auto simp: poly_deg_def)
 
 lemma poly_deg_lessI:
   "p \<noteq> 0 \<Longrightarrow> (\<And>t. t \<in> keys p \<Longrightarrow> deg_pm t < (d::'a::add_linorder_min)) \<Longrightarrow> poly_deg p < d"
   using finite_keys by (auto simp: poly_deg_def)
 
 lemma poly_deg_zero_imp_monomial:
   assumes "poly_deg p = (0::'a::add_linorder_min)"
   shows "monomial (lookup p 0) 0 = p"
 proof (rule keys_subset_singleton_imp_monomial, rule)
   fix t
   assume "t \<in> keys p"
   have "t = 0"
   proof (rule ccontr)
     assume "t \<noteq> 0"
     hence "deg_pm t \<noteq> 0" by simp
     hence "0 < deg_pm t" using not_gr_zero by blast
     also from \<open>t \<in> keys p\<close> have "... \<le> poly_deg p" by (rule poly_deg_max_keys)
     finally have "poly_deg p \<noteq> 0" by simp
     from this assms show False ..
   qed
   thus "t \<in> {0}" by simp
 qed
 
 lemma poly_deg_plus_le:
   "poly_deg (p + q) \<le> max (poly_deg p) (poly_deg (q::(_ \<Rightarrow>\<^sub>0 'a::add_linorder_min) \<Rightarrow>\<^sub>0 _))"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (p + q)"
   also have "... \<subseteq> keys p \<union> keys q" by (fact Poly_Mapping.keys_add)
   finally show "deg_pm t \<le> max (poly_deg p) (poly_deg q)"
   proof
     assume "t \<in> keys p"
     hence "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
     thus ?thesis by (simp add: le_max_iff_disj)
   next
     assume "t \<in> keys q"
     hence "deg_pm t \<le> poly_deg q" by (rule poly_deg_max_keys)
     thus ?thesis by (simp add: le_max_iff_disj)
   qed
 qed
 
 lemma poly_deg_uminus [simp]: "poly_deg (-p) = poly_deg p"
   by (simp add: poly_deg_def keys_uminus)
 
 lemma poly_deg_minus_le:
   "poly_deg (p - q) \<le> max (poly_deg p) (poly_deg (q::(_ \<Rightarrow>\<^sub>0 'a::add_linorder_min) \<Rightarrow>\<^sub>0 _))"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (p - q)"
   also have "... \<subseteq> keys p \<union> keys q" by (fact keys_minus)
   finally show "deg_pm t \<le> max (poly_deg p) (poly_deg q)"
   proof
     assume "t \<in> keys p"
     hence "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
     thus ?thesis by (simp add: le_max_iff_disj)
   next
     assume "t \<in> keys q"
     hence "deg_pm t \<le> poly_deg q" by (rule poly_deg_max_keys)
     thus ?thesis by (simp add: le_max_iff_disj)
   qed
 qed
 
 lemma poly_deg_times_le:
   "poly_deg (p * q) \<le> poly_deg p + poly_deg (q::(_ \<Rightarrow>\<^sub>0 'a::add_linorder_min) \<Rightarrow>\<^sub>0 _)"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (p * q)"
   then obtain u v where "u \<in> keys p" and "v \<in> keys q" and "t = u + v" by (rule in_keys_timesE)
   from \<open>u \<in> keys p\<close> have "deg_pm u \<le> poly_deg p" by (rule poly_deg_max_keys)
   moreover from \<open>v \<in> keys q\<close> have "deg_pm v \<le> poly_deg q" by (rule poly_deg_max_keys)
   ultimately show "deg_pm t \<le> poly_deg p + poly_deg q" by (simp add: \<open>t = u + v\<close> deg_pm_plus add_mono)
 qed
 
 lemma poly_deg_times:
   assumes "p \<noteq> 0" and "q \<noteq> (0::('x::linorder \<Rightarrow>\<^sub>0 'a::add_linorder_min) \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "poly_deg (p * q) = poly_deg p + poly_deg q"
   using poly_deg_times_le
 proof (rule antisym)
   let ?A = "\<lambda>f. {u. deg_pm u < poly_deg f}"
   define p1 where "p1 = except p (?A p)"
   define p2 where "p2 = except p (- ?A p)"
   define q1 where "q1 = except q (?A q)"
   define q2 where "q2 = except q (- ?A q)"
   have deg_p1: "deg_pm t = poly_deg p" if "t \<in> keys p1" for t
   proof -
     from that have "t \<in> keys p" and "poly_deg p \<le> deg_pm t"
       by (simp_all add: p1_def keys_except not_less)
     from this(1) have "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
     thus ?thesis using \<open>poly_deg p \<le> deg_pm t\<close> by (rule antisym)
   qed
   have deg_p2: "t \<in> keys p2 \<Longrightarrow> deg_pm t < poly_deg p" for t by (simp add: p2_def keys_except)
   have deg_q1: "deg_pm t = poly_deg q" if "t \<in> keys q1" for t
   proof -
     from that have "t \<in> keys q" and "poly_deg q \<le> deg_pm t"
       by (simp_all add: q1_def keys_except not_less)
     from this(1) have "deg_pm t \<le> poly_deg q" by (rule poly_deg_max_keys)
     thus ?thesis using \<open>poly_deg q \<le> deg_pm t\<close> by (rule antisym)
   qed
   have deg_q2: "t \<in> keys q2 \<Longrightarrow> deg_pm t < poly_deg q" for t by (simp add: q2_def keys_except)
   have p: "p = p1 + p2" unfolding p1_def p2_def by (fact except_decomp)
   have "p1 \<noteq> 0"
   proof -
     from assms(1) obtain t where "t \<in> keys p" and "poly_deg p = deg_pm t" by (rule poly_degE)
     hence "t \<in> keys p1" by (simp add: p1_def keys_except)
     thus ?thesis by auto
   qed
   have q: "q = q1 + q2" unfolding q1_def q2_def by (fact except_decomp)
   have "q1 \<noteq> 0"
   proof -
     from assms(2) obtain t where "t \<in> keys q" and "poly_deg q = deg_pm t" by (rule poly_degE)
     hence "t \<in> keys q1" by (simp add: q1_def keys_except)
     thus ?thesis by auto
   qed
   with \<open>p1 \<noteq> 0\<close> have "p1 * q1 \<noteq> 0" by simp
   hence "keys (p1 * q1) \<noteq> {}" by simp
   then obtain u where "u \<in> keys (p1 * q1)" by blast
   then obtain s t where "s \<in> keys p1" and "t \<in> keys q1" and u: "u = s + t" by (rule in_keys_timesE)
   from \<open>s \<in> keys p1\<close> have "deg_pm s = poly_deg p" by (rule deg_p1)
   moreover from \<open>t \<in> keys q1\<close> have "deg_pm t = poly_deg q" by (rule deg_q1)
   ultimately have eq: "poly_deg p + poly_deg q = deg_pm u" by (simp only: u deg_pm_plus)
   also have "\<dots> \<le> poly_deg (p * q)"
   proof (rule poly_deg_max_keys)
     have "u \<notin> keys (p1 * q2 + p2 * q)"
     proof
       assume "u \<in> keys (p1 * q2 + p2 * q)"
       also have "\<dots> \<subseteq> keys (p1 * q2) \<union> keys (p2 * q)" by (rule Poly_Mapping.keys_add)
       finally have "deg_pm u < poly_deg p + poly_deg q"
       proof
         assume "u \<in> keys (p1 * q2)"
         then obtain s' t' where "s' \<in> keys p1" and "t' \<in> keys q2" and u: "u = s' + t'"
           by (rule in_keys_timesE)
         from \<open>s' \<in> keys p1\<close> have "deg_pm s' = poly_deg p" by (rule deg_p1)
         moreover from \<open>t' \<in> keys q2\<close> have "deg_pm t' < poly_deg q" by (rule deg_q2)
         ultimately show ?thesis by (simp add: u deg_pm_plus)
       next
         assume "u \<in> keys (p2 * q)"
         then obtain s' t' where "s' \<in> keys p2" and "t' \<in> keys q" and u: "u = s' + t'"
           by (rule in_keys_timesE)
         from \<open>s' \<in> keys p2\<close> have "deg_pm s' < poly_deg p" by (rule deg_p2)
         moreover from \<open>t' \<in> keys q\<close> have "deg_pm t' \<le> poly_deg q" by (rule poly_deg_max_keys)
         ultimately show ?thesis by (simp add: u deg_pm_plus add_less_le_mono)
       qed
       thus False by (simp only: eq)
     qed
     with \<open>u \<in> keys (p1 * q1)\<close> have "u \<in> keys (p1 * q1 + (p1 * q2 + p2 * q))" by (rule in_keys_plusI1)
     thus "u \<in> keys (p * q)" by (simp only: p q algebra_simps)
   qed
   finally show "poly_deg p + poly_deg q \<le> poly_deg (p * q)" .
 qed
 
 corollary poly_deg_monom_mult_le:
   "poly_deg (punit.monom_mult c (t::_ \<Rightarrow>\<^sub>0 'a::add_linorder_min) p) \<le> deg_pm t + poly_deg p"
 proof -
   have "poly_deg (punit.monom_mult c t p) \<le> poly_deg (monomial c t) + poly_deg p"
     by (simp only: times_monomial_left[symmetric] poly_deg_times_le)
   also have "... \<le> deg_pm t + poly_deg p" by (simp add: poly_deg_monomial)
   finally show ?thesis .
 qed
 
 lemma poly_deg_monom_mult:
   assumes "c \<noteq> 0" and "p \<noteq> (0::(_ \<Rightarrow>\<^sub>0 'a::add_linorder_min) \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "poly_deg (punit.monom_mult c t p) = deg_pm t + poly_deg p"
 proof (rule order.antisym, fact poly_deg_monom_mult_le)
   from assms(2) obtain s where "s \<in> keys p" and "poly_deg p = deg_pm s" by (rule poly_degE)
   have "deg_pm t + poly_deg p = deg_pm (t + s)" by (simp add: \<open>poly_deg p = deg_pm s\<close> deg_pm_plus)
   also have "... \<le> poly_deg (punit.monom_mult c t p)"
   proof (rule poly_deg_max_keys)
     from \<open>s \<in> keys p\<close> show "t + s \<in> keys (punit.monom_mult c t p)"
       unfolding punit.keys_monom_mult[OF assms(1)] by fastforce
   qed
   finally show "deg_pm t + poly_deg p \<le> poly_deg (punit.monom_mult c t p)" .
 qed
 
 lemma poly_deg_map_scale:
   "poly_deg (c \<cdot> p) = (if c = (0::_::semiring_no_zero_divisors) then 0 else poly_deg p)"
   by (simp add: poly_deg_def keys_map_scale)
 
 lemma poly_deg_sum_le: "((poly_deg (sum f A))::'a::add_linorder_min) \<le> Max (poly_deg ` f ` A)"
 proof (cases "finite A")
   case True
   thus ?thesis
   proof (induct A)
     case empty
     show ?case by simp
   next
     case (insert a A)
     show ?case
     proof (cases "A = {}")
       case True
       thus ?thesis by simp
     next
       case False
       have "poly_deg (sum f (insert a A)) \<le> max (poly_deg (f a)) (poly_deg (sum f A))"
         by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] poly_deg_plus_le)
       also have "... \<le> max (poly_deg (f a)) (Max (poly_deg ` f ` A))"
         using insert(3) max.mono by blast
       also have "... = (Max (poly_deg ` f ` (insert a A)))" using False by (simp add: insert(1))
       finally show ?thesis .
     qed
   qed
 next
   case False
   thus ?thesis by simp
 qed
 
 lemma poly_deg_prod_le: "((poly_deg (prod f A))::'a::add_linorder_min) \<le> (\<Sum>a\<in>A. poly_deg (f a))"
 proof (cases "finite A")
   case True
   thus ?thesis
   proof (induct A)
     case empty
     show ?case by simp
   next
     case (insert a A)
     have "poly_deg (prod f (insert a A)) \<le> (poly_deg (f a)) + (poly_deg (prod f A))"
       by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] poly_deg_times_le)
     also have "... \<le> (poly_deg (f a)) + (\<Sum>a\<in>A. poly_deg (f a))"
       using insert(3) add_le_cancel_left by blast
     also have "... = (\<Sum>a\<in>insert a A. poly_deg (f a))" by (simp add: insert(1) insert(2))
     finally show ?case .
   qed
 next
   case False
   thus ?thesis by simp
 qed
 
 lemma maxdeg_max:
   assumes "finite A" and "p \<in> A"
   shows "poly_deg p \<le> maxdeg A"
   unfolding maxdeg_def using assms by auto
 
 lemma mindeg_min:
   assumes "finite A" and "p \<in> A"
   shows "mindeg A \<le> poly_deg p"
   unfolding mindeg_def using assms by auto
 
 subsection \<open>Indeterminates\<close>
 
 definition indets :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'x set"
-  where "indets p = UNION (keys p) keys"
+  where "indets p = \<Union> (keys ` keys p)"
 
 definition PPs :: "'x set \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) set"  (".[(_)]")
   where "PPs X = {t. keys t \<subseteq> X}"
 
 definition Polys :: "'x set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero) set"  ("P[(_)]")
   where "Polys X = {p. keys p \<subseteq> .[X]}"
 
 subsubsection \<open>@{const indets}\<close>
 
 lemma in_indetsI:
   assumes "x \<in> keys t" and "t \<in> keys p"
   shows "x \<in> indets p"
   using assms by (auto simp add: indets_def)
 
 lemma in_indetsE:
   assumes "x \<in> indets p"
   obtains t where "t \<in> keys p" and "x \<in> keys t"
   using assms by (auto simp add: indets_def)
 
 lemma keys_subset_indets: "t \<in> keys p \<Longrightarrow> keys t \<subseteq> indets p"
   by (auto dest: in_indetsI)
 
 lemma indets_empty_imp_monomial:
   assumes "indets p = {}"
   shows "monomial (lookup p 0) 0 = p"
 proof (rule keys_subset_singleton_imp_monomial, rule)
   fix t
   assume "t \<in> keys p"
   have "t = 0"
   proof (rule ccontr)
     assume "t \<noteq> 0"
     hence "keys t \<noteq> {}" by simp
     then obtain x where "x \<in> keys t" by blast
     from this \<open>t \<in> keys p\<close> have "x \<in> indets p" by (rule in_indetsI)
     with assms show False by simp
   qed
   thus "t \<in> {0}" by simp
 qed
 
 lemma finite_indets: "finite (indets p)"
   by (simp only: indets_def, rule finite_UN_I, (rule finite_keys)+)
 
 lemma indets_zero [simp]: "indets 0 = {}"
   by (simp add: indets_def)
 
 lemma indets_one [simp]: "indets 1 = {}"
   by (simp add: indets_def)
 
 lemma indets_monomial_single_subset: "indets (monomial c (Poly_Mapping.single v k)) \<subseteq> {v}"
 proof
   fix x assume "x \<in> indets (monomial c (Poly_Mapping.single v k))"
   then have "x = v" unfolding indets_def
     by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
   thus "x \<in> {v}" by simp
 qed
 
 lemma indets_monomial_single:
   assumes "c \<noteq> 0" and "k \<noteq> 0"
   shows "indets (monomial c (Poly_Mapping.single v k)) = {v}"
 proof (rule, fact indets_monomial_single_subset, simp)
   from assms show "v \<in> indets (monomial c (monomial k v))" by (simp add: indets_def)
 qed
 
 lemma indets_monomial:
   assumes "c \<noteq> 0"
   shows "indets (monomial c t) = keys t"
 proof (rule antisym; rule subsetI)
   fix x
   assume "x \<in> indets (monomial c t)"
   then have "lookup t x \<noteq> 0" unfolding indets_def
     by (metis UN_E lookup_eq_zero_in_keys_contradict lookup_single_not_eq)
   thus "x \<in> keys t" by (meson lookup_not_eq_zero_eq_in_keys)
 next
   fix x
   assume "x \<in> keys t"
   then have "lookup t x \<noteq> 0" by (meson lookup_not_eq_zero_eq_in_keys)
   thus "x \<in> indets (monomial c t)" unfolding indets_def using assms
     by (metis UN_iff lookup_not_eq_zero_eq_in_keys lookup_single_eq)
 qed
 
 lemma indets_monomial_subset: "indets (monomial c t) \<subseteq> keys t"
   by (cases "c = 0", simp_all add: indets_def)
 
 lemma indets_monomial_zero [simp]: "indets (monomial c 0) = {}"
   by (simp add: indets_def)
 
 lemma indets_plus_subset: "indets (p + q) \<subseteq> indets p \<union> indets q"
 proof
   fix x
   assume "x \<in> indets (p + q)"
   then obtain t where "x \<in> keys t" and "t \<in> keys (p + q)" by (metis UN_E indets_def)
   hence "t \<in> keys p \<union> keys q" by (metis Poly_Mapping.keys_add subsetCE)
   thus "x \<in> indets p \<union> indets q" using indets_def \<open>x \<in> keys t\<close> by fastforce
 qed
 
 lemma indets_uminus [simp]: "indets (-p) = indets p"
   by (simp add: indets_def keys_uminus)
 
 lemma indets_minus_subset: "indets (p - q) \<subseteq> indets p \<union> indets q"
 proof
   fix x
   assume "x \<in> indets (p - q)"
   then obtain t where "x \<in> keys t" and "t \<in> keys (p - q)" by (metis UN_E indets_def)
   hence "t \<in> keys p \<union> keys q" by (metis keys_minus subsetCE)
   thus "x \<in> indets p \<union> indets q" using indets_def \<open>x \<in> keys t\<close> by fastforce
 qed
 
 lemma indets_times_subset: "indets (p * q) \<subseteq> indets p \<union> indets (q::(_ \<Rightarrow>\<^sub>0 _::cancel_comm_monoid_add) \<Rightarrow>\<^sub>0 _)"
 proof
   fix x
   assume "x \<in> indets (p * q)"
   then obtain t where "t \<in> keys (p * q)" and "x \<in> keys t" unfolding indets_def by blast
   from this(1) obtain u v where "u \<in> keys p" "v \<in> keys q" and "t = u + v" by (rule in_keys_timesE)
   hence "x \<in> keys u \<union> keys v" by (metis \<open>x \<in> keys t\<close> Poly_Mapping.keys_add subsetCE)
   thus "x \<in> indets p \<union> indets q" unfolding indets_def using \<open>u \<in> keys p\<close> \<open>v \<in> keys q\<close> by blast
 qed
 
 corollary indets_monom_mult_subset: "indets (punit.monom_mult c t p) \<subseteq> keys t \<union> indets p"
 proof -
   have "indets (punit.monom_mult c t p) \<subseteq> indets (monomial c t) \<union> indets p"
     by (simp only: times_monomial_left[symmetric] indets_times_subset)
   also have "... \<subseteq> keys t \<union> indets p" using indets_monomial_subset[of t c] by blast
   finally show ?thesis .
 qed
 
 lemma indets_monom_mult:
   assumes "c \<noteq> 0" and "p \<noteq> (0::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::semiring_no_zero_divisors)"
   shows "indets (punit.monom_mult c t p) = keys t \<union> indets p"
 proof (rule, fact indets_monom_mult_subset, rule)
   fix x
   assume "x \<in> keys t \<union> indets p"
   thus "x \<in> indets (punit.monom_mult c t p)"
   proof
     assume "x \<in> keys t"
     from assms(2) have "keys p \<noteq> {}" by simp
     then obtain s where "s \<in> keys p" by blast
     hence "t + s \<in> (+) t ` keys p" by fastforce
     also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
     finally have "t + s \<in> keys (punit.monom_mult c t p)" .
     show ?thesis
     proof (rule in_indetsI)
       from \<open>x \<in> keys t\<close> show "x \<in> keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
     qed fact
   next
     assume "x \<in> indets p"
     then obtain s where "s \<in> keys p" and "x \<in> keys s" by (rule in_indetsE)
     from this(1) have "t + s \<in> (+) t ` keys p" by fastforce
     also from assms(1) have "... = keys (punit.monom_mult c t p)" by (simp add: punit.keys_monom_mult)
     finally have "t + s \<in> keys (punit.monom_mult c t p)" .
     show ?thesis
     proof (rule in_indetsI)
       from \<open>x \<in> keys s\<close> show "x \<in> keys (t + s)" by (simp add: keys_plus_ninv_comm_monoid_add)
     qed fact
   qed
 qed
 
 lemma indets_sum_subset: "indets (sum f A) \<subseteq> (\<Union>a\<in>A. indets (f a))"
 proof (cases "finite A")
   case True
   thus ?thesis
   proof (induct A)
     case empty
     show ?case by simp
   next
     case (insert a A)
     have "indets (sum f (insert a A)) \<subseteq> indets (f a) \<union> indets (sum f A)"
       by (simp only: comm_monoid_add_class.sum.insert[OF insert(1) insert(2)] indets_plus_subset)
     also have "... \<subseteq> indets (f a) \<union> (\<Union>a\<in>A. indets (f a))" using insert(3) by blast
     also have "... = (\<Union>a\<in>insert a A. indets (f a))" by simp
     finally show ?case .
   qed
 next
   case False
   thus ?thesis by simp
 qed
 
 lemma indets_prod_subset:
   "indets (prod (f::_ \<Rightarrow> ((_ \<Rightarrow>\<^sub>0 _::cancel_comm_monoid_add) \<Rightarrow>\<^sub>0 _)) A) \<subseteq> (\<Union>a\<in>A. indets (f a))"
 proof (cases "finite A")
   case True
   thus ?thesis
   proof (induct A)
     case empty
     show ?case by simp
   next
     case (insert a A)
     have "indets (prod f (insert a A)) \<subseteq> indets (f a) \<union> indets (prod f A)"
       by (simp only: comm_monoid_mult_class.prod.insert[OF insert(1) insert(2)] indets_times_subset)
     also have "... \<subseteq> indets (f a) \<union> (\<Union>a\<in>A. indets (f a))" using insert(3) by blast
     also have "... = (\<Union>a\<in>insert a A. indets (f a))" by simp
     finally show ?case .
   qed
 next
   case False
   thus ?thesis by simp
 qed
 
 lemma indets_power_subset: "indets (p ^ n) \<subseteq> indets (p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::comm_semiring_1)"
 proof -
   have "p ^ n = (\<Prod>i=0..<n. p)" by simp
   also have "indets ... \<subseteq> (\<Union>i\<in>{0..<n}. indets p)" by (fact indets_prod_subset)
   also have "... \<subseteq> indets p" by simp
   finally show ?thesis .
 qed
 
 lemma indets_empty_iff_poly_deg_zero: "indets p = {} \<longleftrightarrow> poly_deg p = 0"
 proof
   assume "indets p = {}"
   hence "monomial (lookup p 0) 0 = p" by (rule indets_empty_imp_monomial)
   moreover have "poly_deg (monomial (lookup p 0) 0) = 0" by simp
   ultimately show "poly_deg p = 0" by metis
 next
   assume "poly_deg p = 0"
   hence "monomial (lookup p 0) 0 = p" by (rule poly_deg_zero_imp_monomial)
   moreover have "indets (monomial (lookup p 0) 0) = {}" by simp
   ultimately show "indets p = {}" by metis
 qed
 
 subsubsection \<open>@{const PPs}\<close>
 
 lemma PPsI: "keys t \<subseteq> X \<Longrightarrow> t \<in> .[X]"
   by (simp add: PPs_def)
 
 lemma PPsD: "t \<in> .[X] \<Longrightarrow> keys t \<subseteq> X"
   by (simp add: PPs_def)
 
 lemma PPs_empty [simp]: ".[{}] = {0}"
   by (simp add: PPs_def)
 
 lemma PPs_UNIV [simp]: ".[UNIV] = UNIV"
   by (simp add: PPs_def)
 
 lemma PPs_singleton: ".[{x}] = range (Poly_Mapping.single x)"
 proof (rule set_eqI)
   fix t
   show "t \<in> .[{x}] \<longleftrightarrow> t \<in> range (Poly_Mapping.single x)"
   proof
     assume "t \<in> .[{x}]"
     hence "keys t \<subseteq> {x}" by (rule PPsD)
     hence "Poly_Mapping.single x (lookup t x) = t" by (rule keys_subset_singleton_imp_monomial)
     from this[symmetric] UNIV_I show "t \<in> range (Poly_Mapping.single x)" ..
   next
     assume "t \<in> range (Poly_Mapping.single x)"
     then obtain e where "t = Poly_Mapping.single x e" ..
     thus "t \<in> .[{x}]" by (simp add: PPs_def)
   qed
 qed
 
 lemma zero_in_PPs: "0 \<in> .[X]"
   by (simp add: PPs_def)
 
 lemma PPs_mono: "X \<subseteq> Y \<Longrightarrow> .[X] \<subseteq> .[Y]"
   by (auto simp: PPs_def)
 
 lemma PPs_closed_single:
   assumes "x \<in> X"
   shows "Poly_Mapping.single x e \<in> .[X]"
 proof (rule PPsI)
   have "keys (Poly_Mapping.single x e) \<subseteq> {x}" by simp
   also from assms have "... \<subseteq> X" by simp
   finally show "keys (Poly_Mapping.single x e) \<subseteq> X" .
 qed
 
 lemma PPs_closed_plus:
   assumes "s \<in> .[X]" and "t \<in> .[X]"
   shows "s + t \<in> .[X]"
 proof -
   have "keys (s + t) \<subseteq> keys s \<union> keys t" by (fact Poly_Mapping.keys_add)
   also from assms have "... \<subseteq> X" by (simp add: PPs_def)
   finally show ?thesis by (rule PPsI)
 qed
 
 lemma PPs_closed_minus:
   assumes "s \<in> .[X]"
   shows "s - t \<in> .[X]"
 proof -
   have "keys (s - t) \<subseteq> keys s" by (metis lookup_minus lookup_not_eq_zero_eq_in_keys subsetI zero_diff)
   also from assms have "... \<subseteq> X" by (rule PPsD)
   finally show ?thesis by (rule PPsI)
 qed
 
 lemma PPs_closed_adds:
   assumes "s \<in> .[X]" and "t adds s"
   shows "t \<in> .[X]"
 proof -
   from assms(2) have "s - (s - t) = t" by (metis add_minus_2 adds_minus)
   moreover from assms(1) have "s - (s - t) \<in> .[X]" by (rule PPs_closed_minus)
   ultimately show ?thesis by simp
 qed
 
 lemma PPs_closed_gcs:
   assumes "s \<in> .[X]"
   shows "gcs s t \<in> .[X]"
   using assms gcs_adds by (rule PPs_closed_adds)
 
 lemma PPs_closed_lcs:
   assumes "s \<in> .[X]" and "t \<in> .[X]"
   shows "lcs s t \<in> .[X]"
 proof -
   from assms have "s + t \<in> .[X]" by (rule PPs_closed_plus)
   hence "(s + t) - gcs s t \<in> .[X]" by (rule PPs_closed_minus)
   thus ?thesis by (simp add: gcs_plus_lcs[of s t, symmetric])
 qed
 
 lemma PPs_closed_except': "t \<in> .[X] \<Longrightarrow> except t Y \<in> .[X - Y]"
   by (auto simp: keys_except PPs_def)
 
 lemma PPs_closed_except: "t \<in> .[X] \<Longrightarrow> except t Y \<in> .[X]"
   by (auto simp: keys_except PPs_def)
 
 lemma PPs_UnI:
   assumes "tx \<in> .[X]" and "ty \<in> .[Y]" and "t = tx + ty"
   shows "t \<in> .[X \<union> Y]"
 proof -
   from assms(1) have "tx \<in> .[X \<union> Y]" by rule (simp add: PPs_mono)
   moreover from assms(2) have "ty \<in> .[X \<union> Y]" by rule (simp add: PPs_mono)
   ultimately show ?thesis unfolding assms(3) by (rule PPs_closed_plus)
 qed
 
 lemma PPs_UnE:
   assumes "t \<in> .[X \<union> Y]"
   obtains tx ty where "tx \<in> .[X]" and "ty \<in> .[Y]" and "t = tx + ty"
 proof -
   from assms have "keys t \<subseteq> X \<union> Y" by (rule PPsD)
   define tx where "tx = except t (- X)"
   have "keys tx \<subseteq> X" by (simp add: tx_def keys_except)
   hence "tx \<in> .[X]" by (simp add: PPs_def)
   have "tx adds t" by (simp add: tx_def adds_poly_mappingI le_fun_def lookup_except)
   from adds_minus[OF this] have "t = tx + (t - tx)" by (simp only: ac_simps)
   have "t - tx \<in> .[Y]"
   proof (rule PPsI, rule)
     fix x
     assume "x \<in> keys (t - tx)"
     also have "... \<subseteq> keys t \<union> keys tx" by (rule keys_minus)
     also from \<open>keys t \<subseteq> X \<union> Y\<close> \<open>keys tx \<subseteq> X\<close> have "... \<subseteq> X \<union> Y" by blast
     finally show "x \<in> Y"
     proof
       assume "x \<in> X"
       hence "x \<notin> keys (t - tx)" by (simp add: tx_def lookup_except lookup_minus in_keys_iff)
       thus ?thesis using \<open>x \<in> keys (t - tx)\<close> ..
     qed
   qed
   with \<open>tx \<in> .[X]\<close> show ?thesis using \<open>t = tx + (t - tx)\<close> ..
 qed
 
 lemma PPs_Un: ".[X \<union> Y] = (\<Union>t\<in>.[X]. (+) t ` .[Y])"  (is "?A = ?B")
 proof (rule set_eqI)
   fix t
   show "t \<in> ?A \<longleftrightarrow> t \<in> ?B"
   proof
     assume "t \<in> ?A"
     then obtain tx ty where "tx \<in> .[X]" and "ty \<in> .[Y]" and "t = tx + ty" by (rule PPs_UnE)
     from this(2) have "t \<in> (+) tx ` .[Y]" unfolding \<open>t = tx + ty\<close> by (rule imageI)
     with \<open>tx \<in> .[X]\<close> show "t \<in> ?B" ..
   next
     assume "t \<in> ?B"
     then obtain tx where "tx \<in> .[X]" and "t \<in> (+) tx ` .[Y]" ..
     from this(2) obtain ty where "ty \<in> .[Y]" and "t = tx + ty" ..
     with \<open>tx \<in> .[X]\<close> show "t \<in> ?A" by (rule PPs_UnI)
   qed
 qed
 
 corollary PPs_insert: ".[insert x X] = (\<Union>e. (+) (Poly_Mapping.single x e) ` .[X])"
 proof -
   have ".[insert x X] = .[{x} \<union> X]" by simp
   also have "... = (\<Union>t\<in>.[{x}]. (+) t ` .[X])" by (fact PPs_Un)
   also have "... = (\<Union>e. (+) (Poly_Mapping.single x e) ` .[X])" by (simp add: PPs_singleton)
   finally show ?thesis .
 qed
 
 corollary PPs_insertI:
   assumes "tx \<in> .[X]" and "t = Poly_Mapping.single x e + tx"
   shows "t \<in> .[insert x X]"
 proof -
   from assms(1) have "t \<in> (+) (Poly_Mapping.single x e) ` .[X]" unfolding assms(2) by (rule imageI)
   with UNIV_I show ?thesis unfolding PPs_insert by (rule UN_I)
 qed
 
 corollary PPs_insertE:
   assumes "t \<in> .[insert x X]"
   obtains e tx where "tx \<in> .[X]" and "t = Poly_Mapping.single x e + tx"
 proof -
   from assms obtain e where "t \<in> (+) (Poly_Mapping.single x e) ` .[X]" unfolding PPs_insert ..
   then obtain tx where "tx \<in> .[X]" and "t = Poly_Mapping.single x e + tx" ..
   thus ?thesis ..
 qed
 
 lemma PPs_Int: ".[X \<inter> Y] = .[X] \<inter> .[Y]"
   by (auto simp: PPs_def)
 
 lemma PPs_INT: ".[\<Inter> X] = \<Inter> (PPs ` X)"
   by (auto simp: PPs_def)
 
 subsubsection \<open>@{const Polys}\<close>
 
 lemma Polys_alt: "P[X] = {p. indets p \<subseteq> X}"
   by (auto simp: Polys_def PPs_def indets_def)
 
 lemma PolysI: "keys p \<subseteq> .[X] \<Longrightarrow> p \<in> P[X]"
   by (simp add: Polys_def)
 
 lemma PolysI_alt: "indets p \<subseteq> X \<Longrightarrow> p \<in> P[X]"
   by (simp add: Polys_alt)
 
 lemma PolysD:
   assumes "p \<in> P[X]"
   shows "keys p \<subseteq> .[X]" and "indets p \<subseteq> X"
   using assms by (simp add: Polys_def, simp add: Polys_alt)
 
 lemma Polys_empty: "P[{}] = ((range (Poly_Mapping.single 0))::(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero) set)"
 proof (rule set_eqI)
   fix p :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero"
   show "p \<in> P[{}] \<longleftrightarrow> p \<in> range (Poly_Mapping.single 0)"
   proof
     assume "p \<in> P[{}]"
     hence "keys p \<subseteq> .[{}]" by (rule PolysD)
     also have "... = {0}" by simp
     finally have "keys p \<subseteq> {0}" .
     hence "Poly_Mapping.single 0 (lookup p 0) = p" by (rule keys_subset_singleton_imp_monomial)
     from this[symmetric] UNIV_I show "p \<in> range (Poly_Mapping.single 0)" ..
   next
     assume "p \<in> range (Poly_Mapping.single 0)"
     then obtain c where "p = monomial c 0" ..
     thus "p \<in> P[{}]" by (simp add: Polys_def)
   qed
 qed
 
 lemma Polys_UNIV [simp]: "P[UNIV] = UNIV"
   by (simp add: Polys_def)
 
 lemma zero_in_Polys: "0 \<in> P[X]"
   by (simp add: Polys_def)
 
 lemma one_in_Polys: "1 \<in> P[X]"
   by (simp add: Polys_def zero_in_PPs)
 
 lemma Polys_mono: "X \<subseteq> Y \<Longrightarrow> P[X] \<subseteq> P[Y]"
   by (auto simp: Polys_alt)
 
 lemma Polys_closed_monomial: "t \<in> .[X] \<Longrightarrow> monomial c t \<in> P[X]"
   using indets_monomial_subset[where c=c and t=t] by (auto simp: Polys_alt PPs_def)
 
 lemma Polys_closed_plus: "p \<in> P[X] \<Longrightarrow> q \<in> P[X] \<Longrightarrow> p + q \<in> P[X]"
   using indets_plus_subset[of p q] by (auto simp: Polys_alt PPs_def)
 
 lemma Polys_closed_uminus: "p \<in> P[X] \<Longrightarrow> -p \<in> P[X]"
   by (simp add: Polys_def keys_uminus)
 
 lemma Polys_closed_minus: "p \<in> P[X] \<Longrightarrow> q \<in> P[X] \<Longrightarrow> p - q \<in> P[X]"
   using indets_minus_subset[of p q] by (auto simp: Polys_alt PPs_def)
 
 lemma Polys_closed_monom_mult: "t \<in> .[X] \<Longrightarrow> p \<in> P[X] \<Longrightarrow> punit.monom_mult c t p \<in> P[X]"
   using indets_monom_mult_subset[of c t p] by (auto simp: Polys_alt PPs_def)
 
 corollary Polys_closed_map_scale: "p \<in> P[X] \<Longrightarrow> (c::_::semiring_0) \<cdot> p \<in> P[X]"
   unfolding punit.map_scale_eq_monom_mult using zero_in_PPs by (rule Polys_closed_monom_mult)
 
 lemma Polys_closed_times: "p \<in> P[X] \<Longrightarrow> q \<in> P[X] \<Longrightarrow> p * q \<in> P[X]"
   using indets_times_subset[of p q] by (auto simp: Polys_alt PPs_def)
 
 lemma Polys_closed_power: "p \<in> P[X] \<Longrightarrow> p ^ m \<in> P[X]"
   by (induct m) (auto intro: one_in_Polys Polys_closed_times)
 
 lemma Polys_closed_sum: "(\<And>a. a \<in> A \<Longrightarrow> f a \<in> P[X]) \<Longrightarrow> sum f A \<in> P[X]"
   by (induct A rule: infinite_finite_induct) (auto intro: zero_in_Polys Polys_closed_plus)
 
 lemma Polys_closed_prod: "(\<And>a. a \<in> A \<Longrightarrow> f a \<in> P[X]) \<Longrightarrow> prod f A \<in> P[X]"
   by (induct A rule: infinite_finite_induct) (auto intro: one_in_Polys Polys_closed_times)
 
 lemma Polys_closed_sum_list: "(\<And>x. x \<in> set xs \<Longrightarrow> x \<in> P[X]) \<Longrightarrow> sum_list xs \<in> P[X]"
   by (induct xs) (auto intro: zero_in_Polys Polys_closed_plus)
 
 lemma Polys_closed_except: "p \<in> P[X] \<Longrightarrow> except p T \<in> P[X]"
   by (auto intro!: PolysI simp: keys_except dest!: PolysD(1))
 
 lemma times_in_PolysD:
   assumes "p * q \<in> P[X]" and "p \<in> P[X]" and "p \<noteq> (0::('x::linorder \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::semiring_no_zero_divisors)"
   shows "q \<in> P[X]"
 proof -
   define qX where "qX = except q (- .[X])"
   define qY where "qY = except q .[X]"
   have q: "q = qX + qY" by (simp only: qX_def qY_def add.commute flip: except_decomp)
   have "qX \<in> P[X]" by (rule PolysI) (simp add: qX_def keys_except)
   with assms(2) have "p * qX \<in> P[X]" by (rule Polys_closed_times)
   show ?thesis
   proof (cases "qY = 0")
     case True
     with \<open>qX \<in> P[X]\<close> show ?thesis by (simp add: q)
   next
     case False
     with assms(3) have "p * qY \<noteq> 0" by simp
     hence "keys (p * qY) \<noteq> {}" by simp
     then obtain t where "t \<in> keys (p * qY)" by blast
     then obtain t1 t2 where "t2 \<in> keys qY" and t: "t = t1 + t2" by (rule in_keys_timesE)
     have "t \<notin> .[X]" unfolding t
     proof
       assume "t1 + t2 \<in> .[X]"
       hence "t1 + t2 - t1 \<in> .[X]" by (rule PPs_closed_minus)
       hence "t2 \<in> .[X]" by simp
       with \<open>t2 \<in> keys qY\<close> show False by (simp add: qY_def keys_except)
     qed
     have "t \<notin> keys (p * qX)"
     proof
       assume "t \<in> keys (p * qX)"
       also from \<open>p * qX \<in> P[X]\<close> have "\<dots> \<subseteq> .[X]" by (rule PolysD)
       finally have "t \<in> .[X]" .
       with \<open>t \<notin> .[X]\<close> show False ..
     qed
     with \<open>t \<in> keys (p * qY)\<close> have "t \<in> keys (p * qX + p * qY)" by (rule in_keys_plusI2)
     also have "\<dots> = keys (p * q)" by (simp only: q algebra_simps)
     finally have "p * q \<notin> P[X]" using \<open>t \<notin> .[X]\<close> by (auto simp: Polys_def)
     thus ?thesis using assms(1) ..
   qed
 qed
 
 lemma poly_mapping_plus_induct_Polys [consumes 1, case_names 0 plus]:
   assumes "p \<in> P[X]" and "P 0"
     and "\<And>p c t. t \<in> .[X] \<Longrightarrow> p \<in> P[X] \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> t \<notin> keys p \<Longrightarrow> P p \<Longrightarrow> P (monomial c t + p)"
   shows "P p"
   using assms(1)
 proof (induct p rule: poly_mapping_plus_induct)
   case 1
   show ?case by (fact assms(2))
 next
   case step: (2 p c t)
   from step.hyps(1) have 1: "keys (monomial c t) = {t}" by simp
   also from step.hyps(2) have "\<dots> \<inter> keys p = {}" by simp
   finally have "keys (monomial c t + p) = keys (monomial c t) \<union> keys p" by (rule keys_add[symmetric])
   hence "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
   moreover from step.prems(1) have "keys (monomial c t + p) \<subseteq> .[X]" by (rule PolysD)
   ultimately have "t \<in> .[X]" and "keys p \<subseteq> .[X]" by blast+
   from this(2) have "p \<in> P[X]" by (rule PolysI)
   hence "P p" by (rule step.hyps)
   with \<open>t \<in> .[X]\<close> \<open>p \<in> P[X]\<close> step.hyps(1, 2) show ?case by (rule assms(3))
 qed
 
 lemma Polys_Int: "P[X \<inter> Y] = P[X] \<inter> P[Y]"
   by (auto simp: Polys_def PPs_Int)
 
 lemma Polys_INT: "P[\<Inter> X] = \<Inter> (Polys ` X)"
   by (auto simp: Polys_def PPs_INT)
 
 subsection \<open>Substitution Homomorphism\<close>
 
 text \<open>The substitution homomorphism defined here is more general than @{const insertion}, since
   it replaces indeterminates by @{emph \<open>polynomials\<close>} rather than coefficients, and therefore
   constructs new polynomials.\<close>
 
 definition subst_pp :: "('x \<Rightarrow> (('y \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a)) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> (('y \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1)"
   where "subst_pp f t = (\<Prod>x\<in>keys t. (f x) ^ (lookup t x))"
 
 definition poly_subst :: "('x \<Rightarrow> (('y \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a)) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('y \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1)"
   where "poly_subst f p = (\<Sum>t\<in>keys p. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
 
 lemma subst_pp_alt: "subst_pp f t = (\<Prod>x. (f x) ^ (lookup t x))"
 proof -
   from finite_keys have "subst_pp f t = (\<Prod>x. if x \<in> keys t then (f x) ^ (lookup t x) else 1)"
     unfolding subst_pp_def by (rule Prod_any.conditionalize)
   also have "... = (\<Prod>x. (f x) ^ (lookup t x))" by (rule Prod_any.cong) (simp add: in_keys_iff)
   finally show ?thesis .
 qed
 
 lemma subst_pp_zero [simp]: "subst_pp f 0 = 1"
   by (simp add: subst_pp_def)
 
 lemma subst_pp_trivial_not_zero:
   assumes "t \<noteq> 0"
   shows "subst_pp (\<lambda>_. 0) t = (0::(_ \<Rightarrow>\<^sub>0 'b::comm_semiring_1))"
   unfolding subst_pp_def using finite_keys
 proof (rule prod_zero)
   from assms have "keys t \<noteq> {}" by simp
   then obtain x where "x \<in> keys t" by blast
   thus "\<exists>x\<in>keys t. 0 ^ lookup t x = (0::(_ \<Rightarrow>\<^sub>0 'b))"
   proof
     from \<open>x \<in> keys t\<close> have "0 < lookup t x" by (simp add: in_keys_iff)
     thus "0 ^ lookup t x = (0::(_ \<Rightarrow>\<^sub>0 'b))" by (rule Power.semiring_1_class.zero_power)
   qed
 qed
 
 lemma subst_pp_single: "subst_pp f (Poly_Mapping.single x e) = (f x) ^ e"
   by (simp add: subst_pp_def)
 
 corollary subst_pp_trivial: "subst_pp (\<lambda>_. 0) t = (if t = 0 then 1 else 0)"
   by (simp split: if_split add: subst_pp_trivial_not_zero)
 
 lemma power_lookup_not_one_subset_keys: "{x. f x ^ (lookup t x) \<noteq> 1} \<subseteq> keys t"
 proof (rule, simp)
   fix x
   assume "f x ^ (lookup t x) \<noteq> 1"
   thus "x \<in> keys t" unfolding in_keys_iff by (metis power_0)
 qed
 
 corollary finite_power_lookup_not_one: "finite {x. f x ^ (lookup t x) \<noteq> 1}"
   by (rule finite_subset, fact power_lookup_not_one_subset_keys, fact finite_keys)
 
 lemma subst_pp_plus: "subst_pp f (s + t) = subst_pp f s * subst_pp f t"
   by (simp add: subst_pp_alt lookup_add power_add, rule Prod_any.distrib, (fact finite_power_lookup_not_one)+)
 
 lemma subst_pp_id:
   assumes "\<And>x. x \<in> keys t \<Longrightarrow> f x = monomial 1 (Poly_Mapping.single x 1)"
   shows "subst_pp f t = monomial 1 t"
 proof -
   have "subst_pp f t = (\<Prod>x\<in>keys t. monomial 1 (Poly_Mapping.single x (lookup t x)))"
   proof (simp only: subst_pp_def, rule prod.cong, fact refl)
     fix x
     assume "x \<in> keys t"
     thus "f x ^ lookup t x = monomial 1 (Poly_Mapping.single x (lookup t x))"
       by (simp add: assms monomial_single_power)
   qed
   also have "... = monomial 1 t"
     by (simp add: punit.monomial_prod_sum[symmetric] poly_mapping_sum_monomials)
   finally show ?thesis .
 qed
 
 lemma in_indets_subst_ppE:
   assumes "x \<in> indets (subst_pp f t)"
   obtains y where "y \<in> keys t" and "x \<in> indets (f y)"
 proof -
   note assms
   also have "indets (subst_pp f t) \<subseteq> (\<Union>y\<in>keys t. indets ((f y) ^ (lookup t y)))" unfolding subst_pp_def
     by (rule indets_prod_subset)
   finally obtain y where "y \<in> keys t" and "x \<in> indets ((f y) ^ (lookup t y))" ..
   note this(2)
   also have "indets ((f y) ^ (lookup t y)) \<subseteq> indets (f y)" by (rule indets_power_subset)
   finally have "x \<in> indets (f y)" .
   with \<open>y \<in> keys t\<close> show ?thesis ..
 qed
 
 lemma subst_pp_by_monomials:
   assumes "\<And>y. y \<in> keys t \<Longrightarrow> f y = monomial (c y) (s y)"
   shows "subst_pp f t = monomial (\<Prod>y\<in>keys t. (c y) ^ lookup t y) (\<Sum>y\<in>keys t. lookup t y \<cdot> s y)"
   by (simp add: subst_pp_def assms monomial_power_map_scale punit.monomial_prod_sum)
 
 lemma poly_deg_subst_pp_eq_zeroI:
   assumes "\<And>x. x \<in> keys t \<Longrightarrow> poly_deg (f x) = 0"
   shows "poly_deg (subst_pp f t) = 0"
 proof -
   have "poly_deg (subst_pp f t) \<le> (\<Sum>x\<in>keys t. poly_deg ((f x) ^ (lookup t x)))"
     unfolding subst_pp_def by (fact poly_deg_prod_le)
   also have "... = 0"
   proof (rule sum.neutral, rule)
     fix x
     assume "x \<in> keys t"
     hence "poly_deg (f x) = 0" by (rule assms)
     have "f x ^ lookup t x = (\<Prod>i=0..<lookup t x. f x)" by simp
     also have "poly_deg ... \<le> (\<Sum>i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
     also have "... = 0" by (simp add: \<open>poly_deg (f x) = 0\<close>)
     finally show "poly_deg (f x ^ lookup t x) = 0" by simp
   qed
   finally show ?thesis by simp
 qed
 
 lemma poly_deg_subst_pp_le:
   assumes "\<And>x. x \<in> keys t \<Longrightarrow> poly_deg (f x) \<le> 1"
   shows "poly_deg (subst_pp f t) \<le> deg_pm t"
 proof -
   have "poly_deg (subst_pp f t) \<le> (\<Sum>x\<in>keys t. poly_deg ((f x) ^ (lookup t x)))"
     unfolding subst_pp_def by (fact poly_deg_prod_le)
   also have "... \<le> (\<Sum>x\<in>keys t. lookup t x)"
   proof (rule sum_mono)
     fix x
     assume "x \<in> keys t"
     hence "poly_deg (f x) \<le> 1" by (rule assms)
     have "f x ^ lookup t x = (\<Prod>i=0..<lookup t x. f x)" by simp
     also have "poly_deg ... \<le> (\<Sum>i=0..<lookup t x. poly_deg (f x))" by (rule poly_deg_prod_le)
     also from \<open>poly_deg (f x) \<le> 1\<close> have "... \<le> (\<Sum>i=0..<lookup t x. 1)" by (rule sum_mono)
     finally show "poly_deg (f x ^ lookup t x) \<le> lookup t x" by simp
   qed
   also have "... = deg_pm t" by (rule deg_pm_superset[symmetric], fact subset_refl, fact finite_keys)
   finally show ?thesis by simp
 qed
 
 lemma poly_subst_alt: "poly_subst f p = (\<Sum>t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
 proof -
   from finite_keys have "poly_subst f p = (\<Sum>t. if t \<in> keys p then punit.monom_mult (lookup p t) 0 (subst_pp f t) else 0)"
     unfolding poly_subst_def by (rule Sum_any.conditionalize)
   also have "\<dots> = (\<Sum>t. punit.monom_mult (lookup p t) 0 (subst_pp f t))"
     by (rule Sum_any.cong) (simp add: in_keys_iff)
   finally show ?thesis .
 qed
 
 lemma poly_subst_trivial [simp]: "poly_subst (\<lambda>_. 0) p = monomial (lookup p 0) 0"
   by (simp add: poly_subst_def subst_pp_trivial if_distrib in_keys_iff cong: if_cong)
       (metis mult.right_neutral times_monomial_left)
 
 lemma poly_subst_zero [simp]: "poly_subst f 0 = 0"
   by (simp add: poly_subst_def)
 
 lemma monom_mult_lookup_not_zero_subset_keys:
   "{t. punit.monom_mult (lookup p t) 0 (subst_pp f t) \<noteq> 0} \<subseteq> keys p"
 proof (rule, simp)
   fix t
   assume "punit.monom_mult (lookup p t) 0 (subst_pp f t) \<noteq> 0"
   thus "t \<in> keys p" unfolding in_keys_iff by (metis punit.monom_mult_zero_left)
 qed
 
 corollary finite_monom_mult_lookup_not_zero:
   "finite {t. punit.monom_mult (lookup p t) 0 (subst_pp f t) \<noteq> 0}"
   by (rule finite_subset, fact monom_mult_lookup_not_zero_subset_keys, fact finite_keys)
 
 lemma poly_subst_plus: "poly_subst f (p + q) = poly_subst f p + poly_subst f q"
   by (simp add: poly_subst_alt lookup_add punit.monom_mult_dist_left, rule Sum_any.distrib,
       (fact finite_monom_mult_lookup_not_zero)+)
 
 lemma poly_subst_uminus: "poly_subst f (-p) = - poly_subst f (p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::comm_ring_1)"
   by (simp add: poly_subst_def keys_uminus punit.monom_mult_uminus_left sum_negf)
 
 lemma poly_subst_minus:
   "poly_subst f (p - q) = poly_subst f p - poly_subst f (q::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::comm_ring_1)"
 proof -
   have "poly_subst f (p + (-q)) = poly_subst f p + poly_subst f (-q)" by (fact poly_subst_plus)
   thus ?thesis by (simp add: poly_subst_uminus)
 qed
 
 lemma poly_subst_monomial: "poly_subst f (monomial c t) = punit.monom_mult c 0 (subst_pp f t)"
   by (simp add: poly_subst_def lookup_single)
 
 corollary poly_subst_one [simp]: "poly_subst f 1 = 1"
   by (simp add: single_one[symmetric] poly_subst_monomial punit.monom_mult_monomial del: single_one)
 
 lemma poly_subst_times: "poly_subst f (p * q) = poly_subst f p * poly_subst f q"
 proof -
   have bij: "bij (\<lambda>(l, n, m). (m, l, n))"
     by (auto intro!: bijI injI simp add: image_def)
   let ?P = "keys p"
   let ?Q = "keys q"
   let ?PQ = "{s + t | s t. lookup p s \<noteq> 0 \<and> lookup q t \<noteq> 0}"
   have fin_PQ: "finite ?PQ"
     by (rule finite_not_eq_zero_sumI, simp_all)
   have fin_1: "finite {l. lookup p l * (\<Sum>qa. lookup q qa when t = l + qa) \<noteq> 0}" for t
   proof (rule finite_subset)
     show "{l. lookup p l * (\<Sum>qa. lookup q qa when t = l + qa) \<noteq> 0} \<subseteq> keys p"
       by (rule, auto simp: in_keys_iff)
   qed (fact finite_keys)
   have fin_2: "finite {v. (lookup q v when t = u + v) \<noteq> 0}" for t u
   proof (rule finite_subset)
     show "{v. (lookup q v when t = u + v) \<noteq> 0} \<subseteq> keys q"
       by (rule, auto simp: in_keys_iff)
   qed (fact finite_keys)
   have fin_3: "finite {v. (lookup p u * lookup q v when t = u + v) \<noteq> 0}" for t u
   proof (rule finite_subset)
     show "{v. (lookup p u * lookup q v when t = u + v) \<noteq> 0} \<subseteq> keys q"
       by (rule, auto simp add: in_keys_iff simp del: lookup_not_eq_zero_eq_in_keys)
   qed (fact finite_keys)
   have "(\<Sum>t. punit.monom_mult (lookup (p * q) t) 0 (subst_pp f t)) =
         (\<Sum>t. \<Sum>u. punit.monom_mult (lookup p u * (\<Sum>v. lookup q v when t = u + v)) 0 (subst_pp f t))"
     by (simp add: times_poly_mapping.rep_eq prod_fun_def punit.monom_mult_Sum_any_left[OF fin_1])
   also have "\<dots> = (\<Sum>t. \<Sum>u. \<Sum>v. (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v)"
     by (simp add: Sum_any_right_distrib[OF fin_2] punit.monom_mult_Sum_any_left[OF fin_3] mult_when punit.when_monom_mult)
   also have "\<dots> = (\<Sum>t. (\<Sum>(u, v). (punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t)) when t = u + v))"
     by (subst (2) Sum_any.cartesian_product [of "?P \<times> ?Q"]) (auto simp: in_keys_iff)
   also have "\<dots> = (\<Sum>(t, u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
     apply (subst Sum_any.cartesian_product [of "?PQ \<times> (?P \<times> ?Q)"])
     apply (auto simp: fin_PQ in_keys_iff)
     apply (metis monomial_0I mult_not_zero times_monomial_left)
     done
   also have "\<dots> = (\<Sum>(u, v, t). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
     using bij by (rule Sum_any.reindex_cong [of "\<lambda>(u, v, t). (t, u, v)"]) (simp add: fun_eq_iff)
   also have "\<dots> = (\<Sum>(u, v). \<Sum>t. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f t) when t = u + v)"
     apply (subst Sum_any.cartesian_product2 [of "(?P \<times> ?Q) \<times> ?PQ"])
     apply (auto simp: fin_PQ in_keys_iff)
     apply (metis monomial_0I mult_not_zero times_monomial_left)
     done
   also have "\<dots> = (\<Sum>(u, v). punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
     by (simp add: subst_pp_plus)
   also have "\<dots> = (\<Sum>u. \<Sum>v. punit.monom_mult (lookup p u * lookup q v) 0 (subst_pp f u * subst_pp f v))"
     by (subst Sum_any.cartesian_product [of "?P \<times> ?Q"]) (auto simp: in_keys_iff)
   also have "\<dots> = (\<Sum>u. \<Sum>v. (punit.monom_mult (lookup p u) 0 (subst_pp f u)) * (punit.monom_mult (lookup q v) 0 (subst_pp f v)))"
     by (simp add: times_monomial_left[symmetric] ac_simps mult_single)
   also have "\<dots> = (\<Sum>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) *
                   (\<Sum>t. punit.monom_mult (lookup q t) 0 (subst_pp f t))"
     by (rule Sum_any_product [symmetric], (fact finite_monom_mult_lookup_not_zero)+)
   finally show ?thesis by (simp add: poly_subst_alt)
 qed
 
 corollary poly_subst_monom_mult:
   "poly_subst f (punit.monom_mult c t p) = punit.monom_mult c 0 (subst_pp f t * poly_subst f p)"
   by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial mult.assoc)
 
 corollary poly_subst_monom_mult':
   "poly_subst f (punit.monom_mult c t p) = (punit.monom_mult c 0 (subst_pp f t)) * poly_subst f p"
   by (simp only: times_monomial_left[symmetric] poly_subst_times poly_subst_monomial)
 
 lemma poly_subst_sum: "poly_subst f (sum p A) = (\<Sum>a\<in>A. poly_subst f (p a))"
   by (rule fun_sum_commute, simp_all add: poly_subst_plus)
 
 lemma poly_subst_prod: "poly_subst f (prod p A) = (\<Prod>a\<in>A. poly_subst f (p a))"
   by (rule fun_prod_commute, simp_all add: poly_subst_times)
 
 lemma poly_subst_power: "poly_subst f (p ^ n) = (poly_subst f p) ^ n"
   by (induct n, simp_all add: poly_subst_times)
 
 lemma poly_subst_subst_pp: "poly_subst f (subst_pp g t) = subst_pp (\<lambda>x. poly_subst f (g x)) t"
   by (simp only: subst_pp_def poly_subst_prod poly_subst_power)
 
 lemma poly_subst_poly_subst: "poly_subst f (poly_subst g p) = poly_subst (\<lambda>x. poly_subst f (g x)) p"
 proof -
   have "poly_subst f (poly_subst g p) =
           poly_subst f (\<Sum>t\<in>keys p. punit.monom_mult (lookup p t) 0 (subst_pp g t))"
     by (simp only: poly_subst_def)
   also have "\<dots> = (\<Sum>t\<in>keys p. punit.monom_mult (lookup p t) 0 (subst_pp (\<lambda>x. poly_subst f (g x)) t))"
     by (simp add: poly_subst_sum poly_subst_monom_mult poly_subst_subst_pp)
   also have "\<dots> = poly_subst (\<lambda>x. poly_subst f (g x)) p" by (simp only: poly_subst_def)
   finally show ?thesis .
 qed
 
 lemma poly_subst_id:
   assumes "\<And>x. x \<in> indets p \<Longrightarrow> f x = monomial 1 (Poly_Mapping.single x 1)"
   shows "poly_subst f p = p"
 proof -
   have "poly_subst f p = (\<Sum>t\<in>keys p. monomial (lookup p t) t)"
   proof (simp only: poly_subst_def, rule sum.cong, fact refl)
     fix t
     assume "t \<in> keys p"
     have eq: "subst_pp f t = monomial 1 t"
       by (rule subst_pp_id, rule assms, erule in_indetsI, fact \<open>t \<in> keys p\<close>)
     show "punit.monom_mult (lookup p t) 0 (subst_pp f t) = monomial (lookup p t) t"
       by (simp add: eq punit.monom_mult_monomial)
   qed
   also have "... = p" by (simp only: poly_mapping_sum_monomials)
   finally show ?thesis .
 qed
 
 lemma in_keys_poly_substE:
   assumes "t \<in> keys (poly_subst f p)"
   obtains s where "s \<in> keys p" and "t \<in> keys (subst_pp f s)"
 proof -
   note assms
   also have "keys (poly_subst f p) \<subseteq> (\<Union>t\<in>keys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
     unfolding poly_subst_def by (rule keys_sum_subset)
   finally obtain s where "s \<in> keys p" and "t \<in> keys (punit.monom_mult (lookup p s) 0 (subst_pp f s))" ..
   note this(2)
   also have "\<dots> \<subseteq> (+) 0 ` keys (subst_pp f s)" by (rule punit.keys_monom_mult_subset[simplified])
   also have "\<dots> = keys (subst_pp f s)" by simp
   finally have "t \<in> keys (subst_pp f s)" .
   with \<open>s \<in> keys p\<close> show ?thesis ..
 qed
 
 lemma in_indets_poly_substE:
   assumes "x \<in> indets (poly_subst f p)"
   obtains y where "y \<in> indets p" and "x \<in> indets (f y)"
 proof -
   note assms
   also have "indets (poly_subst f p) \<subseteq> (\<Union>t\<in>keys p. indets (punit.monom_mult (lookup p t) 0 (subst_pp f t)))"
     unfolding poly_subst_def by (rule indets_sum_subset)
   finally obtain t where "t \<in> keys p" and "x \<in> indets (punit.monom_mult (lookup p t) 0 (subst_pp f t))" ..
   note this(2)
   also have "indets (punit.monom_mult (lookup p t) 0 (subst_pp f t)) \<subseteq> keys (0::('a \<Rightarrow>\<^sub>0 nat)) \<union> indets (subst_pp f t)"
     by (rule indets_monom_mult_subset)
   also have "... = indets (subst_pp f t)" by simp
   finally obtain y where "y \<in> keys t" and "x \<in> indets (f y)" by (rule in_indets_subst_ppE)
   from this(1) \<open>t \<in> keys p\<close> have "y \<in> indets p" by (rule in_indetsI)
   from this \<open>x \<in> indets (f y)\<close> show ?thesis ..
 qed
 
 lemma poly_deg_poly_subst_eq_zeroI:
   assumes "\<And>x. x \<in> indets p \<Longrightarrow> poly_deg (f x) = 0"
   shows "poly_deg (poly_subst (f::_ \<Rightarrow> (('y \<Rightarrow>\<^sub>0 _) \<Rightarrow>\<^sub>0 _)) (p::('x \<Rightarrow>\<^sub>0 _) \<Rightarrow>\<^sub>0 'b::comm_semiring_1)) = 0"
 proof (cases "p = 0")
   case True
   thus ?thesis by simp
 next
   case False
   have "poly_deg (poly_subst f p) \<le> Max (poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
     unfolding poly_subst_def by (fact poly_deg_sum_le)
   also have "... \<le> 0"
   proof (rule Max.boundedI)
     show "finite (poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
       by (simp add: finite_image_iff)
   next
     from False show "poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p \<noteq> {}" by simp
   next
     fix d
     assume "d \<in> poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
     then obtain t where "t \<in> keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
       by fastforce
     have "d \<le> deg_pm (0::'y \<Rightarrow>\<^sub>0 nat) + poly_deg (subst_pp f t)"
       unfolding d by (fact poly_deg_monom_mult_le)
     also have "... = poly_deg (subst_pp f t)" by simp
     also have "... = 0" by (rule poly_deg_subst_pp_eq_zeroI, rule assms, erule in_indetsI, fact)
     finally show "d \<le> 0" .
   qed
   finally show ?thesis by simp
 qed
 
 lemma poly_deg_poly_subst_le:
   assumes "\<And>x. x \<in> indets p \<Longrightarrow> poly_deg (f x) \<le> 1"
   shows "poly_deg (poly_subst (f::_ \<Rightarrow> (('y \<Rightarrow>\<^sub>0 _) \<Rightarrow>\<^sub>0 _)) (p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::comm_semiring_1)) \<le> poly_deg p"
 proof (cases "p = 0")
   case True
   thus ?thesis by simp
 next
   case False
   have "poly_deg (poly_subst f p) \<le> Max (poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
     unfolding poly_subst_def by (fact poly_deg_sum_le)
   also have "... \<le> poly_deg p"
   proof (rule Max.boundedI)
     show "finite (poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p)"
       by (simp add: finite_image_iff)
   next
     from False show "poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p \<noteq> {}" by simp
   next
     fix d
     assume "d \<in> poly_deg ` (\<lambda>t. punit.monom_mult (lookup p t) 0 (subst_pp f t)) ` keys p"
     then obtain t where "t \<in> keys p" and d: "d = poly_deg (punit.monom_mult (lookup p t) 0 (subst_pp f t))"
       by fastforce
     have "d \<le> deg_pm (0::'y \<Rightarrow>\<^sub>0 nat) + poly_deg (subst_pp f t)"
       unfolding d by (fact poly_deg_monom_mult_le)
     also have "... = poly_deg (subst_pp f t)" by simp
     also have "... \<le> deg_pm t" by (rule poly_deg_subst_pp_le, rule assms, erule in_indetsI, fact)
     also from \<open>t \<in> keys p\<close> have "... \<le> poly_deg p" by (rule poly_deg_max_keys)
     finally show "d \<le> poly_deg p" .
   qed
   finally show ?thesis by simp
 qed
 
 lemma subst_pp_cong: "s = t \<Longrightarrow> (\<And>x. x \<in> keys t \<Longrightarrow> f x = g x) \<Longrightarrow> subst_pp f s = subst_pp g t"
   by (simp add: subst_pp_def)
 
 lemma poly_subst_cong:
   assumes "p = q" and "\<And>x. x \<in> indets q \<Longrightarrow> f x = g x"
   shows "poly_subst f p = poly_subst g q"
 proof (simp add: poly_subst_def assms(1), rule sum.cong)
   fix t
   assume "t \<in> keys q"
   {
     fix x
     assume "x \<in> keys t"
     with \<open>t \<in> keys q\<close> have "x \<in> indets q" by (auto simp: indets_def)
     hence "f x = g x" by (rule assms(2))
   }
   thus "punit.monom_mult (lookup q t) 0 (subst_pp f t) = punit.monom_mult (lookup q t) 0 (subst_pp g t)"
     by (simp cong: subst_pp_cong)
 qed (fact refl)
 
 lemma Polys_homomorphismE:
   obtains h where "\<And>p q. h (p + q) = h p + h q" and "\<And>p q. h (p * q) = h p * h q"
     and "\<And>p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1. h (h p) = h p" and "range h = P[X]"
 proof -
   let ?f = "\<lambda>x. if x \<in> X then monomial (1::'a) (Poly_Mapping.single x 1) else 1"
 
   have 1: "poly_subst ?f p = p" if "p \<in> P[X]" for p
   proof (rule poly_subst_id)
     fix x
     assume "x \<in> indets p"
     also from that have "\<dots> \<subseteq> X" by (rule PolysD)
     finally show "?f x = monomial 1 (Poly_Mapping.single x 1)" by simp
   qed
 
   have 2: "poly_subst ?f p \<in> P[X]" for p
   proof (intro PolysI_alt subsetI)
     fix x
     assume "x \<in> indets (poly_subst ?f p)"
     then obtain y where "x \<in> indets (?f y)" by (rule in_indets_poly_substE)
     thus "x \<in> X" by (simp add: indets_monomial split: if_split_asm)
   qed
 
   from poly_subst_plus poly_subst_times show ?thesis
   proof
     fix p
     from 2 show "poly_subst ?f (poly_subst ?f p) = poly_subst ?f p" by (rule 1)
   next
     show "range (poly_subst ?f) = P[X]"
     proof (intro set_eqI iffI)
       fix p :: "_ \<Rightarrow>\<^sub>0 'a"
       assume "p \<in> P[X]"
       hence "p = poly_subst ?f p" by (simp only: 1)
       thus "p \<in> range (poly_subst ?f)" by (rule image_eqI) simp
     qed (auto intro: 2)
   qed
 qed
 
 lemma in_idealE_Polys_finite:
   assumes "finite B" and "B \<subseteq> P[X]" and "p \<in> P[X]" and "(p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) \<in> ideal B"
   obtains q where "\<And>b. q b \<in> P[X]" and "p = (\<Sum>b\<in>B. q b * b)"
 proof -
   obtain h where "\<And>p q. h (p + q) = h p + h q" and "\<And>p q. h (p * q) = h p * h q"
     and "\<And>p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
     by (rule Polys_homomorphismE) blast
   from this(1-3) assms obtain q where "\<And>b. q b \<in> P[X]" and "p = (\<Sum>b\<in>B. q b * b)"
     unfolding rng by (rule in_idealE_homomorphism_finite) blast
   thus ?thesis ..
 qed
 
 corollary in_idealE_Polys:
   assumes "B \<subseteq> P[X]" and "p \<in> P[X]" and "p \<in> ideal B"
   obtains A q where "finite A" and "A \<subseteq> B" and "\<And>b. q b \<in> P[X]" and "p = (\<Sum>b\<in>A. q b * b)"
 proof -
   from assms(3) obtain A where "finite A" and "A \<subseteq> B" and "p \<in> ideal A"
     by (rule ideal.span_finite_subset)
   from this(2) assms(1) have "A \<subseteq> P[X]" by (rule subset_trans)
   with \<open>finite A\<close> obtain q where "\<And>b. q b \<in> P[X]" and "p = (\<Sum>b\<in>A. q b * b)"
     using assms(2) \<open>p \<in> ideal A\<close> by (rule in_idealE_Polys_finite) blast
   with \<open>finite A\<close> \<open>A \<subseteq> B\<close> show ?thesis ..
 qed
 
 lemma ideal_induct_Polys [consumes 3, case_names 0 plus]:
   assumes "F \<subseteq> P[X]" and "p \<in> P[X]" and "p \<in> ideal F"
   assumes "P 0" and "\<And>c q h. c \<in> P[X] \<Longrightarrow> q \<in> F \<Longrightarrow> P h \<Longrightarrow> h \<in> P[X] \<Longrightarrow> P (c * q + h)"
   shows "P (p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1)"
 proof -
   obtain h where "\<And>p q. h (p + q) = h p + h q" and "\<And>p q. h (p * q) = h p * h q"
     and "\<And>p::('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a. h (h p) = h p" and rng[symmetric]: "range h = P[X]"
     by (rule Polys_homomorphismE) blast
   from this(1-3) assms show ?thesis
     unfolding rng by (rule ideal_induct_homomorphism) blast
 qed
 
 lemma image_poly_subst_ideal_subset: "poly_subst g ` ideal F \<subseteq> ideal (poly_subst g ` F)"
 proof (intro subsetI, elim imageE)
   fix h f
   assume h: "h = poly_subst g f"
   assume "f \<in> ideal F"
   thus "h \<in> ideal (poly_subst g ` F)" unfolding h
   proof (induct f rule: ideal.span_induct_alt)
     case base
     show ?case by (simp add: ideal.span_zero)
   next
     case (step c f h)
     from step.hyps(1) have "poly_subst g f \<in> ideal (poly_subst g ` F)"
       by (intro ideal.span_base imageI)
     hence "poly_subst g c * poly_subst g f \<in> ideal (poly_subst g ` F)" by (rule ideal.span_scale)
     hence "poly_subst g c * poly_subst g f + poly_subst g h \<in> ideal (poly_subst g ` F)"
       using step.hyps(2) by (rule ideal.span_add)
     thus ?case by (simp only: poly_subst_plus poly_subst_times)
   qed
 qed
 
 subsection \<open>Evaluating Polynomials\<close>
 
 lemma lookup_times_zero:
   "lookup (p * q) 0 = lookup p 0 * lookup q (0::'a::{comm_powerprod,ninv_comm_monoid_add})"
 proof -
   have eq: "(\<Sum>v\<in>keys q. lookup q v when t + v = 0) = (lookup q 0 when t = 0)" for t
   proof -
     have "(\<Sum>v\<in>keys q. lookup q v when t + v = 0) = (\<Sum>v\<in>keys q \<inter> {0}. lookup q v when t + v = 0)"
     proof (intro sum.mono_neutral_right ballI)
       fix v
       assume "v \<in> keys q - keys q \<inter> {0}"
       hence "v \<noteq> 0" by blast
       hence "t + v \<noteq> 0" using plus_eq_zero_2 by blast
       thus "(lookup q v when t + v = 0) = 0" by simp
     qed simp_all
     also have "\<dots> = (lookup q 0 when t = 0)" by (cases "0 \<in> keys q") (simp_all add: in_keys_iff)
     finally show ?thesis .
   qed
   have "(\<Sum>t\<in>keys p. lookup p t * lookup q 0 when t = 0) =
           (\<Sum>t\<in>keys p \<inter> {0}. lookup p t * lookup q 0 when t = 0)"
   proof (intro sum.mono_neutral_right ballI)
     fix t
     assume "t \<in> keys p - keys p \<inter> {0}"
     hence "t \<noteq> 0" by blast
     thus "(lookup p t * lookup q 0 when t = 0) = 0" by simp
   qed simp_all
   also have "\<dots> = lookup p 0 * lookup q 0" by (cases "0 \<in> keys p") (simp_all add: in_keys_iff)
   finally show ?thesis by (simp add: lookup_times eq when_distrib)
 qed
 
 corollary lookup_prod_zero:
   "lookup (prod f I) 0 = (\<Prod>i\<in>I. lookup (f i) (0::_::{comm_powerprod,ninv_comm_monoid_add}))"
   by (induct I rule: infinite_finite_induct) (simp_all add: lookup_times_zero)
 
 corollary lookup_power_zero:
   "lookup (p ^ k) 0 = lookup p (0::_::{comm_powerprod,ninv_comm_monoid_add}) ^ k"
   by (induct k) (simp_all add: lookup_times_zero)
 
 definition poly_eval :: "('x \<Rightarrow> 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> 'a::comm_semiring_1"
   where "poly_eval a p = lookup (poly_subst (\<lambda>y. monomial (a y) (0::'x \<Rightarrow>\<^sub>0 nat)) p) 0"
 
 lemma poly_eval_alt: "poly_eval a p = (\<Sum>t\<in>keys p. lookup p t * (\<Prod>x\<in>keys t. a x ^ lookup t x))"
   by (simp add: poly_eval_def poly_subst_def lookup_sum lookup_times_zero subst_pp_def
           lookup_prod_zero lookup_power_zero flip: times_monomial_left)
 
 lemma poly_eval_monomial: "poly_eval a (monomial c t) = c * (\<Prod>x\<in>keys t. a x ^ lookup t x)"
   by (simp add: poly_eval_def poly_subst_monomial subst_pp_def punit.lookup_monom_mult
       lookup_prod_zero lookup_power_zero)
 
 lemma poly_eval_zero [simp]: "poly_eval a 0 = 0"
   by (simp only: poly_eval_def poly_subst_zero lookup_zero)
 
 lemma poly_eval_zero_left [simp]: "poly_eval 0 p = lookup p 0"
   by (simp add: poly_eval_def)
 
 lemma poly_eval_plus: "poly_eval a (p + q) = poly_eval a p + poly_eval a q"
   by (simp only: poly_eval_def poly_subst_plus lookup_add)
 
 lemma poly_eval_uminus [simp]: "poly_eval a (- p) = - poly_eval (a::_::comm_ring_1) p"
   by (simp only: poly_eval_def poly_subst_uminus lookup_uminus)
 
 lemma poly_eval_minus: "poly_eval a (p - q) = poly_eval a p - poly_eval (a::_::comm_ring_1) q"
   by (simp only: poly_eval_def poly_subst_minus lookup_minus)
 
 lemma poly_eval_one [simp]: "poly_eval a 1 = 1"
   by (simp add: poly_eval_def lookup_one)
 
 lemma poly_eval_times: "poly_eval a (p * q) = poly_eval a p * poly_eval a q"
   by (simp only: poly_eval_def poly_subst_times lookup_times_zero)
 
 lemma poly_eval_power: "poly_eval a (p ^ m) = poly_eval a p ^ m"
   by (induct m) (simp_all add: poly_eval_times)
 
 lemma poly_eval_sum: "poly_eval a (sum f I) = (\<Sum>i\<in>I. poly_eval a (f i))"
   by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_plus)
 
 lemma poly_eval_prod: "poly_eval a (prod f I) = (\<Prod>i\<in>I. poly_eval a (f i))"
   by (induct I rule: infinite_finite_induct) (simp_all add: poly_eval_times)
 
 lemma poly_eval_cong: "p = q \<Longrightarrow> (\<And>x. x \<in> indets q \<Longrightarrow> a x = b x) \<Longrightarrow> poly_eval a p = poly_eval b q"
   by (simp add: poly_eval_def cong: poly_subst_cong)
 
 lemma indets_poly_eval_subset:
   "indets (poly_eval a p) \<subseteq> \<Union> (indets ` a ` indets p) \<union> \<Union> (indets ` lookup p ` keys p)"
 proof (induct p rule: poly_mapping_plus_induct)
   case 1
   show ?case by simp
 next
   case (2 p c t)
   have "keys (monomial c t + p) = keys (monomial c t) \<union> keys p"
     by (rule keys_plus_eqI) (simp add: 2(2))
   with 2(1) have eq1: "keys (monomial c t + p) = insert t (keys p)" by simp
   hence eq2: "indets (monomial c t + p) = keys t \<union> indets p" by (simp add: indets_def)
   from 2(2) have eq3: "lookup (monomial c t + p) t = c" by (simp add: lookup_add in_keys_iff)
   have eq4: "lookup (monomial c t + p) s = lookup p s" if "s \<in> keys p" for s
     using that 2(2) by (auto simp: lookup_add lookup_single when_def)
   have "indets (poly_eval a (monomial c t + p)) =
           indets (c * (\<Prod>x\<in>keys t. a x ^ lookup t x) + poly_eval a p)"
     by (simp only: poly_eval_plus poly_eval_monomial)
   also have "\<dots> \<subseteq> indets (c * (\<Prod>x\<in>keys t. a x ^ lookup t x)) \<union> indets (poly_eval a p)"
     by (fact indets_plus_subset)
   also have "\<dots> \<subseteq> indets c \<union> (\<Union> (indets ` a ` keys t)) \<union>
                     (\<Union> (indets ` a ` indets p) \<union> \<Union> (indets ` lookup p ` keys p))"
   proof (intro Un_mono 2(3))
     have "indets (c * (\<Prod>x\<in>keys t. a x ^ lookup t x)) \<subseteq> indets c \<union> indets (\<Prod>x\<in>keys t. a x ^ lookup t x)"
       by (fact indets_times_subset)
     also have "indets (\<Prod>x\<in>keys t. a x ^ lookup t x) \<subseteq> (\<Union>x\<in>keys t. indets (a x ^ lookup t x))"
       by (fact indets_prod_subset)
     also have "\<dots> \<subseteq> (\<Union>x\<in>keys t. indets (a x))" by (intro UN_mono subset_refl indets_power_subset)
     also have "\<dots> = \<Union> (indets ` a ` keys t)" by simp
     finally show "indets (c * (\<Prod>x\<in>keys t. a x ^ lookup t x)) \<subseteq> indets c \<union> \<Union> (indets ` a ` keys t)"
       by blast
   qed
   also have "\<dots> = \<Union> (indets ` a ` indets (monomial c t + p)) \<union>
                     \<Union> (indets ` lookup (monomial c t + p) ` keys (monomial c t + p))"
     by (simp add: eq1 eq2 eq3 eq4 Un_commute Un_assoc Un_left_commute)
   finally show ?case .
 qed
 
 lemma image_poly_eval_ideal: "poly_eval a ` ideal F = ideal (poly_eval a ` F)"
 proof (intro image_ideal_eq_surj poly_eval_plus poly_eval_times surjI)
   fix x
   show "poly_eval a (monomial x 0) = x" by (simp add: poly_eval_monomial)
 qed
 
 subsection \<open>Replacing Indeterminates\<close>
 
 definition map_indets where "map_indets f = poly_subst (\<lambda>x. monomial 1 (Poly_Mapping.single (f x) 1))"
 
 lemma
   shows map_indets_zero [simp]: "map_indets f 0 = 0"
     and map_indets_one [simp]: "map_indets f 1 = 1"
     and map_indets_uminus [simp]: "map_indets f (- r) = - map_indets f (r::_ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
     and map_indets_plus: "map_indets f (p + q) = map_indets f p + map_indets f q"
     and map_indets_minus: "map_indets f (r - s) = map_indets f r - map_indets f s"
     and map_indets_times: "map_indets f (p * q) = map_indets f p * map_indets f q"
     and map_indets_power [simp]: "map_indets f (p ^ m) = map_indets f p ^ m"
     and map_indets_sum: "map_indets f (sum g A) = (\<Sum>a\<in>A. map_indets f (g a))"
     and map_indets_prod: "map_indets f (prod g A) = (\<Prod>a\<in>A. map_indets f (g a))"
   by (simp_all add: map_indets_def poly_subst_uminus poly_subst_plus poly_subst_minus poly_subst_times
       poly_subst_power poly_subst_sum poly_subst_prod)
 
 lemma map_indets_monomial:
   "map_indets f (monomial c t) = monomial c (\<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x))"
   by (simp add: map_indets_def poly_subst_monomial subst_pp_def monomial_power_map_scale
       punit.monom_mult_monomial flip: punit.monomial_prod_sum)
 
 lemma map_indets_id: "(\<And>x. x \<in> indets p \<Longrightarrow> f x = x) \<Longrightarrow> map_indets f p = p"
   by (simp add: map_indets_def poly_subst_id)
 
 lemma map_indets_map_indets: "map_indets f (map_indets g p) = map_indets (f \<circ> g) p"
   by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single)
 
 lemma map_indets_cong: "p = q \<Longrightarrow> (\<And>x. x \<in> indets q \<Longrightarrow> f x = g x) \<Longrightarrow> map_indets f p = map_indets g q"
   unfolding map_indets_def by (simp cong: poly_subst_cong)
 
 lemma poly_subst_map_indets: "poly_subst f (map_indets g p) = poly_subst (f \<circ> g) p"
   by (simp add: map_indets_def poly_subst_poly_subst poly_subst_monomial subst_pp_single comp_def)
 
 lemma poly_eval_map_indets: "poly_eval a (map_indets g p) = poly_eval (a \<circ> g) p"
   by (simp add: poly_eval_def poly_subst_map_indets comp_def)
       (simp add: poly_subst_def lookup_sum lookup_times_zero subst_pp_def lookup_prod_zero
           lookup_power_zero flip: times_monomial_left)
 
 lemma map_indets_inverseE_Polys:
   assumes "inj_on f X" and "p \<in> P[X]"
   shows "map_indets (the_inv_into X f) (map_indets f p) = p"
   unfolding map_indets_map_indets
 proof (rule map_indets_id)
   fix x
   assume "x \<in> indets p"
   also from assms(2) have "\<dots> \<subseteq> X" by (rule PolysD)
   finally show "(the_inv_into X f \<circ> f) x = x" using assms(1) by (auto intro: the_inv_into_f_f)
 qed
 
 lemma map_indets_inverseE:
   assumes "inj f"
   obtains g where "g = the_inv f" and "g \<circ> f = id" and "map_indets g \<circ> map_indets f = id"
 proof -
   define g where "g = the_inv f"
   moreover from assms have eq: "g \<circ> f = id" by (auto intro!: ext the_inv_f_f simp: g_def)
   moreover have "map_indets g \<circ> map_indets f = id"
     by (rule ext) (simp add: map_indets_map_indets eq map_indets_id)
   ultimately show ?thesis ..
 qed
 
 lemma indets_map_indets_subset: "indets (map_indets f (p::_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1)) \<subseteq> f ` indets p"
 proof
   fix x
   assume "x \<in> indets (map_indets f p)"
   then obtain y where "y \<in> indets p" and "x \<in> indets (monomial (1::'a) (Poly_Mapping.single (f y) 1))"
     unfolding map_indets_def by (rule in_indets_poly_substE)
   from this(2) have x: "x = f y" by (simp add: indets_monomial)
   from \<open>y \<in> indets p\<close> show "x \<in> f ` indets p" unfolding x by (rule imageI)
 qed
 
 corollary map_indets_in_Polys: "map_indets f p \<in> P[f ` indets p]"
   using indets_map_indets_subset by (rule PolysI_alt)
 
 lemma indets_map_indets:
   assumes "inj_on f (indets p)"
   shows "indets (map_indets f p) = f ` indets p"
   using indets_map_indets_subset
 proof (rule subset_antisym)
   let ?g = "the_inv_into (indets p) f"
   have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
     by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
   also have "indets \<dots> \<subseteq> ?g ` indets (map_indets f p)" by (fact indets_map_indets_subset)
   finally have "f ` indets p \<subseteq> f ` ?g ` indets (map_indets f p)" by (rule image_mono)
   also have "\<dots> = (\<lambda>x. x) ` indets (map_indets f p)" unfolding image_image using refl
   proof (rule image_cong)
     fix x
     assume "x \<in> indets (map_indets f p)"
     with indets_map_indets_subset have "x \<in> f ` indets p" ..
     with assms show "f (?g x) = x" by (rule f_the_inv_into_f)
   qed
   finally show "f ` indets p \<subseteq> indets (map_indets f p)" by simp
 qed
 
 lemma image_map_indets_Polys: "map_indets f ` P[X] = (P[f ` X]::(_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1) set)"
 proof (intro set_eqI iffI)
   fix p :: "_ \<Rightarrow>\<^sub>0 'a"
   assume "p \<in> map_indets f ` P[X]"
   then obtain q where "q \<in> P[X]" and "p = map_indets f q" ..
   note this(2)
   also have "map_indets f q \<in> P[f ` indets q]" by (fact map_indets_in_Polys)
   also from \<open>q \<in> _\<close> have "\<dots> \<subseteq> P[f ` X]" by (auto intro!: Polys_mono imageI dest: PolysD)
   finally show "p \<in> P[f ` X]" .
 next
   fix p :: "_ \<Rightarrow>\<^sub>0 'a"
   assume "p \<in> P[f ` X]"
   define g where "g = (\<lambda>y. SOME x. x \<in> X \<and> f x = y)"
   have "g y \<in> X \<and> f (g y) = y" if "y \<in> indets p" for y
   proof -
     note that
     also from \<open>p \<in> _\<close> have "indets p \<subseteq> f ` X" by (rule PolysD)
     finally obtain x where "x \<in> X" and "y = f x" ..
     hence "x \<in> X \<and> f x = y" by simp
     thus ?thesis unfolding g_def by (rule someI)
   qed
   hence 1: "g y \<in> X" and 2: "f (g y) = y" if "y \<in> indets p" for y using that by simp_all
   show "p \<in> map_indets f ` P[X]"
   proof
     show "p = map_indets f (map_indets g p)"
       by (rule sym) (simp add: map_indets_map_indets map_indets_id 2)
   next
     have "map_indets g p \<in> P[g ` indets p]" by (fact map_indets_in_Polys)
     also have "\<dots> \<subseteq> P[X]" by (auto intro!: Polys_mono 1)
     finally show "map_indets g p \<in> P[X]" .
   qed
 qed
 
 corollary range_map_indets: "range (map_indets f) = P[range f]"
 proof -
   have "range (map_indets f) = map_indets f ` P[UNIV]" by simp
   also have "\<dots> = P[range f]" by (simp only: image_map_indets_Polys)
   finally show ?thesis .
 qed
 
 lemma in_keys_map_indetsE:
   assumes "t \<in> keys (map_indets f (p::_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1))"
   obtains s where "s \<in> keys p" and "t = (\<Sum>x\<in>keys s. Poly_Mapping.single (f x) (lookup s x))"
 proof -
   let ?f = "(\<lambda>x. monomial (1::'a) (Poly_Mapping.single (f x) 1))"
   from assms obtain s where "s \<in> keys p" and "t \<in> keys (subst_pp ?f s)" unfolding map_indets_def
     by (rule in_keys_poly_substE)
   note this(2)
   also have "\<dots> \<subseteq> {\<Sum>x\<in>keys s. Poly_Mapping.single (f x) (lookup s x)}"
     by (simp add: subst_pp_def monomial_power_map_scale flip: punit.monomial_prod_sum)
   finally have "t = (\<Sum>x\<in>keys s. Poly_Mapping.single (f x) (lookup s x))" by simp
   with \<open>s \<in> keys p\<close> show ?thesis ..
 qed
 
 lemma keys_map_indets_subset:
   "keys (map_indets f p) \<subseteq> (\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
   by (auto elim: in_keys_map_indetsE)
 
 lemma keys_map_indets:
   assumes "inj_on f (indets p)"
   shows "keys (map_indets f p) = (\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p"
   using keys_map_indets_subset
 proof (rule subset_antisym)
   let ?g = "the_inv_into (indets p) f"
   have "p = map_indets ?g (map_indets f p)" unfolding map_indets_map_indets
     by (rule sym, rule map_indets_id) (simp add: assms the_inv_into_f_f)
   also have "keys \<dots> \<subseteq> (\<lambda>t. \<Sum>x\<in>keys t. monomial (lookup t x) (?g x)) ` keys (map_indets f p)"
     by (rule keys_map_indets_subset)
   finally have "(\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p \<subseteq>
                 (\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x)) `
                 (\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
     by (rule image_mono)
   also from refl have "\<dots> = (\<lambda>t. \<Sum>x. Poly_Mapping.single (f x) (lookup t x)) `
                        (\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (?g x) (lookup t x)) ` keys (map_indets f p)"
     by (rule image_cong)
         (smt Sum_any.conditionalize Sum_any.cong finite_keys not_in_keys_iff_lookup_eq_zero single_zero)
   also have "\<dots> = (\<lambda>t. t) ` keys (map_indets f p)" unfolding image_image using refl
   proof (rule image_cong)
     fix t
     assume "t \<in> keys (map_indets f p)"
     have "(\<Sum>x. monomial (lookup (\<Sum>y\<in>keys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) =
           (\<Sum>x. \<Sum>y\<in>keys t. monomial (lookup t y when ?g y = x) (f x))"
       by (simp add: lookup_sum lookup_single monomial_sum)
     also have "\<dots> = (\<Sum>x\<in>indets p. \<Sum>y\<in>keys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
     proof (intro Sum_any.expand_superset finite_indets subsetI)
       fix x
       assume "x \<in> {a. (\<Sum>y\<in>keys t. Poly_Mapping.single (f a) (lookup t y when ?g y = a)) \<noteq> 0}"
       hence "(\<Sum>y\<in>keys t. Poly_Mapping.single (f x) (lookup t y when ?g y = x)) \<noteq> 0" by simp
       then obtain y where "y \<in> keys t" and *: "Poly_Mapping.single (f x) (lookup t y when ?g y = x) \<noteq> 0"
         by (rule sum.not_neutral_contains_not_neutral)
       from this(1) have "y \<in> indets (map_indets f p)" using \<open>t \<in> _\<close> by (rule in_indetsI)
       with indets_map_indets_subset have "y \<in> f ` indets p" ..
       from * have "x = ?g y" by (simp add: when_def split: if_split_asm)
       also from assms \<open>y \<in> f ` indets p\<close> subset_refl have "\<dots> \<in> indets p" by (rule the_inv_into_into)
       finally show "x \<in> indets p" .
     qed
     also have "\<dots> = (\<Sum>y\<in>keys t. \<Sum>x\<in>indets p. Poly_Mapping.single (f x) (lookup t y when ?g y = x))"
       by (fact sum.swap)
     also from refl have "\<dots> = (\<Sum>y\<in>keys t. Poly_Mapping.single y (lookup t y))"
     proof (rule sum.cong)
       fix x
       assume "x \<in> keys t"
       hence "x \<in> indets (map_indets f p)" using \<open>t \<in> _\<close> by (rule in_indetsI)
       with indets_map_indets_subset have "x \<in> f ` indets p" ..
       with assms have "?g x \<in> indets p" using subset_refl by (rule the_inv_into_into)
       hence "{?g x} \<subseteq> indets p" by simp
       with finite_indets have "(\<Sum>y\<in>indets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
                                 (\<Sum>y\<in>{?g x}. Poly_Mapping.single (f y) (lookup t x when ?g x = y))"
         by (rule sum.mono_neutral_right) (simp add: monomial_0_iff when_def)
       also from assms \<open>x \<in> f ` indets p\<close> have "\<dots> = Poly_Mapping.single x (lookup t x)"
         by (simp add: f_the_inv_into_f)
       finally show "(\<Sum>y\<in>indets p. Poly_Mapping.single (f y) (lookup t x when ?g x = y)) =
                       Poly_Mapping.single x (lookup t x)" .
     qed
     also have "\<dots> = t" by (fact poly_mapping_sum_monomials)
     finally show "(\<Sum>x. monomial (lookup (\<Sum>y\<in>keys t. Poly_Mapping.single (?g y) (lookup t y)) x) (f x)) = t" .
   qed
   also have "\<dots> = keys (map_indets f p)" by simp
   finally show "(\<lambda>t. \<Sum>x\<in>keys t. Poly_Mapping.single (f x) (lookup t x)) ` keys p \<subseteq> keys (map_indets f p)" .
 qed
 
 lemma poly_deg_map_indets_le: "poly_deg (map_indets f p) \<le> poly_deg p"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (map_indets f p)"
   then obtain s where "s \<in> keys p" and t: "t = (\<Sum>x\<in>keys s. Poly_Mapping.single (f x) (lookup s x))"
     by (rule in_keys_map_indetsE)
   from this(1) have "deg_pm s \<le> poly_deg p" by (rule poly_deg_max_keys)
   thus "deg_pm t \<le> poly_deg p"
     by (simp add: t deg_pm_sum deg_pm_single deg_pm_superset[OF subset_refl])
 qed
 
 lemma poly_deg_map_indets:
   assumes "inj_on f (indets p)"
   shows "poly_deg (map_indets f p) = poly_deg p"
 proof -
   from assms have "deg_pm ` keys (map_indets f p) = deg_pm ` keys p"
     by (simp add: keys_map_indets image_image deg_pm_sum deg_pm_single
           flip: deg_pm_superset[OF subset_refl])
   thus ?thesis by (auto simp: poly_deg_def)
 qed
 
 lemma map_indets_inj_on_PolysI:
   assumes "inj_on (f::'x \<Rightarrow> 'y) X"
   shows "inj_on ((map_indets f)::_ \<Rightarrow> _ \<Rightarrow>\<^sub>0 'a::comm_semiring_1) P[X]"
 proof (rule inj_onI)
   fix p q :: "_ \<Rightarrow>\<^sub>0 'a"
   assume "p \<in> P[X]"
   with assms have 1: "map_indets (the_inv_into X f) (map_indets f p) = p" (is "map_indets ?g _ = _")
     by (rule map_indets_inverseE_Polys)
   assume "q \<in> P[X]"
   with assms have "map_indets ?g (map_indets f q) = q" by (rule map_indets_inverseE_Polys)
   moreover assume "map_indets f p = map_indets f q"
   ultimately show "p = q" using 1 by (simp add: map_indets_map_indets)
 qed
 
 lemma map_indets_injI:
   assumes "inj f"
   shows "inj (map_indets f)"
 proof -
   from assms have "inj_on (map_indets f) P[UNIV]" by (rule map_indets_inj_on_PolysI)
   thus ?thesis by simp
 qed
 
 lemma image_map_indets_ideal:
   assumes "inj f"
   shows "map_indets f ` ideal F = ideal (map_indets f ` (F::(_ \<Rightarrow>\<^sub>0 'a::comm_ring_1) set)) \<inter> P[range f]"
 proof
   from map_indets_plus map_indets_times have "map_indets f ` ideal F \<subseteq> ideal (map_indets f ` F)"
     by (rule image_ideal_subset)
   moreover from subset_UNIV have "map_indets f ` ideal F \<subseteq> range (map_indets f)" by (rule image_mono)
   ultimately show "map_indets f ` ideal F \<subseteq> ideal (map_indets f ` F) \<inter> P[range f]"
     unfolding range_map_indets by blast
 next
   show "ideal (map_indets f ` F) \<inter> P[range f] \<subseteq> map_indets f ` ideal F"
   proof
     fix p
     assume "p \<in> ideal (map_indets f ` F) \<inter> P[range f]"
     hence "p \<in> ideal (map_indets f ` F)" and "p \<in> range (map_indets f)"
       by (simp_all add: range_map_indets)
     from this(1) obtain F0 q where "F0 \<subseteq> map_indets f ` F" and p: "p = (\<Sum>f'\<in>F0. q f' * f')"
       by (rule ideal.spanE)
     from this(1) obtain F' where "F' \<subseteq> F" and F0: "F0 = map_indets f ` F'" by (rule subset_imageE)
     from assms obtain g where "map_indets g \<circ> map_indets f = (id::_ \<Rightarrow> _ \<Rightarrow>\<^sub>0 'a)"
       by (rule map_indets_inverseE)
     hence eq: "map_indets g (map_indets f p') = p'" for p'::"_ \<Rightarrow>\<^sub>0 'a"
       by (simp add: pointfree_idE)
     from assms have "inj (map_indets f)" by (rule map_indets_injI)
     from this subset_UNIV have "inj_on (map_indets f) F'" by (rule inj_on_subset)
     from \<open>p \<in> range _\<close> obtain p' where "p = map_indets f p'" ..
     hence "p = map_indets f (map_indets g p)" by (simp add: eq)
     also from \<open>inj_on _ F'\<close> have "\<dots> = map_indets f (\<Sum>f'\<in>F'. map_indets g (q (map_indets f f')) * f')"
       by (simp add: p F0 sum.reindex map_indets_sum map_indets_times eq)
     finally have "p = map_indets f (\<Sum>f'\<in>F'. map_indets g (q (map_indets f f')) * f')" .
     moreover have "(\<Sum>f'\<in>F'. map_indets g (q (map_indets f f')) * f') \<in> ideal F"
     proof
       show "(\<Sum>f'\<in>F'. map_indets g (q (map_indets f f')) * f') \<in> ideal F'" by (rule ideal.sum_in_spanI)
     next
       from \<open>F' \<subseteq> F\<close> show "ideal F' \<subseteq> ideal F" by (rule ideal.span_mono)
     qed
     ultimately show "p \<in> map_indets f ` ideal F" by (rule image_eqI)
   qed
 qed
 
 subsection \<open>Homogeneity\<close>
 
 definition homogeneous :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) \<Rightarrow> bool"
   where "homogeneous p \<longleftrightarrow> (\<forall>s\<in>keys p. \<forall>t\<in>keys p. deg_pm s = deg_pm t)"
 
 definition hom_component :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> nat \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero)"
   where "hom_component p n = except p {t. deg_pm t \<noteq> n}"
 
 definition hom_components :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) set"
   where "hom_components p = hom_component p ` deg_pm ` keys p"
 
 definition homogeneous_set :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero) set \<Rightarrow> bool"
   where "homogeneous_set A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>n. hom_component a n \<in> A)"
 
 lemma homogeneousI: "(\<And>s t. s \<in> keys p \<Longrightarrow> t \<in> keys p \<Longrightarrow> deg_pm s = deg_pm t) \<Longrightarrow> homogeneous p"
   unfolding homogeneous_def by blast
 
 lemma homogeneousD: "homogeneous p \<Longrightarrow> s \<in> keys p \<Longrightarrow> t \<in> keys p \<Longrightarrow> deg_pm s = deg_pm t"
   unfolding homogeneous_def by blast
 
 lemma homogeneousD_poly_deg:
   assumes "homogeneous p" and "t \<in> keys p"
   shows "deg_pm t = poly_deg p"
 proof (rule antisym)
   from assms(2) show "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
 next
   show "poly_deg p \<le> deg_pm t"
   proof (rule poly_deg_leI)
     fix s
     assume "s \<in> keys p"
     with assms(1) have "deg_pm s = deg_pm t" using assms(2) by (rule homogeneousD)
     thus "deg_pm s \<le> deg_pm t" by simp
   qed
 qed
 
 lemma homogeneous_monomial [simp]: "homogeneous (monomial c t)"
   by (auto split: if_split_asm intro: homogeneousI)
 
 corollary homogeneous_zero [simp]: "homogeneous 0" and homogeneous_one [simp]: "homogeneous 1"
   by (simp_all only: homogeneous_monomial flip: single_zero[of 0] single_one)
 
 lemma homogeneous_uminus_iff [simp]: "homogeneous (- p) \<longleftrightarrow> homogeneous p"
   by (auto intro!: homogeneousI dest: homogeneousD simp: keys_uminus)
 
 lemma homogeneous_monom_mult: "homogeneous p \<Longrightarrow> homogeneous (punit.monom_mult c t p)"
   by (auto intro!: homogeneousI elim!: punit.keys_monom_multE simp: deg_pm_plus dest: homogeneousD)
 
 lemma homogeneous_monom_mult_rev:
   assumes "c \<noteq> (0::'a::semiring_no_zero_divisors)" and "homogeneous (punit.monom_mult c t p)"
   shows "homogeneous p"
 proof (rule homogeneousI)
   fix s s'
   assume "s \<in> keys p"
   hence 1: "t + s \<in> keys (punit.monom_mult c t p)"
     using assms(1) by (rule punit.keys_monom_multI[simplified])
   assume "s' \<in> keys p"
   hence "t + s' \<in> keys (punit.monom_mult c t p)"
     using assms(1) by (rule punit.keys_monom_multI[simplified])
   with assms(2) 1 have "deg_pm (t + s) = deg_pm (t + s')" by (rule homogeneousD)
   thus "deg_pm s = deg_pm s'" by (simp add: deg_pm_plus)
 qed
 
 lemma homogeneous_times:
   assumes "homogeneous p" and "homogeneous q"
   shows "homogeneous (p * q)"
 proof (rule homogeneousI)
   fix s t
   assume "s \<in> keys (p * q)"
   then obtain sp sq where sp: "sp \<in> keys p" and sq: "sq \<in> keys q" and s: "s = sp + sq"
     by (rule in_keys_timesE)
   assume "t \<in> keys (p * q)"
   then obtain tp tq where tp: "tp \<in> keys p" and tq: "tq \<in> keys q" and t: "t = tp + tq"
     by (rule in_keys_timesE)
   from assms(1) sp tp have "deg_pm sp = deg_pm tp" by (rule homogeneousD)
   moreover from assms(2) sq tq have "deg_pm sq = deg_pm tq" by (rule homogeneousD)
   ultimately show "deg_pm s = deg_pm t" by (simp only: s t deg_pm_plus)
 qed
 
 lemma lookup_hom_component: "lookup (hom_component p n) = (\<lambda>t. lookup p t when deg_pm t = n)"
   by (rule ext) (simp add: hom_component_def lookup_except)
 
 lemma keys_hom_component: "keys (hom_component p n) = {t. t \<in> keys p \<and> deg_pm t = n}"
   by (auto simp: hom_component_def keys_except)
 
 lemma keys_hom_componentD:
   assumes "t \<in> keys (hom_component p n)"
   shows "t \<in> keys p" and "deg_pm t = n"
   using assms by (simp_all add: keys_hom_component)
 
 lemma homogeneous_hom_component: "homogeneous (hom_component p n)"
   by (auto dest: keys_hom_componentD intro: homogeneousI)
 
 lemma hom_component_zero [simp]: "hom_component 0 = 0"
   by (rule ext) (simp add: hom_component_def)
 
 lemma hom_component_zero_iff: "hom_component p n = 0 \<longleftrightarrow> (\<forall>t\<in>keys p. deg_pm t \<noteq> n)"
   by (metis (mono_tags, lifting) empty_iff keys_eq_empty_iff keys_hom_component mem_Collect_eq subsetI subset_antisym)
 
 lemma hom_component_uminus [simp]: "hom_component (- p) = - hom_component p"
   by (intro ext poly_mapping_eqI) (simp add: hom_component_def lookup_except)
 
 lemma hom_component_plus: "hom_component (p + q) n = hom_component p n + hom_component q n"
   by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_add)
 
 lemma hom_component_minus: "hom_component (p - q) n = hom_component p n - hom_component q n"
   by (rule poly_mapping_eqI) (simp add: hom_component_def lookup_except lookup_minus)
 
 lemma hom_component_monom_mult:
   "punit.monom_mult c t (hom_component p n) = hom_component (punit.monom_mult c t p) (deg_pm t + n)"
   by (auto simp: hom_component_def lookup_except punit.lookup_monom_mult deg_pm_minus deg_pm_mono intro!: poly_mapping_eqI)
 
 lemma hom_component_inject:
   assumes "t \<in> keys p" and "hom_component p (deg_pm t) = hom_component p n"
   shows "deg_pm t = n"
 proof -
   from assms(1) have "t \<in> keys (hom_component p (deg_pm t))" by (simp add: keys_hom_component)
   hence "0 \<noteq> lookup (hom_component p (deg_pm t)) t" by (simp add: in_keys_iff)
   also have "lookup (hom_component p (deg_pm t)) t = lookup (hom_component p n) t"
     by (simp only: assms(2))
   also have "\<dots> = (lookup p t when deg_pm t = n)" by (simp only: lookup_hom_component)
   finally show ?thesis by simp
 qed
 
 lemma hom_component_of_homogeneous:
   assumes "homogeneous p"
   shows "hom_component p n = (p when n = poly_deg p)"
 proof (cases "n = poly_deg p")
   case True
   have "hom_component p n = p"
   proof (rule poly_mapping_eqI)
     fix t
     show "lookup (hom_component p n) t = lookup p t"
     proof (cases "t \<in> keys p")
       case True
       with assms have "deg_pm t = n" unfolding \<open>n = poly_deg p\<close> by (rule homogeneousD_poly_deg)
       thus ?thesis by (simp add: lookup_hom_component)
     next
       case False
       moreover from this have "t \<notin> keys (hom_component p n)" by (simp add: keys_hom_component)
       ultimately show ?thesis by (simp add: in_keys_iff)
     qed
   qed
   with True show ?thesis by simp
 next
   case False
   have "hom_component p n = 0" unfolding hom_component_zero_iff
   proof (intro ballI notI)
     fix t
     assume "t \<in> keys p"
     with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
     moreover assume "deg_pm t = n"
     ultimately show False using False by simp
   qed
   with False show ?thesis by simp
 qed
 
 lemma hom_components_zero [simp]: "hom_components 0 = {}"
   by (simp add: hom_components_def)
 
 lemma hom_components_zero_iff [simp]: "hom_components p = {} \<longleftrightarrow> p = 0"
   by (simp add: hom_components_def)
 
 lemma hom_components_uminus: "hom_components (- p) = uminus ` hom_components p"
   by (simp add: hom_components_def keys_uminus image_image)
 
 lemma hom_components_monom_mult:
   "hom_components (punit.monom_mult c t p) = (if c = 0 then {} else punit.monom_mult c t ` hom_components p)"
   for c::"'a::semiring_no_zero_divisors"
   by (simp add: hom_components_def punit.keys_monom_mult image_image deg_pm_plus hom_component_monom_mult)
 
 lemma hom_componentsI: "q = hom_component p (deg_pm t) \<Longrightarrow> t \<in> keys p \<Longrightarrow> q \<in> hom_components p"
   unfolding hom_components_def by blast
 
 lemma hom_componentsE:
   assumes "q \<in> hom_components p"
   obtains t where "t \<in> keys p" and "q = hom_component p (deg_pm t)"
   using assms unfolding hom_components_def by blast
 
 lemma hom_components_of_homogeneous:
   assumes "homogeneous p"
   shows "hom_components p = (if p = 0 then {} else {p})"
 proof (split if_split, intro conjI impI)
   assume "p \<noteq> 0"
   have "deg_pm ` keys p = {poly_deg p}"
   proof (rule set_eqI)
     fix n
     have "n \<in> deg_pm ` keys p \<longleftrightarrow> n = poly_deg p"
     proof
       assume "n \<in> deg_pm ` keys p"
       then obtain t where "t \<in> keys p" and "n = deg_pm t" ..
       from assms this(1) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
       thus "n = poly_deg p" by (simp only: \<open>n = deg_pm t\<close>)
     next
       assume "n = poly_deg p"
       from \<open>p \<noteq> 0\<close> have "keys p \<noteq> {}" by simp
       then obtain t where "t \<in> keys p" by blast
       with assms have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
       hence "n = deg_pm t" by (simp only: \<open>n = poly_deg p\<close>)
       with \<open>t \<in> keys p\<close> show "n \<in> deg_pm ` keys p" by (rule rev_image_eqI)
     qed
     thus "n \<in> deg_pm ` keys p \<longleftrightarrow> n \<in> {poly_deg p}" by simp
   qed
   with assms show "hom_components p = {p}"
     by (simp add: hom_components_def hom_component_of_homogeneous)
 qed simp
 
 lemma finite_hom_components: "finite (hom_components p)"
   unfolding hom_components_def using finite_keys by (intro finite_imageI)
 
 lemma hom_components_homogeneous: "q \<in> hom_components p \<Longrightarrow> homogeneous q"
   by (elim hom_componentsE) (simp only: homogeneous_hom_component)
 
 lemma hom_components_nonzero: "q \<in> hom_components p \<Longrightarrow> q \<noteq> 0"
   by (auto elim!: hom_componentsE simp: hom_component_zero_iff)
 
 lemma deg_pm_hom_components:
   assumes "q1 \<in> hom_components p" and "q2 \<in> hom_components p" and "t1 \<in> keys q1" and "t2 \<in> keys q2"
   shows "deg_pm t1 = deg_pm t2 \<longleftrightarrow> q1 = q2"
 proof -
   from assms(1) obtain s1 where "s1 \<in> keys p" and q1: "q1 = hom_component p (deg_pm s1)"
     by (rule hom_componentsE)
   from assms(3) have t1: "deg_pm t1 = deg_pm s1" unfolding q1 by (rule keys_hom_componentD)
   from assms(2) obtain s2 where "s2 \<in> keys p" and q2: "q2 = hom_component p (deg_pm s2)"
     by (rule hom_componentsE)
   from assms(4) have t2: "deg_pm t2 = deg_pm s2" unfolding q2 by (rule keys_hom_componentD)
   from \<open>s1 \<in> keys p\<close> show ?thesis by (auto simp: q1 q2 t1 t2 dest: hom_component_inject)
 qed
 
 lemma poly_deg_hom_components:
   assumes "q1 \<in> hom_components p" and "q2 \<in> hom_components p"
   shows "poly_deg q1 = poly_deg q2 \<longleftrightarrow> q1 = q2"
 proof -
   from assms(1) have "homogeneous q1" and "q1 \<noteq> 0"
     by (rule hom_components_homogeneous, rule hom_components_nonzero)
   from this(2) have "keys q1 \<noteq> {}" by simp
   then obtain t1 where "t1 \<in> keys q1" by blast
   with \<open>homogeneous q1\<close> have t1: "deg_pm t1 = poly_deg q1" by (rule homogeneousD_poly_deg)
   from assms(2) have "homogeneous q2" and "q2 \<noteq> 0"
     by (rule hom_components_homogeneous, rule hom_components_nonzero)
   from this(2) have "keys q2 \<noteq> {}" by simp
   then obtain t2 where "t2 \<in> keys q2" by blast
   with \<open>homogeneous q2\<close> have t2: "deg_pm t2 = poly_deg q2" by (rule homogeneousD_poly_deg)
   from assms \<open>t1 \<in> keys q1\<close> \<open>t2 \<in> keys q2\<close> have "deg_pm t1 = deg_pm t2 \<longleftrightarrow> q1 = q2"
     by (rule deg_pm_hom_components)
   thus ?thesis by (simp only: t1 t2)
 qed
 
 lemma hom_components_keys_disjoint:
   assumes "q1 \<in> hom_components p" and "q2 \<in> hom_components p" and "q1 \<noteq> q2"
   shows "keys q1 \<inter> keys q2 = {}"
 proof (rule ccontr)
   assume "keys q1 \<inter> keys q2 \<noteq> {}"
   then obtain t where "t \<in> keys q1" and "t \<in> keys q2" by blast
   with assms(1, 2) have "deg_pm t = deg_pm t \<longleftrightarrow> q1 = q2" by (rule deg_pm_hom_components)
   with assms(3) show False by simp
 qed
 
 lemma Keys_hom_components: "Keys (hom_components p) = keys p"
   by (auto simp: Keys_def hom_components_def keys_hom_component)
 
 lemma lookup_hom_components: "q \<in> hom_components p \<Longrightarrow> t \<in> keys q \<Longrightarrow> lookup q t = lookup p t"
   by (auto elim!: hom_componentsE simp: keys_hom_component lookup_hom_component)
 
 lemma poly_deg_hom_components_le:
   assumes "q \<in> hom_components p"
   shows "poly_deg q \<le> poly_deg p"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys q"
   also from assms have "\<dots> \<subseteq> Keys (hom_components p)" by (rule keys_subset_Keys)
   also have "\<dots> = keys p" by (fact Keys_hom_components)
   finally show "deg_pm t \<le> poly_deg p" by (rule poly_deg_max_keys)
 qed
 
 lemma sum_hom_components: "\<Sum>(hom_components p) = p"
 proof (rule poly_mapping_eqI)
   fix t
   show "lookup (\<Sum>(hom_components p)) t = lookup p t" unfolding lookup_sum
   proof (cases "t \<in> keys p")
     case True
     also have "keys p = Keys (hom_components p)" by (simp only: Keys_hom_components)
     finally obtain q where q: "q \<in> hom_components p" and t: "t \<in> keys q" by (rule in_KeysE)
     from this(1) have "(\<Sum>q0\<in>hom_components p. lookup q0 t) =
                         (\<Sum>q0\<in>insert q (hom_components p). lookup q0 t)"
       by (simp only: insert_absorb)
     also from finite_hom_components have "\<dots> = lookup q t + (\<Sum>q0\<in>hom_components p - {q}. lookup q0 t)"
       by (rule sum.insert_remove)
     also from q t have "\<dots> = lookup p t + (\<Sum>q0\<in>hom_components p - {q}. lookup q0 t)"
       by (simp only: lookup_hom_components)
     also have "(\<Sum>q0\<in>hom_components p - {q}. lookup q0 t) = 0"
     proof (intro sum.neutral ballI)
       fix q0
       assume "q0 \<in> hom_components p - {q}"
       hence "q0 \<in> hom_components p" and "q \<noteq> q0" by blast+
       with q have "keys q \<inter> keys q0 = {}" by (rule hom_components_keys_disjoint)
       with t have "t \<notin> keys q0" by blast
       thus "lookup q0 t = 0" by (simp add: in_keys_iff)
     qed
     finally show "(\<Sum>q\<in>hom_components p. lookup q t) = lookup p t" by simp
   next
     case False
     hence "t \<notin> Keys (hom_components p)" by (simp add: Keys_hom_components)
     hence "\<forall>q\<in>hom_components p. lookup q t = 0" by (simp add: Keys_def in_keys_iff)
     hence "(\<Sum>q\<in>hom_components p. lookup q t) = 0" by (rule sum.neutral)
     also from False have "\<dots> = lookup p t" by (simp add: in_keys_iff)
     finally show "(\<Sum>q\<in>hom_components p. lookup q t) = lookup p t" .
   qed
 qed
 
 lemma homogeneous_setI: "(\<And>a n. a \<in> A \<Longrightarrow> hom_component a n \<in> A) \<Longrightarrow> homogeneous_set A"
   by (simp add: homogeneous_set_def)
 
 lemma homogeneous_setD: "homogeneous_set A \<Longrightarrow> a \<in> A \<Longrightarrow> hom_component a n \<in> A"
   by (simp add: homogeneous_set_def)
 
 lemma homogeneous_set_Polys: "homogeneous_set (P[X]::(_ \<Rightarrow>\<^sub>0 'a::zero) set)"
 proof (intro homogeneous_setI PolysI subsetI)
   fix p::"_ \<Rightarrow>\<^sub>0 'a" and n t
   assume "p \<in> P[X]"
   assume "t \<in> keys (hom_component p n)"
   hence "t \<in> keys p" by (rule keys_hom_componentD)
   also from \<open>p \<in> P[X]\<close> have "\<dots> \<subseteq> .[X]" by (rule PolysD)
   finally show "t \<in> .[X]" .
 qed
 
 lemma homogeneous_set_IntI: "homogeneous_set A \<Longrightarrow> homogeneous_set B \<Longrightarrow> homogeneous_set (A \<inter> B)"
   by (simp add: homogeneous_set_def)
 
 lemma homogeneous_setD_hom_components:
   assumes "homogeneous_set A" and "a \<in> A" and "b \<in> hom_components a"
   shows "b \<in> A"
 proof -
   from assms(3) obtain t::"'a \<Rightarrow>\<^sub>0 nat" where "b = hom_component a (deg_pm t)"
     by (rule hom_componentsE)
   also from assms(1, 2) have "\<dots> \<in> A" by (rule homogeneous_setD)
   finally show ?thesis .
 qed
 
 lemma zero_in_homogeneous_set:
   assumes "homogeneous_set A" and "A \<noteq> {}"
   shows "0 \<in> A"
 proof -
   from assms(2) obtain a where "a \<in> A" by blast
   have "lookup a t = 0" if "deg_pm t = Suc (poly_deg a)" for t
   proof (rule ccontr)
     assume "lookup a t \<noteq> 0"
     hence "t \<in> keys a" by (simp add: in_keys_iff)
     hence "deg_pm t \<le> poly_deg a" by (rule poly_deg_max_keys)
     thus False by (simp add: that)
   qed
   hence "0 = hom_component a (Suc (poly_deg a))"
     by (intro poly_mapping_eqI) (simp add: lookup_hom_component when_def)
   also from assms(1) \<open>a \<in> A\<close> have "\<dots> \<in> A" by (rule homogeneous_setD)
   finally show ?thesis .
 qed
 
 lemma homogeneous_ideal:
   assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F"
   shows "hom_component p n \<in> ideal F"
 proof -
   from assms(2) have "p \<in> punit.pmdl F" by simp
   thus ?thesis
   proof (induct p rule: punit.pmdl_induct)
     case module_0
     show ?case by (simp add: ideal.span_zero)
   next
     case (module_plus a f c t)
     let ?f = "punit.monom_mult c t f"
     from module_plus.hyps(3) have "f \<in> punit.pmdl F" by (simp add: ideal.span_base)
     hence *: "?f \<in> punit.pmdl F" by (rule punit.pmdl_closed_monom_mult)
     from module_plus.hyps(3) have "homogeneous f" by (rule assms(1))
     hence "homogeneous ?f" by (rule homogeneous_monom_mult)
     hence "hom_component ?f n = (?f when n = poly_deg ?f)" by (rule hom_component_of_homogeneous)
     also from * have "\<dots> \<in> ideal F" by (simp add: when_def ideal.span_zero)
     finally have "hom_component ?f n \<in> ideal F" .
     with module_plus.hyps(2) show ?case unfolding hom_component_plus by (rule ideal.span_add)
   qed
 qed
 
 corollary homogeneous_set_homogeneous_ideal:
   "(\<And>f. f \<in> F \<Longrightarrow> homogeneous f) \<Longrightarrow> homogeneous_set (ideal F)"
   by (auto intro: homogeneous_setI homogeneous_ideal)
 
 corollary homogeneous_ideal':
   assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F" and "q \<in> hom_components p"
   shows "q \<in> ideal F"
   using _ assms(2, 3)
 proof (rule homogeneous_setD_hom_components)
   from assms(1) show "homogeneous_set (ideal F)" by (rule homogeneous_set_homogeneous_ideal)
 qed
 
 lemma homogeneous_idealE_homogeneous:
   assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F" and "homogeneous p"
   obtains F' q where "finite F'" and "F' \<subseteq> F" and "p = (\<Sum>f\<in>F'. q f * f)" and "\<And>f. homogeneous (q f)"
     and "\<And>f. f \<in> F' \<Longrightarrow> poly_deg (q f * f) = poly_deg p" and "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0"
 proof -
   from assms(2) obtain F'' q' where "finite F''" and "F'' \<subseteq> F" and p: "p = (\<Sum>f\<in>F''. q' f * f)"
     by (rule ideal.spanE)
   let ?A = "\<lambda>f. {h \<in> hom_components (q' f). poly_deg h + poly_deg f = poly_deg p}"
   let ?B = "\<lambda>f. {h \<in> hom_components (q' f). poly_deg h + poly_deg f \<noteq> poly_deg p}"
   define F' where "F' = {f \<in> F''. (\<Sum>(?A f)) * f \<noteq> 0}"
   define q where "q = (\<lambda>f. (\<Sum>(?A f)) when f \<in> F')"
   have "F' \<subseteq> F''" by (simp add: F'_def)
   hence "F' \<subseteq> F" using \<open>F'' \<subseteq> F\<close> by (rule subset_trans)
   have 1: "deg_pm t + poly_deg f = poly_deg p" if "f \<in> F'" and "t \<in> keys (q f)" for f t
   proof -
     from that have "t \<in> keys (\<Sum>(?A f))" by (simp add: q_def)
     also have "\<dots> \<subseteq> (\<Union>h\<in>?A f. keys h)" by (fact keys_sum_subset)
     finally obtain h where "h \<in> ?A f" and "t \<in> keys h" ..
     from this(1) have "h \<in> hom_components (q' f)" and eq: "poly_deg h + poly_deg f = poly_deg p"
       by simp_all
     from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
     hence "deg_pm t = poly_deg h" using \<open>t \<in> keys h\<close> by (rule homogeneousD_poly_deg)
     thus ?thesis by (simp only: eq)
   qed
   have 2: "deg_pm t = poly_deg p" if "f \<in> F'" and "t \<in> keys (q f * f)" for f t
   proof -
     from that(1) \<open>F' \<subseteq> F\<close> have "f \<in> F" ..
     hence "homogeneous f" by (rule assms(1))
     from that(2) obtain s1 s2 where "s1 \<in> keys (q f)" and "s2 \<in> keys f" and t: "t = s1 + s2"
       by (rule in_keys_timesE)
     from that(1) this(1) have "deg_pm s1 + poly_deg f = poly_deg p" by (rule 1)
     moreover from \<open>homogeneous f\<close> \<open>s2 \<in> keys f\<close> have "deg_pm s2 = poly_deg f"
       by (rule homogeneousD_poly_deg)
     ultimately show ?thesis by (simp add: t deg_pm_plus)
   qed
   from \<open>F' \<subseteq> F''\<close> \<open>finite F''\<close> have "finite F'" by (rule finite_subset)
   thus ?thesis using \<open>F' \<subseteq> F\<close>
   proof
     note p
     also from refl have "(\<Sum>f\<in>F''. q' f * f) = (\<Sum>f\<in>F''. (\<Sum>(?A f) * f) + (\<Sum>(?B f) * f))"
     proof (rule sum.cong)
       fix f
       assume "f \<in> F''"
       from sum_hom_components have "q' f = (\<Sum>(hom_components (q' f)))" by (rule sym)
       also have "\<dots> = (\<Sum>(?A f \<union> ?B f))" by (rule arg_cong[where f="sum (\<lambda>x. x)"]) blast
       also have "\<dots> = \<Sum>(?A f) + \<Sum>(?B f)"
       proof (rule sum.union_disjoint)
         have "?A f \<subseteq> hom_components (q' f)" by blast
         thus "finite (?A f)" using finite_hom_components by (rule finite_subset)
       next
         have "?B f \<subseteq> hom_components (q' f)" by blast
         thus "finite (?B f)" using finite_hom_components by (rule finite_subset)
       qed blast
       finally show "q' f * f = (\<Sum>(?A f) * f) + (\<Sum>(?B f) * f)"
         by (metis (no_types, lifting) distrib_right)
     qed
     also have "\<dots> = (\<Sum>f\<in>F''. \<Sum>(?A f) * f) + (\<Sum>f\<in>F''. \<Sum>(?B f) * f)" by (rule sum.distrib)
     also from \<open>finite F''\<close> \<open>F' \<subseteq> F''\<close> have "(\<Sum>f\<in>F''. \<Sum>(?A f) * f) = (\<Sum>f\<in>F'. q f * f)"
     proof (intro sum.mono_neutral_cong_right ballI)
       fix f
       assume "f \<in> F'' - F'"
       thus "\<Sum>(?A f) * f = 0" by (simp add: F'_def)
     next
       fix f
       assume "f \<in> F'"
       thus "\<Sum>(?A f) * f = q f * f" by (simp add: q_def)
     qed
     finally have p[symmetric]: "p = (\<Sum>f\<in>F'. q f * f) + (\<Sum>f\<in>F''. \<Sum>(?B f) * f)" .
     moreover have "keys (\<Sum>f\<in>F''. \<Sum>(?B f) * f) = {}"
     proof (rule, rule)
       fix t
       assume t_in: "t \<in> keys (\<Sum>f\<in>F''. \<Sum>(?B f) * f)"
       also have "\<dots> \<subseteq> (\<Union>f\<in>F''. keys (\<Sum>(?B f) * f))" by (fact keys_sum_subset)
       finally obtain f where "f \<in> F''" and "t \<in> keys (\<Sum>(?B f) * f)" ..
       from this(2) obtain s1 s2 where "s1 \<in> keys (\<Sum>(?B f))" and "s2 \<in> keys f" and t: "t = s1 + s2"
         by (rule in_keys_timesE)
       from \<open>f \<in> F''\<close> \<open>F'' \<subseteq> F\<close> have "f \<in> F" ..
       hence "homogeneous f" by (rule assms(1))
       note \<open>s1 \<in> keys (\<Sum>(?B f))\<close>
       also have "keys (\<Sum>(?B f)) \<subseteq> (\<Union>h\<in>?B f. keys h)" by (fact keys_sum_subset)
       finally obtain h where "h \<in> ?B f" and "s1 \<in> keys h" ..
       from this(1) have "h \<in> hom_components (q' f)" and neq: "poly_deg h + poly_deg f \<noteq> poly_deg p"
         by simp_all
       from this(1) have "homogeneous h" by (rule hom_components_homogeneous)
       hence "deg_pm s1 = poly_deg h" using \<open>s1 \<in> keys h\<close> by (rule homogeneousD_poly_deg)
       moreover from \<open>homogeneous f\<close> \<open>s2 \<in> keys f\<close> have "deg_pm s2 = poly_deg f"
         by (rule homogeneousD_poly_deg)
       ultimately have "deg_pm t \<noteq> poly_deg p" using neq by (simp add: t deg_pm_plus)
       have "t \<notin> keys (\<Sum>f\<in>F'. q f * f)"
       proof
         assume "t \<in> keys (\<Sum>f\<in>F'. q f * f)"
         also have "\<dots> \<subseteq> (\<Union>f\<in>F'. keys (q f * f))" by (fact keys_sum_subset)
         finally obtain f where "f \<in> F'" and "t \<in> keys (q f * f)" ..
         hence "deg_pm t = poly_deg p" by (rule 2)
         with \<open>deg_pm t \<noteq> poly_deg p\<close> show False ..
       qed
       with t_in have "t \<in> keys ((\<Sum>f\<in>F'. q f * f) + (\<Sum>f\<in>F''. \<Sum>(?B f) * f))"
         by (rule in_keys_plusI2)
       hence "t \<in> keys p" by (simp only: p)
       with assms(3) have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
       with \<open>deg_pm t \<noteq> poly_deg p\<close> show "t \<in> {}" ..
     qed (fact empty_subsetI)
     ultimately show "p = (\<Sum>f\<in>F'. q f * f)" by simp
   next
     fix f
     show "homogeneous (q f)"
     proof (cases "f \<in> F'")
       case True
       show ?thesis
       proof (rule homogeneousI)
         fix s t
         assume "s \<in> keys (q f)"
         with True have *: "deg_pm s + poly_deg f = poly_deg p" by (rule 1)
         assume "t \<in> keys (q f)"
         with True have "deg_pm t + poly_deg f = poly_deg p" by (rule 1)
         with * show "deg_pm s = deg_pm t" by simp
       qed
     next
       case False
       thus ?thesis by (simp add: q_def)
     qed
 
     assume "f \<in> F'"
     show "poly_deg (q f * f) = poly_deg p"
     proof (intro antisym)
       show "poly_deg (q f * f) \<le> poly_deg p"
       proof (rule poly_deg_leI)
         fix t
         assume "t \<in> keys (q f * f)"
         with \<open>f \<in> F'\<close> have "deg_pm t = poly_deg p" by (rule 2)
         thus "deg_pm t \<le> poly_deg p" by simp
       qed
     next
       from \<open>f \<in> F'\<close> have "q f * f \<noteq> 0" by (simp add: q_def F'_def)
       hence "keys (q f * f) \<noteq> {}" by simp
       then obtain t where "t \<in> keys (q f * f)" by blast
       with \<open>f \<in> F'\<close> have "deg_pm t = poly_deg p" by (rule 2)
       moreover from \<open>t \<in> keys (q f * f)\<close> have "deg_pm t \<le> poly_deg (q f * f)" by (rule poly_deg_max_keys)
       ultimately show "poly_deg p \<le> poly_deg (q f * f)" by simp
     qed
   qed (simp add: q_def)
 qed
 
 corollary homogeneous_idealE:
   assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F"
   obtains F' q where "finite F'" and "F' \<subseteq> F" and "p = (\<Sum>f\<in>F'. q f * f)"
     and "\<And>f. poly_deg (q f * f) \<le> poly_deg p" and "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0"
 proof (cases "p = 0")
   case True
   show ?thesis
   proof
     show "p = (\<Sum>f\<in>{}. (\<lambda>_. 0) f * f)" by (simp add: True)
   qed simp_all
 next
   case False
   define P where "P = (\<lambda>h qf. finite (fst qf) \<and> fst qf \<subseteq> F \<and> h = (\<Sum>f\<in>fst qf. snd qf f * f) \<and>
                   (\<forall>f\<in>fst qf. poly_deg (snd qf f * f) = poly_deg h) \<and> (\<forall>f. f \<notin> fst qf \<longrightarrow> snd qf f = 0))"
   define q0 where "q0 = (\<lambda>h. SOME qf. P h qf)"
   have 1: "P h (q0 h)" if "h \<in> hom_components p" for h
   proof -
     note assms(1)
     moreover from assms that have "h \<in> ideal F" by (rule homogeneous_ideal')
     moreover from that have "homogeneous h" by (rule hom_components_homogeneous)
     ultimately obtain F' q where "finite F'" and "F' \<subseteq> F" and "h = (\<Sum>f\<in>F'. q f * f)"
       and "\<And>f. f \<in> F' \<Longrightarrow> poly_deg (q f * f) = poly_deg h" and "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0"
       by (rule homogeneous_idealE_homogeneous) blast+
     hence "P h (F', q)" by (simp add: P_def)
     thus ?thesis unfolding q0_def by (rule someI)
   qed
   define F' where "F' = (\<Union>h\<in>hom_components p. fst (q0 h))"
   define q where "q = (\<lambda>f. \<Sum>h\<in>hom_components p. snd (q0 h) f)"
   show ?thesis
   proof
     have "finite F' \<and> F' \<subseteq> F" unfolding F'_def UN_subset_iff finite_UN[OF finite_hom_components]
     proof (intro conjI ballI)
       fix h
       assume "h \<in> hom_components p"
       hence "P h (q0 h)" by (rule 1)
       thus "finite (fst (q0 h))" and "fst (q0 h) \<subseteq> F" by (simp_all only: P_def)
     qed
     thus "finite F'" and "F' \<subseteq> F" by simp_all
 
     from sum_hom_components have "p = (\<Sum>(hom_components p))" by (rule sym)
     also from refl have "\<dots> = (\<Sum>h\<in>hom_components p. \<Sum>f\<in>F'. snd (q0 h) f * f)"
     proof (rule sum.cong)
       fix h
       assume "h \<in> hom_components p"
       hence "P h (q0 h)" by (rule 1)
       hence "h = (\<Sum>f\<in>fst (q0 h). snd (q0 h) f * f)" and 2: "\<And>f. f \<notin> fst (q0 h) \<Longrightarrow> snd (q0 h) f = 0"
         by (simp_all add: P_def)
       note this(1)
       also from \<open>finite F'\<close> have "(\<Sum>f\<in>fst (q0 h). (snd (q0 h)) f * f) = (\<Sum>f\<in>F'. snd (q0 h) f * f)"
       proof (intro sum.mono_neutral_left ballI)
         show "fst (q0 h) \<subseteq> F'" unfolding F'_def using \<open>h \<in> hom_components p\<close> by blast
       next
         fix f
         assume "f \<in> F' - fst (q0 h)"
         hence "f \<notin> fst (q0 h)" by simp
         hence "snd (q0 h) f = 0" by (rule 2)
         thus "snd (q0 h) f * f = 0" by simp
       qed
       finally show "h = (\<Sum>f\<in>F'. snd (q0 h) f * f)" .
     qed
     also have "\<dots> = (\<Sum>f\<in>F'. \<Sum>h\<in>hom_components p. snd (q0 h) f * f)" by (rule sum.swap)
     also have "\<dots> = (\<Sum>f\<in>F'. q f * f)" by (simp only: q_def sum_distrib_right)
     finally show "p = (\<Sum>f\<in>F'. q f * f)" .
 
     fix f
     have "poly_deg (q f * f) = poly_deg (\<Sum>h\<in>hom_components p. snd (q0 h) f * f)"
       by (simp only: q_def sum_distrib_right)
     also have "\<dots> \<le> Max (poly_deg ` (\<lambda>h. snd (q0 h) f * f) ` hom_components p)"
       by (rule poly_deg_sum_le)
     also have "\<dots> = Max ((\<lambda>h. poly_deg (snd (q0 h) f * f)) ` hom_components p)"
       (is "_ = Max (?f ` _)") by (simp only: image_image)
     also have "\<dots> \<le> poly_deg p"
     proof (rule Max.boundedI)
       from finite_hom_components show "finite (?f ` hom_components p)" by (rule finite_imageI)
     next
       from False show "?f ` hom_components p \<noteq> {}" by simp
     next
       fix d
       assume "d \<in> ?f ` hom_components p"
       then obtain h where "h \<in> hom_components p" and d: "d = ?f h" ..
       from this(1) have "P h (q0 h)" by (rule 1)
       hence 2: "\<And>f. f \<in> fst (q0 h) \<Longrightarrow> poly_deg (snd (q0 h) f * f) = poly_deg h"
         and 3: "\<And>f. f \<notin> fst (q0 h) \<Longrightarrow> snd (q0 h) f = 0" by (simp_all add: P_def)
       show "d \<le> poly_deg p"
       proof (cases "f \<in> fst (q0 h)")
         case True
         hence "poly_deg (snd (q0 h) f * f) = poly_deg h" by (rule 2)
         hence "d = poly_deg h" by (simp only: d)
         also from \<open>h \<in> hom_components p\<close> have "\<dots> \<le> poly_deg p" by (rule poly_deg_hom_components_le)
         finally show ?thesis .
       next
         case False
         hence "snd (q0 h) f = 0" by (rule 3)
         thus ?thesis by (simp add: d)
       qed
     qed
     finally show "poly_deg (q f * f) \<le> poly_deg p" .
 
     assume "f \<notin> F'"
     show "q f = 0" unfolding q_def
     proof (intro sum.neutral ballI)
       fix h
       assume "h \<in> hom_components p"
       hence "P h (q0 h)" by (rule 1)
       hence 2: "\<And>f. f \<notin> fst (q0 h) \<Longrightarrow> snd (q0 h) f = 0" by (simp add: P_def)
       show "snd (q0 h) f = 0"
       proof (intro 2 notI)
         assume "f \<in> fst (q0 h)"
         hence "f \<in> F'" unfolding F'_def using \<open>h \<in> hom_components p\<close> by blast
         with \<open>f \<notin> F'\<close> show False ..
       qed
     qed
   qed
 qed
 
 corollary homogeneous_idealE_finite:
   assumes "finite F" and "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F"
   obtains q where "p = (\<Sum>f\<in>F. q f * f)" and "\<And>f. poly_deg (q f * f) \<le> poly_deg p"
     and "\<And>f. f \<notin> F \<Longrightarrow> q f = 0"
 proof -
   from assms(2, 3) obtain F' q where "F' \<subseteq> F" and p: "p = (\<Sum>f\<in>F'. q f * f)"
     and "\<And>f. poly_deg (q f * f) \<le> poly_deg p" and 1: "\<And>f. f \<notin> F' \<Longrightarrow> q f = 0"
     by (rule homogeneous_idealE) blast+
   show ?thesis
   proof
     from assms(1) \<open>F' \<subseteq> F\<close> have "(\<Sum>f\<in>F'. q f * f) = (\<Sum>f\<in>F. q f * f)"
     proof (intro sum.mono_neutral_left ballI)
       fix f
       assume "f \<in> F - F'"
       hence "f \<notin> F'" by simp
       hence "q f = 0" by (rule 1)
       thus "q f * f = 0" by simp
     qed
     thus "p = (\<Sum>f\<in>F. q f * f)" by (simp only: p)
   next
     fix f
     show "poly_deg (q f * f) \<le> poly_deg p" by fact
 
     assume "f \<notin> F"
     with \<open>F' \<subseteq> F\<close> have "f \<notin> F'" by blast
     thus "q f = 0" by (rule 1)
   qed
 qed
 
 subsubsection \<open>Homogenization and Dehomogenization\<close>
 
 definition homogenize :: "'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::semiring_1)"
   where "homogenize x p = (\<Sum>t\<in>keys p. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
 
 definition dehomo_subst :: "'x \<Rightarrow> 'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::zero_neq_one)"
   where "dehomo_subst x = (\<lambda>y. if y = x then 1 else monomial 1 (Poly_Mapping.single y 1))"
 
 definition dehomogenize :: "'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1)"
   where "dehomogenize x = poly_subst (dehomo_subst x)"
 
 lemma homogenize_zero [simp]: "homogenize x 0 = 0"
   by (simp add: homogenize_def)
 
 lemma homogenize_uminus [simp]: "homogenize x (- p) = - homogenize x (p::_ \<Rightarrow>\<^sub>0 'a::ring_1)"
   by (simp add: homogenize_def keys_uminus sum.reindex inj_on_def single_uminus sum_negf)
 
 lemma homogenize_monom_mult [simp]:
   "homogenize x (punit.monom_mult c t p) = punit.monom_mult c t (homogenize x p)"
   for c::"'a::{semiring_1,semiring_no_zero_divisors_cancel}"
 proof (cases "p = 0")
   case True
   thus ?thesis by simp
 next
   case False
   show ?thesis
   proof (cases "c = 0")
     case True
     thus ?thesis by simp
   next
     case False
     show ?thesis
       by (simp add: homogenize_def punit.keys_monom_mult \<open>p \<noteq> 0\<close> False sum.reindex
           punit.lookup_monom_mult punit.monom_mult_sum_right poly_deg_monom_mult
           punit.monom_mult_monomial ac_simps deg_pm_plus)
   qed
 qed
 
 lemma homogenize_alt:
   "homogenize x p = (\<Sum>q\<in>hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
 proof -
   have "homogenize x p = (\<Sum>t\<in>Keys (hom_components p). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
     by (simp only: homogenize_def Keys_hom_components)
   also have "\<dots> = (\<Sum>t\<in>(\<Union> (keys ` hom_components p)). monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
     by (simp only: Keys_def)
   also have "\<dots> = (\<Sum>q\<in>hom_components p. (\<Sum>t\<in>keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
     by (auto intro!: sum.UNION_disjoint finite_hom_components finite_keys dest: hom_components_keys_disjoint)
   also have "\<dots> = (\<Sum>q\<in>hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
     using refl
   proof (rule sum.cong)
     fix q
     assume q: "q \<in> hom_components p"
     hence "homogeneous q" by (rule hom_components_homogeneous)
     have "(\<Sum>t\<in>keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
           (\<Sum>t\<in>keys q. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t))"
       using refl
     proof (rule sum.cong)
       fix t
       assume "t \<in> keys q"
       with \<open>homogeneous q\<close> have "deg_pm t = poly_deg q" by (rule homogeneousD_poly_deg)
       moreover from q \<open>t \<in> keys q\<close> have "lookup q t = lookup p t" by (rule lookup_hom_components)
       ultimately show "monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) =
             punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) (monomial (lookup q t) t)"
         by (simp add: punit.monom_mult_monomial)
     qed
     also have "\<dots> = punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q"
       by (simp only: poly_mapping_sum_monomials flip: punit.monom_mult_sum_right)
     finally show "(\<Sum>t\<in>keys q. monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)) =
                   punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q" .
   qed
   finally show ?thesis .
 qed
 
 lemma keys_homogenizeE:
   assumes "t \<in> keys (homogenize x p)"
   obtains t' where "t' \<in> keys p" and "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
 proof -
   note assms
   also have "keys (homogenize x p) \<subseteq>
             (\<Union>t\<in>keys p. keys (monomial (lookup p t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)))"
     unfolding homogenize_def by (rule keys_sum_subset)
   finally obtain t' where "t' \<in> keys p"
     and "t \<in> keys (monomial (lookup p t') (Poly_Mapping.single x (poly_deg p - deg_pm t') + t'))" ..
   from this(2) have "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'"
     by (simp split: if_split_asm)
   with \<open>t' \<in> keys p\<close> show ?thesis ..
 qed
 
 lemma keys_homogenizeE_alt:
   assumes "t \<in> keys (homogenize x p)"
   obtains q t' where "q \<in> hom_components p" and "t' \<in> keys q"
     and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'"
 proof -
   note assms
   also have "keys (homogenize x p) \<subseteq>
             (\<Union>q\<in>hom_components p. keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q))"
     unfolding homogenize_alt by (rule keys_sum_subset)
   finally obtain q where q: "q \<in> hom_components p"
     and "t \<in> keys (punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)" ..
   note this(2)
   also have "\<dots> \<subseteq> (+) (Poly_Mapping.single x (poly_deg p - poly_deg q)) ` keys q"
     by (rule punit.keys_monom_mult_subset[simplified])
   finally obtain t' where "t' \<in> keys q" and "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" ..
   with q show ?thesis ..
 qed
 
 lemma deg_pm_homogenize:
   assumes "t \<in> keys (homogenize x p)"
   shows "deg_pm t = poly_deg p"
 proof -
   from assms obtain q t' where q: "q \<in> hom_components p" and "t' \<in> keys q"
     and t: "t = Poly_Mapping.single x (poly_deg p - poly_deg q) + t'" by (rule keys_homogenizeE_alt)
   from q have "homogeneous q" by (rule hom_components_homogeneous)
   hence "deg_pm t' = poly_deg q" using \<open>t' \<in> keys q\<close> by (rule homogeneousD_poly_deg)
   moreover from q have "poly_deg q \<le> poly_deg p" by (rule poly_deg_hom_components_le)
   ultimately show ?thesis by (simp add: t deg_pm_plus deg_pm_single)
 qed
 
 corollary homogeneous_homogenize: "homogeneous (homogenize x p)"
 proof (rule homogeneousI)
   fix s t
   assume "s \<in> keys (homogenize x p)"
   hence *: "deg_pm s = poly_deg p" by (rule deg_pm_homogenize)
   assume "t \<in> keys (homogenize x p)"
   hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
   with * show "deg_pm s = deg_pm t" by simp
 qed
 
 corollary poly_deg_homogenize_le: "poly_deg (homogenize x p) \<le> poly_deg p"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (homogenize x p)"
   hence "deg_pm t = poly_deg p" by (rule deg_pm_homogenize)
   thus "deg_pm t \<le> poly_deg p" by simp
 qed
 
 lemma homogenize_id_iff [simp]: "homogenize x p = p \<longleftrightarrow> homogeneous p"
 proof
   assume "homogenize x p = p"
   moreover have "homogeneous (homogenize x p)" by (fact homogeneous_homogenize)
   ultimately show "homogeneous p" by simp
 next
   assume "homogeneous p"
   hence "hom_components p = (if p = 0 then {} else {p})" by (rule hom_components_of_homogeneous)
   thus "homogenize x p = p" by (simp add: homogenize_alt split: if_split_asm)
 qed
 
 lemma homogenize_homogenize [simp]: "homogenize x (homogenize x p) = homogenize x p"
   by (simp add: homogeneous_homogenize)
 
 lemma homogenize_monomial: "homogenize x (monomial c t) = monomial c t"
   by (simp only: homogenize_id_iff homogeneous_monomial)
 
 lemma indets_homogenize_subset: "indets (homogenize x p) \<subseteq> insert x (indets p)"
 proof
   fix y
   assume "y \<in> indets (homogenize x p)"
   then obtain t where "t \<in> keys (homogenize x p)" and "y \<in> keys t" by (rule in_indetsE)
   from this(1) obtain t' where "t' \<in> keys p"
     and t: "t = Poly_Mapping.single x (poly_deg p - deg_pm t') + t'" by (rule keys_homogenizeE)
   note \<open>y \<in> keys t\<close>
   also have "keys t \<subseteq> keys (Poly_Mapping.single x (poly_deg p - deg_pm t')) \<union> keys t'"
     unfolding t by (rule Poly_Mapping.keys_add)
   finally show "y \<in> insert x (indets p)"
   proof
     assume "y \<in> keys (Poly_Mapping.single x (poly_deg p - deg_pm t'))"
     thus ?thesis by (simp split: if_split_asm)
   next
     assume "y \<in> keys t'"
     hence "y \<in> indets p" using \<open>t' \<in> keys p\<close> by (rule in_indetsI)
     thus ?thesis by simp
   qed
 qed
 
 lemma homogenize_in_Polys: "p \<in> P[X] \<Longrightarrow> homogenize x p \<in> P[insert x X]"
   using indets_homogenize_subset[of x p] by (auto simp: Polys_alt)
 
 lemma lookup_homogenize:
   assumes "x \<notin> indets p" and "x \<notin> keys t"
   shows "lookup (homogenize x p) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t) = lookup p t"
 proof -
   let ?p = "homogenize x p"
   let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t) + t"
   have eq: "(\<Sum>s\<in>keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t) = 0"
   proof (intro sum.neutral ballI)
     fix s
     assume "s \<in> keys p - {t}"
     hence "s \<in> keys p" and "s \<noteq> t" by simp_all
     from this(1) have "keys s \<subseteq> indets p" by (simp add: in_indetsI subsetI)
     with assms(1) have "x \<notin> keys s" by blast
     have "?t \<noteq> Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
     proof
       assume a: "?t = Poly_Mapping.single x (poly_deg p - deg_pm s) + s"
       hence "lookup ?t x = lookup (Poly_Mapping.single x (poly_deg p - deg_pm s) + s) x"
         by simp
       moreover from assms(2) have "lookup t x = 0" by (simp add: in_keys_iff)
       moreover from \<open>x \<notin> keys s\<close> have "lookup s x = 0" by (simp add: in_keys_iff)
       ultimately have "poly_deg p - deg_pm t = poly_deg p - deg_pm s" by (simp add: lookup_add)
       with a have "s = t" by simp
       with \<open>s \<noteq> t\<close> show False ..
     qed
     thus "lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t = 0"
       by (simp add: lookup_single)
   qed
   show ?thesis
   proof (cases "t \<in> keys p")
     case True
     have "lookup ?p ?t = (\<Sum>s\<in>keys p. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
       by (simp add: homogenize_def lookup_sum)
     also have "\<dots> = lookup (monomial (lookup p t) ?t) ?t +
                     (\<Sum>s\<in>keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
       using finite_keys True by (rule sum.remove)
     also have "\<dots> = lookup p t" by (simp add: eq)
     finally show ?thesis .
   next
     case False
     hence 1: "keys p - {t} = keys p" by simp
     have "lookup ?p ?t = (\<Sum>s\<in>keys p - {t}. lookup (monomial (lookup p s) (Poly_Mapping.single x (poly_deg p - deg_pm s) + s)) ?t)"
       by (simp add: homogenize_def lookup_sum 1)
     also have "\<dots> = 0" by (simp only: eq)
     also from False have "\<dots> = lookup p t" by (simp add: in_keys_iff)
     finally show ?thesis .
   qed
 qed
 
 lemma keys_homogenizeI:
   assumes "x \<notin> indets p" and "t \<in> keys p"
   shows "Poly_Mapping.single x (poly_deg p - deg_pm t) + t \<in> keys (homogenize x p)" (is "?t \<in> keys ?p")
 proof -
   from assms(2) have "keys t \<subseteq> indets p" by (simp add: in_indetsI subsetI)
   with assms(1) have "x \<notin> keys t" by blast
   with assms(1) have "lookup ?p ?t = lookup p t" by (rule lookup_homogenize)
   also from assms(2) have "\<dots> \<noteq> 0" by (simp add: in_keys_iff)
   finally show ?thesis by (simp add: in_keys_iff)
 qed
 
 lemma keys_homogenize:
   "x \<notin> indets p \<Longrightarrow> keys (homogenize x p) = (\<lambda>t. Poly_Mapping.single x (poly_deg p - deg_pm t) + t) ` keys p"
   by (auto intro: keys_homogenizeI elim: keys_homogenizeE)
 
 lemma card_keys_homogenize:
   assumes "x \<notin> indets p"
   shows "card (keys (homogenize x p)) = card (keys p)"
   unfolding keys_homogenize[OF assms]
 proof (intro card_image inj_onI)
   fix s t
   assume "s \<in> keys p" and "t \<in> keys p"
   with assms have "x \<notin> keys s" and "x \<notin> keys t" by (auto dest: in_indetsI simp only:)
   let ?s = "Poly_Mapping.single x (poly_deg p - deg_pm s)"
   let ?t = "Poly_Mapping.single x (poly_deg p - deg_pm t)"
   assume "?s + s = ?t + t"
   hence "lookup (?s + s) x = lookup (?t + t) x" by simp
   with \<open>x \<notin> keys s\<close> \<open>x \<notin> keys t\<close> have "?s = ?t" by (simp add: lookup_add in_keys_iff)
   with \<open>?s + s = ?t + t\<close> show "s = t" by simp
 qed
 
 lemma poly_deg_homogenize:
   assumes "x \<notin> indets p"
   shows "poly_deg (homogenize x p) = poly_deg p"
 proof (cases "p = 0")
   case True
   thus ?thesis by simp
 next
   case False
   then obtain t where "t \<in> keys p" and 1: "poly_deg p = deg_pm t" by (rule poly_degE)
   from assms this(1) have "Poly_Mapping.single x (poly_deg p - deg_pm t) + t \<in> keys (homogenize x p)"
     by (rule keys_homogenizeI)
   hence "t \<in> keys (homogenize x p)" by (simp add: 1)
   hence "poly_deg p \<le> poly_deg (homogenize x p)" unfolding 1 by (rule poly_deg_max_keys)
   with poly_deg_homogenize_le show ?thesis by (rule antisym)
 qed
 
 lemma maxdeg_homogenize:
-  assumes "x \<notin> UNION F indets"
+  assumes "x \<notin> \<Union> (indets ` F)"
   shows "maxdeg (homogenize x ` F) = maxdeg F"
   unfolding maxdeg_def image_image
 proof (rule arg_cong[where f=Max], rule set_eqI)
   fix d
   show "d \<in> (\<lambda>f. poly_deg (homogenize x f)) ` F \<longleftrightarrow> d \<in> poly_deg ` F"
   proof
     assume "d \<in> (\<lambda>f. poly_deg (homogenize x f)) ` F"
     then obtain f where "f \<in> F" and d: "d = poly_deg (homogenize x f)" ..
     from assms this(1) have "x \<notin> indets f" by blast
     hence "d = poly_deg f" by (simp add: d poly_deg_homogenize)
     with \<open>f \<in> F\<close> show "d \<in> poly_deg ` F" by (rule rev_image_eqI)
   next
     assume "d \<in> poly_deg ` F"
     then obtain f where "f \<in> F" and d: "d = poly_deg f" ..
     from assms this(1) have "x \<notin> indets f" by blast
     hence "d = poly_deg (homogenize x f)" by (simp add: d poly_deg_homogenize)
     with \<open>f \<in> F\<close> show "d \<in> (\<lambda>f. poly_deg (homogenize x f)) ` F" by (rule rev_image_eqI)
   qed
 qed
 
 lemma homogeneous_ideal_homogenize:
   assumes "\<And>f. f \<in> F \<Longrightarrow> homogeneous f" and "p \<in> ideal F"
   shows "homogenize x p \<in> ideal F"
 proof -
   have "homogenize x p = (\<Sum>q\<in>hom_components p. punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q)"
     by (fact homogenize_alt)
   also have "\<dots> \<in> ideal F"
   proof (rule ideal.span_sum)
     fix q
     assume "q \<in> hom_components p"
     with assms have "q \<in> ideal F" by (rule homogeneous_ideal')
     thus "punit.monom_mult 1 (Poly_Mapping.single x (poly_deg p - poly_deg q)) q \<in> ideal F"
       by (rule punit.pmdl_closed_monom_mult[simplified])
   qed
   finally show ?thesis .
 qed
 
 lemma subst_pp_dehomo_subst [simp]:
   "subst_pp (dehomo_subst x) t = monomial (1::'b::comm_semiring_1) (except t {x})"
 proof -
   have "subst_pp (dehomo_subst x) t = ((\<Prod>y\<in>keys t. dehomo_subst x y ^ lookup t y)::_ \<Rightarrow>\<^sub>0 'b)"
     by (fact subst_pp_def)
   also have "\<dots> = (\<Prod>y\<in>keys t - {y0. dehomo_subst x y0 ^ lookup t y0 = (1::_ \<Rightarrow>\<^sub>0 'b)}. dehomo_subst x y ^ lookup t y)"
     by (rule sym, rule prod.setdiff_irrelevant, fact finite_keys)
   also have "\<dots> = (\<Prod>y\<in>keys t - {x}. monomial 1 (Poly_Mapping.single y 1) ^ lookup t y)"
   proof (rule prod.cong)
     have "dehomo_subst x x ^ lookup t x = 1" by (simp add: dehomo_subst_def)
     moreover {
       fix y
       assume "y \<noteq> x"
       hence "dehomo_subst x y ^ lookup t y = monomial 1 (Poly_Mapping.single y (lookup t y))"
         by (simp add: dehomo_subst_def monomial_single_power)
       moreover assume "dehomo_subst x y ^ lookup t y = 1"
       ultimately have "Poly_Mapping.single y (lookup t y) = 0"
         by (smt single_one monomial_inj zero_neq_one)
       hence "lookup t y = 0" by (rule monomial_0D)
       moreover assume "y \<in> keys t"
       ultimately have False by (simp add: in_keys_iff)
     }
     ultimately show "keys t - {y0. dehomo_subst x y0 ^ lookup t y0 = 1} = keys t - {x}" by auto
   qed (simp add: dehomo_subst_def)
   also have "\<dots> = (\<Prod>y\<in>keys t - {x}. monomial 1 (Poly_Mapping.single y (lookup t y)))"
     by (simp add: monomial_single_power)
   also have "\<dots> = monomial 1 (\<Sum>y\<in>keys t - {x}. Poly_Mapping.single y (lookup t y))"
     by (simp flip: punit.monomial_prod_sum)
   also have "(\<Sum>y\<in>keys t - {x}. Poly_Mapping.single y (lookup t y)) = except t {x}"
   proof (rule poly_mapping_eqI, simp add: lookup_sum lookup_except lookup_single, rule)
     fix y
     assume "y \<noteq> x"
     show "(\<Sum>z\<in>keys t - {x}. lookup t z when z = y) = lookup t y"
     proof (cases "y \<in> keys t")
       case True
       have "finite (keys t - {x})" by simp
       moreover from True \<open>y \<noteq> x\<close> have "y \<in> keys t - {x}" by simp
       ultimately have "(\<Sum>z\<in>keys t - {x}. lookup t z when z = y) =
                         (lookup t y when y = y) + (\<Sum>z\<in>keys t - {x} - {y}. lookup t z when z = y)"
         by (rule sum.remove)
       also have "(\<Sum>z\<in>keys t - {x} - {y}. lookup t z when z = y) = 0" by auto
       finally show ?thesis by simp
     next
       case False
       hence "(\<Sum>z\<in>keys t - {x}. lookup t z when z = y) = 0" by (auto simp: when_def)
       also from False have "\<dots> = lookup t y" by (simp add: in_keys_iff)
       finally show ?thesis .
     qed
   qed
   finally show ?thesis .
 qed
 
 lemma
   shows dehomogenize_zero [simp]: "dehomogenize x 0 = 0"
     and dehomogenize_one [simp]: "dehomogenize x 1 = 1"
     and dehomogenize_monomial: "dehomogenize x (monomial c t) = monomial c (except t {x})"
     and dehomogenize_plus: "dehomogenize x (p + q) = dehomogenize x p + dehomogenize x q"
     and dehomogenize_uminus: "dehomogenize x (- r) = - dehomogenize x (r::_ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
     and dehomogenize_minus: "dehomogenize x (r - r') = dehomogenize x r - dehomogenize x r'"
     and dehomogenize_times: "dehomogenize x (p * q) = dehomogenize x p * dehomogenize x q"
     and dehomogenize_power: "dehomogenize x (p ^ n) = dehomogenize x p ^ n"
     and dehomogenize_sum: "dehomogenize x (sum f A) = (\<Sum>a\<in>A. dehomogenize x (f a))"
     and dehomogenize_prod: "dehomogenize x (prod f A) = (\<Prod>a\<in>A. dehomogenize x (f a))"
   by (simp_all add: dehomogenize_def poly_subst_monomial poly_subst_plus poly_subst_uminus
       poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod punit.monom_mult_monomial)
 
 corollary dehomogenize_monom_mult:
   "dehomogenize x (punit.monom_mult c t p) = punit.monom_mult c (except t {x}) (dehomogenize x p)"
   by (simp only: times_monomial_left[symmetric] dehomogenize_times dehomogenize_monomial)
 
 lemma poly_deg_dehomogenize_le: "poly_deg (dehomogenize x p) \<le> poly_deg p"
   unfolding dehomogenize_def dehomo_subst_def
   by (rule poly_deg_poly_subst_le) (simp add: poly_deg_monomial deg_pm_single)
 
 lemma indets_dehomogenize: "indets (dehomogenize x p) \<subseteq> indets p - {x}"
   for p::"('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1"
 proof
   fix y::'x
   assume "y \<in> indets (dehomogenize x p)"
   then obtain y' where "y' \<in> indets p" and "y \<in> indets ((dehomo_subst x y')::_ \<Rightarrow>\<^sub>0 'a)"
     unfolding dehomogenize_def by (rule in_indets_poly_substE)
   from this(2) have "y = y'" and "y' \<noteq> x"
     by (simp_all add: dehomo_subst_def indets_monomial split: if_split_asm)
   with \<open>y' \<in> indets p\<close> show "y \<in> indets p - {x}" by simp
 qed
 
 lemma dehomogenize_id_iff [simp]: "dehomogenize x p = p \<longleftrightarrow> x \<notin> indets p"
 proof
   assume eq: "dehomogenize x p = p"
   from indets_dehomogenize[of x p] show "x \<notin> indets p" by (auto simp: eq)
 next
   assume a: "x \<notin> indets p"
   show "dehomogenize x p = p" unfolding dehomogenize_def
   proof (rule poly_subst_id)
     fix y
     assume "y \<in> indets p"
     with a have "y \<noteq> x" by blast
     thus "dehomo_subst x y = monomial 1 (Poly_Mapping.single y 1)" by (simp add: dehomo_subst_def)
   qed
 qed
 
 lemma dehomogenize_dehomogenize [simp]: "dehomogenize x (dehomogenize x p) = dehomogenize x p"
 proof -
   from indets_dehomogenize[of x p] have "x \<notin> indets (dehomogenize x p)" by blast
   thus ?thesis by simp
 qed
 
 lemma dehomogenize_homogenize [simp]: "dehomogenize x (homogenize x p) = dehomogenize x p"
 proof -
   have "dehomogenize x (homogenize x p) = sum (dehomogenize x) (hom_components p)"
     by (simp add: homogenize_alt dehomogenize_sum dehomogenize_monom_mult except_single)
   also have "\<dots> = dehomogenize x p" by (simp only: sum_hom_components flip: dehomogenize_sum)
   finally show ?thesis .
 qed
 
 corollary dehomogenize_homogenize_id: "x \<notin> indets p \<Longrightarrow> dehomogenize x (homogenize x p) = p"
   by simp
 
 lemma range_dehomogenize: "range (dehomogenize x) = (P[- {x}] :: (_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1) set)"
 proof (intro subset_antisym subsetI PolysI_alt range_eqI)
   fix p::"_ \<Rightarrow>\<^sub>0 'a" and y
   assume "p \<in> range (dehomogenize x)"
   then obtain q where p: "p = dehomogenize x q" ..
   assume "y \<in> indets p"
   hence "y \<in> indets (dehomogenize x q)" by (simp only: p)
   with indets_dehomogenize have "y \<in> indets q - {x}" ..
   thus "y \<in> - {x}" by simp
 next
   fix p::"_ \<Rightarrow>\<^sub>0 'a"
   assume "p \<in> P[- {x}]"
   hence "x \<notin> indets p" by (auto dest: PolysD)
   thus "p = dehomogenize x (homogenize x p)" by (rule dehomogenize_homogenize_id[symmetric])
 qed
 
 lemma dehomogenize_alt: "dehomogenize x p = (\<Sum>t\<in>keys p. monomial (lookup p t) (except t {x}))"
 proof -
   have "dehomogenize x p = dehomogenize x (\<Sum>t\<in>keys p. monomial (lookup p t) t)"
     by (simp only: poly_mapping_sum_monomials)
   also have "\<dots> = (\<Sum>t\<in>keys p. monomial (lookup p t) (except t {x}))"
     by (simp only: dehomogenize_sum dehomogenize_monomial)
   finally show ?thesis .
 qed
 
 lemma keys_dehomogenizeE:
   assumes "t \<in> keys (dehomogenize x p)"
   obtains s where "s \<in> keys p" and "t = except s {x}"
 proof -
   note assms
   also have "keys (dehomogenize x p) \<subseteq> (\<Union>s\<in>keys p. keys (monomial (lookup p s) (except s {x})))"
     unfolding dehomogenize_alt by (rule keys_sum_subset)
   finally obtain s where "s \<in> keys p" and "t \<in> keys (monomial (lookup p s) (except s {x}))" ..
   from this(2) have "t = except s {x}" by (simp split: if_split_asm)
   with \<open>s \<in> keys p\<close> show ?thesis ..
 qed
 
 lemma except_inj_on_keys_homogeneous:
   assumes "homogeneous p"
   shows "inj_on (\<lambda>t. except t {x}) (keys p)"
 proof
   fix s t
   assume "s \<in> keys p" and "t \<in> keys p"
   from assms this(1) have "deg_pm s = poly_deg p" by (rule homogeneousD_poly_deg)
   moreover from assms \<open>t \<in> keys p\<close> have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
   ultimately have "deg_pm (Poly_Mapping.single x (lookup s x) + except s {x}) =
                    deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
     by (simp only: flip: plus_except)
   moreover assume 1: "except s {x} = except t {x}"
   ultimately have 2: "lookup s x = lookup t x"
     by (simp only: deg_pm_plus deg_pm_single)
   show "s = t"
   proof (rule poly_mapping_eqI)
     fix y
     show "lookup s y = lookup t y"
     proof (cases "y = x")
       case True
       with 2 show ?thesis by simp
     next
       case False
       hence "lookup s y = lookup (except s {x}) y" and "lookup t y = lookup (except t {x}) y"
         by (simp_all add: lookup_except)
       with 1 show ?thesis by simp
     qed
   qed
 qed
 
 lemma lookup_dehomogenize:
   assumes "homogeneous p" and "t \<in> keys p"
   shows "lookup (dehomogenize x p) (except t {x}) = lookup p t"
 proof -
   let ?t = "except t {x}"
   have eq: "(\<Sum>s\<in>keys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t) = 0"
   proof (intro sum.neutral ballI)
     fix s
     assume "s \<in> keys p - {t}"
     hence "s \<in> keys p" and "s \<noteq> t" by simp_all
     have "?t \<noteq> except s {x}"
     proof
       from assms(1) have "inj_on (\<lambda>t. except t {x}) (keys p)" by (rule except_inj_on_keys_homogeneous)
       moreover assume "?t = except s {x}"
       ultimately have "t = s" using assms(2) \<open>s \<in> keys p\<close> by (rule inj_onD)
       with \<open>s \<noteq> t\<close> show False by simp
     qed
     thus "lookup (monomial (lookup p s) (except s {x})) ?t = 0" by (simp add: lookup_single)
   qed
   have "lookup (dehomogenize x p) ?t = (\<Sum>s\<in>keys p. lookup (monomial (lookup p s) (except s {x})) ?t)"
     by (simp only: dehomogenize_alt lookup_sum)
   also have "\<dots> = lookup (monomial (lookup p t) ?t) ?t +
                   (\<Sum>s\<in>keys p - {t}. lookup (monomial (lookup p s) (except s {x})) ?t)"
     using finite_keys assms(2) by (rule sum.remove)
   also have "\<dots> = lookup p t" by (simp add: eq)
   finally show ?thesis .
 qed
 
 lemma keys_dehomogenizeI:
   assumes "homogeneous p" and "t \<in> keys p"
   shows "except t {x} \<in> keys (dehomogenize x p)"
 proof -
   from assms have "lookup (dehomogenize x p) (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
   also from assms(2) have "\<dots> \<noteq> 0" by (simp add: in_keys_iff)
   finally show ?thesis by (simp add: in_keys_iff)
 qed
 
 lemma homogeneous_homogenize_dehomogenize:
   assumes "homogeneous p"
   obtains d where "d = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
     and "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
 proof (cases "p = 0")
   case True
   hence "0 = poly_deg p - poly_deg (homogenize x (dehomogenize x p))"
     and "punit.monom_mult 1 (Poly_Mapping.single x 0) (homogenize x (dehomogenize x p)) = p"
     by simp_all
   thus ?thesis ..
 next
   case False
   let ?q = "dehomogenize x p"
   let ?p = "homogenize x ?q"
   define d where "d = poly_deg p - poly_deg ?p"
   show ?thesis
   proof
     have "punit.monom_mult 1 (Poly_Mapping.single x d) ?p =
           (\<Sum>t\<in>keys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t))"
       by (simp add: homogenize_def punit.monom_mult_sum_right punit.monom_mult_monomial flip: add.assoc single_add)
     also have "\<dots> = (\<Sum>t\<in>keys ?q. monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
       using refl
     proof (rule sum.cong)
       fix t
       assume "t \<in> keys ?q"
       have "poly_deg ?p = poly_deg ?q"
       proof (rule poly_deg_homogenize)
         from indets_dehomogenize show "x \<notin> indets ?q" by fastforce
       qed
       hence d: "d = poly_deg p - poly_deg ?q" by (simp only: d_def)
       thm poly_deg_dehomogenize_le
       from \<open>t \<in> keys ?q\<close> have "d + (poly_deg ?q - deg_pm t) = (d + poly_deg ?q) - deg_pm t"
         by (intro add_diff_assoc poly_deg_max_keys)
       also have "d + poly_deg ?q = poly_deg p" by (simp add: d poly_deg_dehomogenize_le)
       finally show "monomial (lookup ?q t) (Poly_Mapping.single x (d + (poly_deg ?q - deg_pm t)) + t) =
                     monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t)"
         by (simp only:)
     qed
     also have "\<dots> = (\<Sum>t\<in>(\<lambda>s. except s {x}) ` keys p.
                     monomial (lookup ?q t) (Poly_Mapping.single x (poly_deg p - deg_pm t) + t))"
     proof (rule sum.mono_neutral_left)
       show "keys (dehomogenize x p) \<subseteq> (\<lambda>s. except s {x}) ` keys p"
       proof
         fix t
         assume "t \<in> keys (dehomogenize x p)"
         then obtain s where "s \<in> keys p" and "t = except s {x}" by (rule keys_dehomogenizeE)
         thus "t \<in> (\<lambda>s. except s {x}) ` keys p" by (rule rev_image_eqI)
       qed
     qed (simp_all add: in_keys_iff)
     also from assms have "\<dots> = (\<Sum>t\<in>keys p. monomial (lookup ?q (except t {x}))
                 (Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}))"
       by (intro sum.reindex[unfolded comp_def] except_inj_on_keys_homogeneous)
     also from refl have "\<dots> = (\<Sum>t\<in>keys p. monomial (lookup p t) t)"
     proof (rule sum.cong)
       fix t
       assume "t \<in> keys p"
       with assms have "lookup ?q (except t {x}) = lookup p t" by (rule lookup_dehomogenize)
       moreover have "Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x} = t"
         (is "?l = _")
       proof (rule poly_mapping_eqI)
         fix y
         show "lookup ?l y = lookup t y"
         proof (cases "y = x")
           case True
           from assms \<open>t \<in> keys p\<close> have "deg_pm t = poly_deg p" by (rule homogeneousD_poly_deg)
           also have "deg_pm t = deg_pm (Poly_Mapping.single x (lookup t x) + except t {x})"
             by (simp flip: plus_except)
           also have "\<dots> = lookup t x + deg_pm (except t {x})" by (simp only: deg_pm_plus deg_pm_single)
           finally have "poly_deg p - deg_pm (except t {x}) = lookup t x" by simp
           thus ?thesis by (simp add: True lookup_add lookup_except lookup_single)
         next
           case False
           thus ?thesis by (simp add: lookup_add lookup_except lookup_single)
         qed
       qed
       ultimately show "monomial (lookup ?q (except t {x}))
               (Poly_Mapping.single x (poly_deg p - deg_pm (except t {x})) + except t {x}) =
             monomial (lookup p t) t" by (simp only:)
     qed
     also have "\<dots> = p" by (fact poly_mapping_sum_monomials)
     finally show "punit.monom_mult 1 (Poly_Mapping.single x d) ?p = p" .
   qed (simp only: d_def)
 qed
 
 lemma dehomogenize_zeroD:
   assumes "dehomogenize x p = 0" and "homogeneous p"
   shows "p = 0"
 proof -
   from assms(2) obtain d
     where "punit.monom_mult 1 (Poly_Mapping.single x d) (homogenize x (dehomogenize x p)) = p"
     by (rule homogeneous_homogenize_dehomogenize)
   thus ?thesis by (simp add: assms(1))
 qed
 
 lemma dehomogenize_ideal: "dehomogenize x ` ideal F = ideal (dehomogenize x ` F) \<inter> P[- {x}]"
   unfolding range_dehomogenize[symmetric]
   using dehomogenize_plus dehomogenize_times dehomogenize_dehomogenize by (rule image_ideal_eq_Int)
 
 corollary dehomogenize_ideal_subset: "dehomogenize x ` ideal F \<subseteq> ideal (dehomogenize x ` F)"
   by (simp add: dehomogenize_ideal)
 
 lemma ideal_dehomogenize:
   assumes "ideal G = ideal (homogenize x ` F)" and "F \<subseteq> P[UNIV - {x}]"
   shows "ideal (dehomogenize x ` G) = ideal F"
 proof -
   have eq: "dehomogenize x (homogenize x f) = f" if "f \<in> F" for f
   proof (rule dehomogenize_homogenize_id)
     from that assms(2) have "f \<in> P[UNIV - {x}]" ..
     thus "x \<notin> indets f" by (auto simp: Polys_alt)
   qed
   show ?thesis
   proof (intro Set.equalityI ideal.span_subset_spanI)
     show "dehomogenize x ` G \<subseteq> ideal F"
     proof
       fix q
       assume "q \<in> dehomogenize x ` G"
       then obtain g where "g \<in> G" and q: "q = dehomogenize x g" ..
       from this(1) have "g \<in> ideal G" by (rule ideal.span_base)
       also have "\<dots> = ideal (homogenize x ` F)" by fact
       finally have "q \<in> dehomogenize x ` ideal (homogenize x ` F)" using q by (rule rev_image_eqI)
       also have "\<dots> \<subseteq> ideal (dehomogenize x ` homogenize x ` F)" by (rule dehomogenize_ideal_subset)
       also have "dehomogenize x ` homogenize x ` F = F"
         by (auto simp: eq image_image simp del: dehomogenize_homogenize intro!: image_eqI)
       finally show "q \<in> ideal F" .
     qed
   next
     show "F \<subseteq> ideal (dehomogenize x ` G)"
     proof
       fix f
       assume "f \<in> F"
       hence "homogenize x f \<in> homogenize x ` F" by (rule imageI)
       also have "\<dots> \<subseteq> ideal (homogenize x ` F)" by (rule ideal.span_superset)
       also from assms(1) have "\<dots> = ideal G" by (rule sym)
       finally have "dehomogenize x (homogenize x f) \<in> dehomogenize x ` ideal G" by (rule imageI)
       with \<open>f \<in> F\<close> have "f \<in> dehomogenize x ` ideal G" by (simp only: eq)
       also have "\<dots> \<subseteq> ideal (dehomogenize x ` G)" by (rule dehomogenize_ideal_subset)
       finally show "f \<in> ideal (dehomogenize x ` G)" .
     qed
   qed
 qed
 
 subsection \<open>Embedding Polynomial Rings in Larger Polynomial Rings (With One Additional Indeterminate)\<close>
 
 text \<open>We define a homomorphism for embedding a polynomial ring in a larger polynomial ring, and its
   inverse. This is mainly needed for homogenizing wrt. a fresh indeterminate.\<close>
 
 definition extend_indets_subst :: "'x \<Rightarrow> ('x option \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1"
   where "extend_indets_subst x = monomial 1 (Poly_Mapping.single (Some x) 1)"
 
 definition extend_indets :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> ('x option \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1"
   where "extend_indets = poly_subst extend_indets_subst"
 
 definition restrict_indets_subst :: "'x option \<Rightarrow> 'x \<Rightarrow>\<^sub>0 nat"
   where "restrict_indets_subst x = (case x of Some y \<Rightarrow> Poly_Mapping.single y 1 | _ \<Rightarrow> 0)"
 
 definition restrict_indets :: "(('x option \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_semiring_1"
   where "restrict_indets = poly_subst (\<lambda>x. monomial 1 (restrict_indets_subst x))"
 
 definition restrict_indets_pp :: "('x option \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat)"
   where "restrict_indets_pp t = (\<Sum>x\<in>keys t. lookup t x \<cdot> restrict_indets_subst x)"
 
 lemma lookup_extend_indets_subst_aux:
   "lookup (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y)) = (\<lambda>x. case x of Some y \<Rightarrow> lookup t y | _ \<Rightarrow> 0)"
 proof -
   have "(\<Sum>x\<in>keys t. lookup t x when x = y) = lookup t y" for y
   proof (cases "y \<in> keys t")
     case True
     hence "(\<Sum>x\<in>keys t. lookup t x when x = y) = (\<Sum>x\<in>insert y (keys t). lookup t x when x = y)"
       by (simp only: insert_absorb)
     also have "\<dots> = lookup t y + (\<Sum>x\<in>keys t - {y}. lookup t x when x = y)"
       by (simp add: sum.insert_remove)
     also have "(\<Sum>x\<in>keys t - {y}. lookup t x when x = y) = 0"
       by (auto simp: when_def intro: sum.neutral)
     finally show ?thesis by simp
   next
     case False
     hence "(\<Sum>x\<in>keys t. lookup t x when x = y) = 0" by (auto simp: when_def intro: sum.neutral)
     with False show ?thesis by (simp add: in_keys_iff)
   qed
   thus ?thesis by (auto simp: lookup_sum lookup_single split: option.split)
 qed
 
 lemma keys_extend_indets_subst_aux:
   "keys (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y)) = Some ` keys t"
   by (auto simp: lookup_extend_indets_subst_aux simp flip: lookup_not_eq_zero_eq_in_keys split: option.splits)
 
 lemma subst_pp_extend_indets_subst:
   "subst_pp extend_indets_subst t = monomial 1 (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))"
 proof -
   have "subst_pp extend_indets_subst t =
       monomial (\<Prod>y\<in>keys t. 1 ^ lookup t y) (\<Sum>y\<in>keys t. lookup t y \<cdot> Poly_Mapping.single (Some y) 1)"
     by (rule subst_pp_by_monomials) (simp only: extend_indets_subst_def)
   also have "\<dots> = monomial 1 (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))"
     by simp
   finally show ?thesis .
 qed
 
 lemma keys_extend_indets:
   "keys (extend_indets p) = (\<lambda>t. \<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y)) ` keys p"
 proof -
   have "keys (extend_indets p) = (\<Union>t\<in>keys p. keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)))"
     unfolding extend_indets_def poly_subst_def using finite_keys
   proof (rule keys_sum)
     fix s t :: "'a \<Rightarrow>\<^sub>0 nat"
     assume "s \<noteq> t"
     then obtain x where "lookup s x \<noteq> lookup t x" by (meson poly_mapping_eqI)
     have "(\<Sum>y\<in>keys t. monomial (lookup t y) (Some y)) \<noteq> (\<Sum>y\<in>keys s. monomial (lookup s y) (Some y))"
       (is "?l \<noteq> ?r")
     proof
       assume "?l = ?r"
       hence "lookup ?l (Some x) = lookup ?r (Some x)" by (simp only:)
       hence "lookup s x = lookup t x" by (simp add: lookup_extend_indets_subst_aux)
       with \<open>lookup s x \<noteq> lookup t x\<close> show False ..
     qed
     thus "keys (punit.monom_mult (lookup p s) 0 (subst_pp extend_indets_subst s)) \<inter>
           keys (punit.monom_mult (lookup p t) 0 (subst_pp extend_indets_subst t)) =
           {}"
       by (simp add: subst_pp_extend_indets_subst punit.monom_mult_monomial)
   qed
   also have "\<dots> = (\<lambda>t. \<Sum>y\<in>keys t. monomial (lookup t y) (Some y)) ` keys p"
     by (auto simp: subst_pp_extend_indets_subst punit.monom_mult_monomial split: if_split_asm)
   finally show ?thesis .
 qed
 
 lemma indets_extend_indets: "indets (extend_indets p) = Some ` indets (p::_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1)"
 proof (rule set_eqI)
   fix x
   show "x \<in> indets (extend_indets p) \<longleftrightarrow> x \<in> Some ` indets p"
   proof
     assume "x \<in> indets (extend_indets p)"
     then obtain y where "y \<in> indets p" and "x \<in> indets (monomial (1::'a) (Poly_Mapping.single (Some y) 1))"
       unfolding extend_indets_def extend_indets_subst_def by (rule in_indets_poly_substE)
     from this(2) indets_monomial_single_subset have "x \<in> {Some y}" ..
     hence "x = Some y" by simp
     with \<open>y \<in> indets p\<close> show "x \<in> Some ` indets p" by (rule rev_image_eqI)
   next
     assume "x \<in> Some ` indets p"
     then obtain y where "y \<in> indets p" and x: "x = Some y" ..
     from this(1) obtain t where "t \<in> keys p" and "y \<in> keys t" by (rule in_indetsE)
     from this(2) have "Some y \<in> keys (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))"
       unfolding keys_extend_indets_subst_aux by (rule imageI)
     moreover have "(\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y)) \<in> keys (extend_indets p)"
       unfolding keys_extend_indets using \<open>t \<in> keys p\<close> by (rule imageI)
     ultimately show "x \<in> indets (extend_indets p)" unfolding x by (rule in_indetsI)
   qed
 qed
 
 lemma poly_deg_extend_indets [simp]: "poly_deg (extend_indets p) = poly_deg p"
 proof -
   have eq: "deg_pm ((\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))) = deg_pm t"
     for t::"'a \<Rightarrow>\<^sub>0 nat"
   proof -
     have "deg_pm ((\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))) = (\<Sum>y\<in>keys t. lookup t y)"
       by (simp add: deg_pm_sum deg_pm_single)
     also from subset_refl finite_keys have "\<dots> = deg_pm t" by (rule deg_pm_superset[symmetric])
     finally show ?thesis .
   qed
   show ?thesis
   proof (rule antisym)
     show "poly_deg (extend_indets p) \<le> poly_deg p"
     proof (rule poly_deg_leI)
       fix t
       assume "t \<in> keys (extend_indets p)"
       then obtain s where "s \<in> keys p" and "t = (\<Sum>y\<in>keys s. Poly_Mapping.single (Some y) (lookup s y))"
         unfolding keys_extend_indets ..
       from this(2) have "deg_pm t = deg_pm s" by (simp only: eq)
       also from \<open>s \<in> keys p\<close> have "\<dots> \<le> poly_deg p" by (rule poly_deg_max_keys)
       finally show "deg_pm t \<le> poly_deg p" .
     qed
   next
     show "poly_deg p \<le> poly_deg (extend_indets p)"
     proof (rule poly_deg_leI)
       fix t
       assume "t \<in> keys p"
       hence *: "(\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y)) \<in> keys (extend_indets p)"
         unfolding keys_extend_indets by (rule imageI)
       have "deg_pm t = deg_pm (\<Sum>y\<in>keys t. Poly_Mapping.single (Some y) (lookup t y))"
         by (simp only: eq)
       also from * have "\<dots> \<le> poly_deg (extend_indets p)" by (rule poly_deg_max_keys)
       finally show "deg_pm t \<le> poly_deg (extend_indets p)" .
     qed
   qed
 qed
 
 lemma
   shows extend_indets_zero [simp]: "extend_indets 0 = 0"
     and extend_indets_one [simp]: "extend_indets 1 = 1"
     and extend_indets_monomial: "extend_indets (monomial c t) = punit.monom_mult c 0 (subst_pp extend_indets_subst t)"
     and extend_indets_plus: "extend_indets (p + q) = extend_indets p + extend_indets q"
     and extend_indets_uminus: "extend_indets (- r) = - extend_indets (r::_ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
     and extend_indets_minus: "extend_indets (r - r') = extend_indets r - extend_indets r'"
     and extend_indets_times: "extend_indets (p * q) = extend_indets p * extend_indets q"
     and extend_indets_power: "extend_indets (p ^ n) = extend_indets p ^ n"
     and extend_indets_sum: "extend_indets (sum f A) = (\<Sum>a\<in>A. extend_indets (f a))"
     and extend_indets_prod: "extend_indets (prod f A) = (\<Prod>a\<in>A. extend_indets (f a))"
   by (simp_all add: extend_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
       poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod)
 
 lemma extend_indets_zero_iff [simp]: "extend_indets p = 0 \<longleftrightarrow> p = 0"
   by (metis (no_types, lifting) imageE imageI keys_extend_indets lookup_zero
       not_in_keys_iff_lookup_eq_zero poly_deg_extend_indets poly_deg_zero poly_deg_zero_imp_monomial)
 
 lemma extend_indets_inject:
   assumes "extend_indets p = extend_indets (q::_ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
   shows "p = q"
 proof -
   from assms have "extend_indets (p - q) = 0" by (simp add: extend_indets_minus)
   thus ?thesis by simp
 qed
 
 corollary inj_extend_indets: "inj (extend_indets::_ \<Rightarrow> _ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
   using extend_indets_inject by (intro injI)
 
 lemma poly_subst_extend_indets: "poly_subst f (extend_indets p) = poly_subst (f \<circ> Some) p"
   by (simp add: extend_indets_def poly_subst_poly_subst extend_indets_subst_def poly_subst_monomial
           subst_pp_single o_def)
 
 lemma poly_eval_extend_indets: "poly_eval a (extend_indets p) = poly_eval (a \<circ> Some) p"
 proof -
   have eq: "poly_eval a (extend_indets (monomial c t)) = poly_eval (\<lambda>x. a (Some x)) (monomial c t)"
     for c t
     by (simp add: extend_indets_monomial poly_eval_times poly_eval_monomial poly_eval_prod poly_eval_power
                 subst_pp_def extend_indets_subst_def flip: times_monomial_left)
   show ?thesis
     by (induct p rule: poly_mapping_plus_induct) (simp_all add: extend_indets_plus poly_eval_plus eq)
 qed
 
 lemma lookup_restrict_indets_pp: "lookup (restrict_indets_pp t) = (\<lambda>x. lookup t (Some x))"
 proof -
   let ?f = "\<lambda>z x. lookup t x * lookup (case x of None \<Rightarrow> 0 | Some y \<Rightarrow> Poly_Mapping.single y 1) z"
   have "sum (?f z) (keys t) = lookup t (Some z)" for z
   proof (cases "Some z \<in> keys t")
     case True
     hence "sum (?f z) (keys t) = sum (?f z) (insert (Some z) (keys t))"
       by (simp only: insert_absorb)
     also have "\<dots> = lookup t (Some z) + sum (?f z) (keys t - {Some z})"
       by (simp add: sum.insert_remove)
     also have "sum (?f z) (keys t - {Some z}) = 0"
       by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
     finally show ?thesis by simp
   next
     case False
     hence "sum (?f z) (keys t) = 0"
       by (auto simp: when_def lookup_single intro: sum.neutral split: option.splits)
     with False show ?thesis by (simp add: in_keys_iff)
   qed
   thus ?thesis by (auto simp: restrict_indets_pp_def restrict_indets_subst_def lookup_sum)
 qed
 
 lemma keys_restrict_indets_pp: "keys (restrict_indets_pp t) = the ` (keys t - {None})"
 proof (rule set_eqI)
   fix x
   show "x \<in> keys (restrict_indets_pp t) \<longleftrightarrow> x \<in> the ` (keys t - {None})"
   proof
     assume "x \<in> keys (restrict_indets_pp t)"
     hence "Some x \<in> keys t" by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
     hence "Some x \<in> keys t - {None}" by blast
     moreover have "x = the (Some x)" by simp
     ultimately show "x \<in> the ` (keys t - {None})" by (rule rev_image_eqI)
   next
     assume "x \<in> the ` (keys t - {None})"
     then obtain y where "y \<in> keys t - {None}" and "x = the y" ..
     hence "Some x \<in> keys t" by auto
     thus "x \<in> keys (restrict_indets_pp t)"
       by (simp add: lookup_restrict_indets_pp flip: lookup_not_eq_zero_eq_in_keys)
   qed
 qed
 
 lemma subst_pp_restrict_indets_subst:
   "subst_pp (\<lambda>x. monomial 1 (restrict_indets_subst x)) t = monomial 1 (restrict_indets_pp t)"
   by (simp add: subst_pp_def monomial_power_map_scale restrict_indets_pp_def flip: punit.monomial_prod_sum)
 
 lemma restrict_indets_pp_zero [simp]: "restrict_indets_pp 0 = 0"
   by (simp add: restrict_indets_pp_def)
 
 lemma restrict_indets_pp_plus: "restrict_indets_pp (s + t) = restrict_indets_pp s + restrict_indets_pp t"
   by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp)
 
 lemma restrict_indets_pp_except_None [simp]:
   "restrict_indets_pp (except t {None}) = restrict_indets_pp t"
   by (rule poly_mapping_eqI) (simp add: lookup_add lookup_restrict_indets_pp lookup_except)
 
 lemma deg_pm_restrict_indets_pp: "deg_pm (restrict_indets_pp t) + lookup t None = deg_pm t"
 proof -
   have "deg_pm t = sum (lookup t) (insert None (keys t))" by (rule deg_pm_superset) auto
   also from finite_keys have "\<dots> = lookup t None + sum (lookup t) (keys t - {None})"
     by (rule sum.insert_remove)
   also have "sum (lookup t) (keys t - {None}) = (\<Sum>x\<in>keys t. lookup t x * deg_pm (restrict_indets_subst x))"
     by (intro sum.mono_neutral_cong_left) (auto simp: restrict_indets_subst_def deg_pm_single)
   also have "\<dots> = deg_pm (restrict_indets_pp t)"
     by (simp only: restrict_indets_pp_def deg_pm_sum deg_pm_map_scale)
   finally show ?thesis by simp
 qed
 
 lemma keys_restrict_indets_subset: "keys (restrict_indets p) \<subseteq> restrict_indets_pp ` keys p"
 proof
   fix t
   assume "t \<in> keys (restrict_indets p)"
   also have "\<dots> = keys (\<Sum>t\<in>keys p. monomial (lookup p t) (restrict_indets_pp t))"
     by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
   also have "\<dots> \<subseteq> (\<Union>t\<in>keys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
     by (rule keys_sum_subset)
   also have "\<dots> = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
   finally show "t \<in> restrict_indets_pp ` keys p" .
 qed
 
 lemma keys_restrict_indets:
   assumes "None \<notin> indets p"
   shows "keys (restrict_indets p) = restrict_indets_pp ` keys p"
 proof -
   have "keys (restrict_indets p) = keys (\<Sum>t\<in>keys p. monomial (lookup p t) (restrict_indets_pp t))"
     by (simp add: restrict_indets_def poly_subst_def subst_pp_restrict_indets_subst punit.monom_mult_monomial)
   also from finite_keys have "\<dots> = (\<Union>t\<in>keys p. keys (monomial (lookup p t) (restrict_indets_pp t)))"
   proof (rule keys_sum)
     fix s t
     assume "s \<in> keys p"
     hence "keys s \<subseteq> indets p" by (rule keys_subset_indets)
     with assms have "None \<notin> keys s" by blast
     assume "t \<in> keys p"
     hence "keys t \<subseteq> indets p" by (rule keys_subset_indets)
     with assms have "None \<notin> keys t" by blast
     assume "s \<noteq> t"
     then obtain x where neq: "lookup s x \<noteq> lookup t x" by (meson poly_mapping_eqI)
     have "x \<noteq> None"
     proof
       assume "x = None"
       with \<open>None \<notin> keys s\<close> and \<open>None \<notin> keys t\<close> have "x \<notin> keys s" and "x \<notin> keys t" by blast+
       with neq show False by (simp add: in_keys_iff)
     qed
     then obtain y where x: "x = Some y" by blast
     have "restrict_indets_pp t \<noteq> restrict_indets_pp s"
     proof
       assume "restrict_indets_pp t = restrict_indets_pp s"
       hence "lookup (restrict_indets_pp t) y = lookup (restrict_indets_pp s) y" by (simp only:)
       hence "lookup s x = lookup t x" by (simp add: x lookup_restrict_indets_pp)
       with neq show False ..
     qed
     thus "keys (monomial (lookup p s) (restrict_indets_pp s)) \<inter>
           keys (monomial (lookup p t) (restrict_indets_pp t)) = {}"
       by (simp add: subst_pp_extend_indets_subst)
   qed
   also have "\<dots> = restrict_indets_pp ` keys p" by (auto split: if_split_asm)
   finally show ?thesis .
 qed
 
 lemma indets_restrict_indets_subset: "indets (restrict_indets p) \<subseteq> the ` (indets p - {None})"
 proof
   fix x
   assume "x \<in> indets (restrict_indets p)"
   then obtain t where "t \<in> keys (restrict_indets p)" and "x \<in> keys t" by (rule in_indetsE)
   from this(1) keys_restrict_indets_subset have "t \<in> restrict_indets_pp ` keys p" ..
   then obtain s where "s \<in> keys p" and "t = restrict_indets_pp s" ..
   from \<open>x \<in> keys t\<close> this(2) have "x \<in> the ` (keys s - {None})" by (simp only: keys_restrict_indets_pp)
   also from \<open>s \<in> keys p\<close> have "\<dots> \<subseteq> the ` (indets p - {None})"
     by (intro image_mono Diff_mono keys_subset_indets subset_refl)
   finally show "x \<in> the ` (indets p - {None})" .
 qed
 
 lemma poly_deg_restrict_indets_le: "poly_deg (restrict_indets p) \<le> poly_deg p"
 proof (rule poly_deg_leI)
   fix t
   assume "t \<in> keys (restrict_indets p)"
   hence "t \<in> restrict_indets_pp ` keys p" using keys_restrict_indets_subset ..
   then obtain s where "s \<in> keys p" and "t = restrict_indets_pp s" ..
   from this(2) have "deg_pm t + lookup s None = deg_pm s"
     by (simp only: deg_pm_restrict_indets_pp)
   also from \<open>s \<in> keys p\<close> have "\<dots> \<le> poly_deg p" by (rule poly_deg_max_keys)
   finally show "deg_pm t \<le> poly_deg p" by simp
 qed
 
 lemma
   shows restrict_indets_zero [simp]: "restrict_indets 0 = 0"
     and restrict_indets_one [simp]: "restrict_indets 1 = 1"
     and restrict_indets_monomial: "restrict_indets (monomial c t) = monomial c (restrict_indets_pp t)"
     and restrict_indets_plus: "restrict_indets (p + q) = restrict_indets p + restrict_indets q"
     and restrict_indets_uminus: "restrict_indets (- r) = - restrict_indets (r::_ \<Rightarrow>\<^sub>0 _::comm_ring_1)"
     and restrict_indets_minus: "restrict_indets (r - r') = restrict_indets r - restrict_indets r'"
     and restrict_indets_times: "restrict_indets (p * q) = restrict_indets p * restrict_indets q"
     and restrict_indets_power: "restrict_indets (p ^ n) = restrict_indets p ^ n"
     and restrict_indets_sum: "restrict_indets (sum f A) = (\<Sum>a\<in>A. restrict_indets (f a))"
     and restrict_indets_prod: "restrict_indets (prod f A) = (\<Prod>a\<in>A. restrict_indets (f a))"
   by (simp_all add: restrict_indets_def poly_subst_monomial poly_subst_plus poly_subst_uminus
       poly_subst_minus poly_subst_times poly_subst_power poly_subst_sum poly_subst_prod
       subst_pp_restrict_indets_subst punit.monom_mult_monomial)
 
 lemma restrict_extend_indets [simp]: "restrict_indets (extend_indets p) = p"
   unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
   by (rule poly_subst_id)
     (simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)
 
 lemma extend_restrict_indets:
   assumes "None \<notin> indets p"
   shows "extend_indets (restrict_indets p) = p"
   unfolding extend_indets_def restrict_indets_def poly_subst_poly_subst
 proof (rule poly_subst_id)
   fix x
   assume "x \<in> indets p"
   with assms have "x \<noteq> None" by meson
   then obtain y where x: "x = Some y" by blast
   thus "poly_subst extend_indets_subst (monomial 1 (restrict_indets_subst x)) =
          monomial 1 (Poly_Mapping.single x 1)"
     by (simp add: extend_indets_subst_def restrict_indets_subst_def poly_subst_monomial subst_pp_single)
 qed
 
 lemma restrict_indets_dehomogenize [simp]: "restrict_indets (dehomogenize None p) = restrict_indets p"
 proof -
   have eq: "poly_subst (\<lambda>x. (monomial 1 (restrict_indets_subst x))) (dehomo_subst None y) =
             monomial 1 (restrict_indets_subst y)" for y::"'x option"
     by (auto simp: restrict_indets_subst_def dehomo_subst_def poly_subst_monomial subst_pp_single)
   show ?thesis by (simp only: dehomogenize_def restrict_indets_def poly_subst_poly_subst eq) 
 qed
 
 corollary restrict_indets_comp_dehomogenize: "restrict_indets \<circ> dehomogenize None = restrict_indets"
   by (rule ext) (simp only: o_def restrict_indets_dehomogenize)
 
 corollary extend_restrict_indets_eq_dehomogenize:
   "extend_indets (restrict_indets p) = dehomogenize None p"
 proof -
   have "extend_indets (restrict_indets p) = extend_indets (restrict_indets (dehomogenize None p))"
     by simp
   also have "\<dots> = dehomogenize None p"
   proof (intro extend_restrict_indets notI)
     assume "None \<in> indets (dehomogenize None p)"
     hence "None \<in> indets p - {None}" using indets_dehomogenize ..
     thus False by simp
   qed
   finally show ?thesis .
 qed
 
 corollary extend_indets_comp_restrict_indets: "extend_indets \<circ> restrict_indets = dehomogenize None"
   by (rule ext) (simp only: o_def extend_restrict_indets_eq_dehomogenize)
 
 lemma restrict_homogenize_extend_indets [simp]:
   "restrict_indets (homogenize None (extend_indets p)) = p"
 proof -
   have "restrict_indets (homogenize None (extend_indets p)) =
           restrict_indets (dehomogenize None (homogenize None (extend_indets p)))"
     by (simp only: restrict_indets_dehomogenize)
   also have "\<dots> = restrict_indets (dehomogenize None (extend_indets p))"
     by (simp only: dehomogenize_homogenize)
   also have "\<dots> = p" by simp
   finally show ?thesis .
 qed
 
 lemma dehomogenize_extend_indets [simp]: "dehomogenize None (extend_indets p) = extend_indets p"
   by (simp add: indets_extend_indets)
 
 lemma restrict_indets_ideal: "restrict_indets ` ideal F = ideal (restrict_indets ` F)"
   using restrict_indets_plus restrict_indets_times
 proof (rule image_ideal_eq_surj)
   from restrict_extend_indets show "surj restrict_indets" by (rule surjI)
 qed
 
 lemma ideal_restrict_indets:
   "ideal G = ideal (homogenize None ` extend_indets ` F) \<Longrightarrow> ideal (restrict_indets ` G) = ideal F"
   by (simp flip: restrict_indets_ideal) (simp add: restrict_indets_ideal image_image)
 
 lemma extend_indets_ideal: "extend_indets ` ideal F = ideal (extend_indets ` F) \<inter> P[- {None}]"
 proof -
   have "extend_indets ` ideal F = extend_indets ` restrict_indets ` ideal (extend_indets ` F)"
     by (simp add: restrict_indets_ideal image_image)
   also have "\<dots> = ideal (extend_indets ` F) \<inter> P[- {None}]"
     by (simp add: extend_restrict_indets_eq_dehomogenize dehomogenize_ideal image_image)
   finally show ?thesis .
 qed
 
 corollary extend_indets_ideal_subset: "extend_indets ` ideal F \<subseteq> ideal (extend_indets ` F)"
   by (simp add: extend_indets_ideal)
 
 subsection \<open>Canonical Isomorphisms between \<open>P[X,Y]\<close> and \<open>P[X][Y]\<close>: \<open>focus\<close> and \<open>flatten\<close>\<close>
 
 definition focus :: "'x set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_monoid_add)"
   where "focus X p = (\<Sum>t\<in>keys p. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"
 
 definition flatten :: "('a \<Rightarrow>\<^sub>0 'a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a::comm_powerprod \<Rightarrow>\<^sub>0 'b::semiring_1)"
   where "flatten p = (\<Sum>t\<in>keys p. punit.monom_mult 1 t (lookup p t))"
 
 lemma focus_superset:
   assumes "finite A" and "keys p \<subseteq> A"
   shows "focus X p = (\<Sum>t\<in>A. monomial (monomial (lookup p t) (except t X)) (except t (- X)))"
   unfolding focus_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)
 
 lemma keys_focus: "keys (focus X p) = (\<lambda>t. except t (- X)) ` keys p"
 proof
   have "keys (focus X p) \<subseteq> (\<Union>t\<in>keys p. keys (monomial (monomial (lookup p t) (except t X)) (except t (- X))))"
     unfolding focus_def by (rule keys_sum_subset)
   also have "\<dots> \<subseteq> (\<Union>t\<in>keys p. {except t (- X)})" by (intro UN_mono subset_refl) simp
   also have "\<dots> = (\<lambda>t. except t (- X)) ` keys p" by (rule UNION_singleton_eq_range)
   finally show "keys (focus X p) \<subseteq> (\<lambda>t. except t (- X)) ` keys p" .
 next
   {
     fix s
     assume "s \<in> keys p"
     have "lookup (focus X p) (except s (- X)) =
               (\<Sum>t\<in>keys p. monomial (lookup p t) (except t X) when except t (- X) = except s (- X))"
       (is "_ = ?p")
       by (simp only: focus_def lookup_sum lookup_single)
     also have "\<dots> \<noteq> 0"
     proof
       have "lookup ?p (except s X) =
               (\<Sum>t\<in>keys p. lookup p t when except t X = except s X \<and> except t (- X) = except s (- X))"
         by (simp add: lookup_sum lookup_single when_def if_distrib if_distribR)
             (metis (no_types, hide_lams) lookup_single_eq lookup_single_not_eq lookup_zero)
       also have "\<dots> = (\<Sum>t\<in>{s}. lookup p t)"
       proof (intro sum.mono_neutral_cong_right ballI)
         fix t
         assume "t \<in> keys p - {s}"
         hence "t \<noteq> s" by simp
         hence "except t X + except t (- X) \<noteq> except s X + except s (- X)"
           by (simp flip: except_decomp)
         thus "(lookup p t when except t X = except s X \<and> except t (- X) = except s (- X)) = 0"
           by (auto simp: when_def)
       next
         from \<open>s \<in> keys p\<close> show "{s} \<subseteq> keys p" by simp
       qed simp_all
       also from \<open>s \<in> keys p\<close> have "\<dots> \<noteq> 0" by (simp add: in_keys_iff)
       finally have "except s X \<in> keys ?p" by (simp add: in_keys_iff)
       moreover assume "?p = 0"
       ultimately show False by simp
     qed
     finally have "except s (- X) \<in> keys (focus X p)" by (simp add: in_keys_iff)
   }
   thus "(\<lambda>t. except t (- X)) ` keys p \<subseteq> keys (focus X p)" by blast
 qed
 
 lemma keys_coeffs_focus_subset:
   assumes "c \<in> range (lookup (focus X p))"
   shows "keys c \<subseteq> (\<lambda>t. except t X) ` keys p"
 proof -
   from assms obtain s where "c = lookup (focus X p) s" ..
   hence "keys c = keys (lookup (focus X p) s)" by (simp only:)
   also have "\<dots> \<subseteq> (\<Union>t\<in>keys p. keys (lookup (monomial (monomial (lookup p t) (except t X)) (except t (- X))) s))"
     unfolding focus_def lookup_sum by (rule keys_sum_subset)
   also from subset_refl have "\<dots> \<subseteq> (\<Union>t\<in>keys p. {except t X})"
     by (rule UN_mono) (simp add: lookup_single when_def)
   also have "\<dots> = (\<lambda>t. except t X) ` keys p" by (rule UNION_singleton_eq_range)
   finally show ?thesis .
 qed
 
 lemma focus_in_Polys':
   assumes "p \<in> P[Y]"
   shows "focus X p \<in> P[Y \<inter> X]"
 proof (intro PolysI subsetI)
   fix t
   assume "t \<in> keys (focus X p)"
   then obtain s where "s \<in> keys p" and t: "t = except s (- X)" unfolding keys_focus ..
   note this(1)
   also from assms have "keys p \<subseteq> .[Y]" by (rule PolysD)
   finally have "keys s \<subseteq> Y" by (rule PPsD)
   hence "keys t \<subseteq> Y \<inter> X" by (simp add: t keys_except le_infI1)
   thus "t \<in> .[Y \<inter> X]" by (rule PPsI)
 qed
 
 corollary focus_in_Polys: "focus X p \<in> P[X]"
 proof -
   have "p \<in> P[UNIV]" by simp
   hence "focus X p \<in> P[UNIV \<inter> X]" by (rule focus_in_Polys')
   thus ?thesis by simp
 qed
 
 lemma focus_coeffs_subset_Polys':
   assumes "p \<in> P[Y]"
   shows "range (lookup (focus X p)) \<subseteq> P[Y - X]"
 proof (intro subsetI PolysI)
   fix c t
   assume "c \<in> range (lookup (focus X p))"
   hence "keys c \<subseteq> (\<lambda>t. except t X) ` keys p" by (rule keys_coeffs_focus_subset)
   moreover assume "t \<in> keys c"
   ultimately have "t \<in> (\<lambda>t. except t X) ` keys p" ..
   then obtain s where "s \<in> keys p" and t: "t = except s X" ..
   note this(1)
   also from assms have "keys p \<subseteq> .[Y]" by (rule PolysD)
   finally have "keys s \<subseteq> Y" by (rule PPsD)
   hence "keys t \<subseteq> Y - X" by (simp add: t keys_except Diff_mono)
   thus "t \<in> .[Y - X]" by (rule PPsI)
 qed
 
 corollary focus_coeffs_subset_Polys: "range (lookup (focus X p)) \<subseteq> P[- X]"
 proof -
   have "p \<in> P[UNIV]" by simp
   hence "range (lookup (focus X p)) \<subseteq> P[UNIV - X]" by (rule focus_coeffs_subset_Polys')
   thus ?thesis by (simp only: Compl_eq_Diff_UNIV)
 qed
 
 corollary lookup_focus_in_Polys: "lookup (focus X p) t \<in> P[- X]"
   using focus_coeffs_subset_Polys by blast
 
 lemma focus_zero [simp]: "focus X 0 = 0"
   by (simp add: focus_def)
 
 lemma focus_eq_zero_iff [iff]: "focus X p = 0 \<longleftrightarrow> p = 0"
   by (simp only: keys_focus flip: keys_eq_empty_iff) simp
 
 lemma focus_one [simp]: "focus X 1 = 1"
   by (simp add: focus_def)
 
 lemma focus_monomial: "focus X (monomial c t) = monomial (monomial c (except t X)) (except t (- X))"
   by (simp add: focus_def)
 
 lemma focus_uminus [simp]: "focus X (- p) = - focus X p"
   by (simp add: focus_def keys_uminus single_uminus sum_negf)
 
 lemma focus_plus: "focus X (p + q) = focus X p + focus X q"
 proof -
   have "finite (keys p \<union> keys q)" by simp
   moreover have "keys (p + q) \<subseteq> keys p \<union> keys q" by (rule Poly_Mapping.keys_add)
   ultimately show ?thesis
     by (simp add: focus_superset[where A="keys p \<union> keys q"] lookup_add single_add sum.distrib)
 qed
 
 lemma focus_minus: "focus X (p - q) = focus X p - focus X (q::_ \<Rightarrow>\<^sub>0 _::ab_group_add)"
   by (simp only: diff_conv_add_uminus focus_plus focus_uminus)
 
 lemma focus_times: "focus X (p * q) = focus X p * focus X q"
 proof -
   have eq: "focus X (monomial c s * q) = focus X (monomial c s) * focus X q" for c s
   proof -
     have "focus X (monomial c s * q) = focus X (punit.monom_mult c s q)"
       by (simp only: times_monomial_left)
     also have "\<dots> = (\<Sum>t\<in>(+) s ` keys q. monomial (monomial (lookup (punit.monom_mult c s q) t)
                                             (except t X)) (except t (- X)))"
       by (rule focus_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
     also have "\<dots> = (\<Sum>t\<in>keys q. ((\<lambda>t. monomial (monomial (lookup (punit.monom_mult c s q) t)
                                   (except t X)) (except t (- X))) \<circ> ((+) s)) t)"
       by (rule sum.reindex) simp
     also have "\<dots> = monomial (monomial c (except s X)) (except s (- X)) *
                       (\<Sum>t\<in>keys q. monomial (monomial (lookup q t) (except t X)) (except t (- X)))"
       by (simp add: o_def punit.lookup_monom_mult except_plus times_monomial_monomial sum_distrib_left)
     also have "\<dots> = focus X (monomial c s) * focus X q"
       by (simp only: focus_monomial focus_def[where p=q])
     finally show ?thesis .
   qed
   show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs focus_plus eq)
 qed
 
 lemma focus_sum: "focus X (sum f I) = (\<Sum>i\<in>I. focus X (f i))"
   by (induct I rule: infinite_finite_induct) (simp_all add: focus_plus)
 
 lemma focus_prod: "focus X (prod f I) = (\<Prod>i\<in>I. focus X (f i))"
   by (induct I rule: infinite_finite_induct) (simp_all add: focus_times)
 
 lemma focus_power [simp]: "focus X (f ^ m) = focus X f ^ m"
   by (induct m) (simp_all add: focus_times)
 
 lemma focus_Polys:
   assumes "p \<in> P[X]"
   shows "focus X p = (\<Sum>t\<in>keys p. monomial (monomial (lookup p t) 0) t)"
   unfolding focus_def
 proof (rule sum.cong)
   fix t
   assume "t \<in> keys p"
   also from assms have "\<dots> \<subseteq> .[X]" by (rule PolysD)
   finally have "keys t \<subseteq> X" by (rule PPsD)
   hence "except t X = 0" and "except t (- X) = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
   thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
         monomial (monomial (lookup p t) 0) t" by simp
 qed (fact refl)
 
 corollary lookup_focus_Polys: "p \<in> P[X] \<Longrightarrow> lookup (focus X p) t = monomial (lookup p t) 0"
   by (simp add: focus_Polys lookup_sum lookup_single when_def in_keys_iff)
 
 lemma focus_Polys_Compl:
   assumes "p \<in> P[- X]"
   shows "focus X p = monomial p 0"
 proof -
   have "focus X p = (\<Sum>t\<in>keys p. monomial (monomial (lookup p t) t) 0)" unfolding focus_def
   proof (rule sum.cong)
     fix t
     assume "t \<in> keys p"
     also from assms have "\<dots> \<subseteq> .[- X]" by (rule PolysD)
     finally have "keys t \<subseteq> - X" by (rule PPsD)
     hence "except t (- X) = 0" and "except t X = t" by (rule except_eq_zeroI, auto simp: except_id_iff)
     thus "monomial (monomial (lookup p t) (except t X)) (except t (- X)) =
           monomial (monomial (lookup p t) t) 0" by simp
   qed (fact refl)
   also have "\<dots> = monomial (\<Sum>t\<in>keys p. monomial (lookup p t) t) 0" by (simp only: monomial_sum)
   also have "\<dots> = monomial p 0" by (simp only: poly_mapping_sum_monomials)
   finally show ?thesis .
 qed
 
 corollary focus_empty [simp]: "focus {} p = monomial p 0"
   by (rule focus_Polys_Compl) simp
 
 lemma focus_Int:
   assumes "p \<in> P[Y]"
   shows "focus (X \<inter> Y) p = focus X p"
   unfolding focus_def using refl
 proof (rule sum.cong)
   fix t
   assume "t \<in> keys p"
   also from assms have "\<dots> \<subseteq> .[Y]" by (rule PolysD)
   finally have "keys t \<subseteq> Y" by (rule PPsD)
   hence "keys t \<subseteq> X \<union> Y" by blast
   hence "except t (X \<inter> Y) = except t X + except t Y" by (rule except_Int)
   also from \<open>keys t \<subseteq> Y\<close> have "except t Y = 0" by (rule except_eq_zeroI)
   finally have eq: "except t (X \<inter> Y) = except t X" by simp
   have "except t (- (X \<inter> Y)) = except (except t (- Y)) (- X)" by (simp add: except_except Un_commute)
   also from \<open>keys t \<subseteq> Y\<close> have "except t (- Y) = t" by (auto simp: except_id_iff)
   finally show "monomial (monomial (lookup p t) (except t (X \<inter> Y))) (except t (- (X \<inter> Y))) =
                 monomial (monomial (lookup p t) (except t X)) (except t (- X))" by (simp only: eq)
 qed
 
 lemma range_focusD:
   assumes "p \<in> range (focus X)"
   shows "p \<in> P[X]" and "range (lookup p) \<subseteq> P[- X]" and "lookup p t \<in> P[- X]"
   using assms by (auto intro: focus_in_Polys lookup_focus_in_Polys)
 
 lemma range_focusI:
   assumes "p \<in> P[X]" and "lookup p ` keys (p::_ \<Rightarrow>\<^sub>0 _ \<Rightarrow>\<^sub>0 _::semiring_1) \<subseteq> P[- X]"
   shows "p \<in> range (focus X)"
   using assms
 proof (induct p rule: poly_mapping_plus_induct_Polys)
   case 0
   show ?case by simp
 next
   case (plus p c t)
   from plus.hyps(3) have 1: "keys (monomial c t) = {t}" by simp
   also from plus.hyps(4) have "\<dots> \<inter> keys p = {}" by simp
   finally have "keys (monomial c t + p) = keys (monomial c t) \<union> keys p" by (rule keys_add[symmetric])
   hence 2: "keys (monomial c t + p) = insert t (keys p)" by (simp only: 1 flip: insert_is_Un)
   from \<open>t \<in> .[X]\<close> have "keys t \<subseteq> X" by (rule PPsD)
   hence eq1: "except t X = 0" and eq2: "except t (- X) = t"
     by (rule except_eq_zeroI, auto simp: except_id_iff)
   from plus.hyps(3, 4) plus.prems have "c \<in> P[- X]" and "lookup p ` keys p \<subseteq> P[- X]"
     by (simp_all add: 2 lookup_add lookup_single in_keys_iff)
         (smt add.commute add.right_neutral image_cong plus.hyps(4) when_simps(2))
   from this(2) have "p \<in> range (focus X)" by (rule plus.hyps)
   then obtain q where p: "p = focus X q" ..
   moreover from \<open>c \<in> P[- X]\<close> have "monomial c t = focus X (monomial 1 t * c)"
     by (simp add: focus_times focus_monomial eq1 eq2 focus_Polys_Compl times_monomial_monomial)
   ultimately have "monomial c t + p = focus X (monomial 1 t * c + q)" by (simp only: focus_plus)
   thus ?case by (rule range_eqI)
 qed
 
 lemma inj_focus: "inj ((focus X) :: (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::ab_group_add) \<Rightarrow> _)"
 proof (rule injI)
   fix p q :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a"
   assume "focus X p = focus X q"
   hence "focus X (p - q) = 0" by (simp add: focus_minus)
   thus "p = q" by simp
 qed
 
 lemma flatten_superset:
   assumes "finite A" and "keys p \<subseteq> A"
   shows "flatten p = (\<Sum>t\<in>A. punit.monom_mult 1 t (lookup p t))"
   unfolding flatten_def using assms by (rule sum.mono_neutral_left) (simp add: in_keys_iff)
 
 lemma keys_flatten_subset: "keys (flatten p) \<subseteq> (\<Union>t\<in>keys p. (+) t ` keys (lookup p t))"
 proof -
   have "keys (flatten p) \<subseteq> (\<Union>t\<in>keys p. keys (punit.monom_mult 1 t (lookup p t)))"
     unfolding flatten_def by (rule keys_sum_subset)
   also from subset_refl have "\<dots> \<subseteq> (\<Union>t\<in>keys p. (+) t ` keys (lookup p t))"
     by (rule UN_mono) (rule punit.keys_monom_mult_subset[simplified])
   finally show ?thesis .
 qed
 
 lemma flatten_in_Polys:
   assumes "p \<in> P[X]" and "lookup p ` keys p \<subseteq> P[Y]"
   shows "flatten p \<in> P[X \<union> Y]"
 proof (intro PolysI subsetI)
   fix t
   assume "t \<in> keys (flatten p)"
   also have "\<dots> \<subseteq> (\<Union>t\<in>keys p. (+) t ` keys (lookup p t))" by (rule keys_flatten_subset)
   finally obtain s where "s \<in> keys p" and "t \<in> (+) s ` keys (lookup p s)" ..
   from this(2) obtain s' where "s' \<in> keys (lookup p s)" and t: "t = s + s'" ..
   from assms(1) have "keys p \<subseteq> .[X]" by (rule PolysD)
   with \<open>s \<in> keys p\<close> have "s \<in> .[X]" ..
   also have "\<dots> \<subseteq> .[X \<union> Y]" by (rule PPs_mono) simp
   finally have 1: "s \<in> .[X \<union> Y]" .
   from \<open>s \<in> keys p\<close> have "lookup p s \<in> lookup p ` keys p" by (rule imageI)
   also have "\<dots> \<subseteq> P[Y]" by fact
   finally have "keys (lookup p s) \<subseteq> .[Y]" by (rule PolysD)
   with \<open>s' \<in> _\<close> have "s' \<in> .[Y]" ..
   also have "\<dots> \<subseteq> .[X \<union> Y]" by (rule PPs_mono) simp
   finally have "s' \<in> .[X \<union> Y]" .
   with 1 show "t \<in> .[X \<union> Y]" unfolding t by (rule PPs_closed_plus)
 qed
 
 lemma flatten_zero [simp]: "flatten 0 = 0"
   by (simp add: flatten_def)
 
 lemma flatten_one [simp]: "flatten 1 = 1"
   by (simp add: flatten_def)
 
 lemma flatten_monomial: "flatten (monomial c t) = punit.monom_mult 1 t c"
   by (simp add: flatten_def)
 
 lemma flatten_uminus [simp]: "flatten (- p) = - flatten (p::_ \<Rightarrow>\<^sub>0 _ \<Rightarrow>\<^sub>0 _::ring)"
   by (simp add: flatten_def keys_uminus punit.monom_mult_uminus_right sum_negf)
 
 lemma flatten_plus: "flatten (p + q) = flatten p + flatten q"
 proof -
   have "finite (keys p \<union> keys q)" by simp
   moreover have "keys (p + q) \<subseteq> keys p \<union> keys q" by (rule Poly_Mapping.keys_add)
   ultimately show ?thesis
     by (simp add: flatten_superset[where A="keys p \<union> keys q"] punit.monom_mult_dist_right lookup_add
                   sum.distrib)
 qed
 
 lemma flatten_minus: "flatten (p - q) = flatten p - flatten (q::_ \<Rightarrow>\<^sub>0 _ \<Rightarrow>\<^sub>0 _::ring)"
   by (simp only: diff_conv_add_uminus flatten_plus flatten_uminus)
 
 lemma flatten_times: "flatten (p * q) = flatten p * flatten (q::_ \<Rightarrow>\<^sub>0 _ \<Rightarrow>\<^sub>0 'b::comm_semiring_1)"
 proof -
   have eq: "flatten (monomial c s * q) = flatten (monomial c s) * flatten q" for c s
   proof -
     have eq: "monomial 1 (t + s) = monomial 1 s * monomial (1::'b) t" for t
       by (simp add: times_monomial_monomial add.commute)
     have "flatten (monomial c s * q) = flatten (punit.monom_mult c s q)"
       by (simp only: times_monomial_left)
     also have "\<dots> = (\<Sum>t\<in>(+) s ` keys q. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t))"
       by (rule flatten_superset) (simp_all add: punit.keys_monom_mult_subset[simplified])
     also have "\<dots> = (\<Sum>t\<in>keys q. ((\<lambda>t. punit.monom_mult 1 t (lookup (punit.monom_mult c s q) t)) \<circ> (+) s) t)"
       by (rule sum.reindex) simp
     thm times_monomial_left
     also have "\<dots> = punit.monom_mult 1 s c *
                       (\<Sum>t\<in>keys q. punit.monom_mult 1 t (lookup q t))"
       by (simp add: o_def punit.lookup_monom_mult sum_distrib_left)
           (simp add: algebra_simps eq flip: times_monomial_left)
     also have "\<dots> = flatten (monomial c s) * flatten q"
       by (simp only: flatten_monomial flatten_def[where p=q])
     finally show ?thesis .
   qed
   show ?thesis by (induct p rule: poly_mapping_plus_induct) (simp_all add: ring_distribs flatten_plus eq)
 qed
 
 lemma flatten_monom_mult:
   "flatten (punit.monom_mult c t p) = punit.monom_mult 1 t (c * flatten (p::_ \<Rightarrow>\<^sub>0 _ \<Rightarrow>\<^sub>0 'b::comm_semiring_1))"
   by (simp only: flatten_times flatten_monomial mult.assoc flip: times_monomial_left)
 
 lemma flatten_sum: "flatten (sum f I) = (\<Sum>i\<in>I. flatten (f i))"
   by (induct I rule: infinite_finite_induct) (simp_all add: flatten_plus)
 
 lemma flatten_prod: "flatten (prod f I) = (\<Prod>i\<in>I. flatten (f i :: _ \<Rightarrow>\<^sub>0 _::comm_semiring_1))"
   by (induct I rule: infinite_finite_induct) (simp_all add: flatten_times)
 
 lemma flatten_power [simp]: "flatten (f ^ m) = flatten (f:: _ \<Rightarrow>\<^sub>0 _::comm_semiring_1) ^ m"
   by (induct m) (simp_all add: flatten_times)
 
 lemma surj_flatten: "surj flatten"
 proof (rule surjI)
   fix p
   show "flatten (monomial p 0) = p" by (simp add: flatten_monomial)
 qed
 
 lemma flatten_focus [simp]: "flatten (focus X p) = p"
   by (induct p rule: poly_mapping_plus_induct)
       (simp_all add: focus_plus flatten_plus focus_monomial flatten_monomial
                       punit.monom_mult_monomial add.commute flip: except_decomp)
 
 lemma focus_flatten:
   assumes "p \<in> P[X]" and "lookup p ` keys p \<subseteq> P[- X]"
   shows "focus X (flatten p) = p"
 proof -
   from assms have "p \<in> range (focus X)" by (rule range_focusI)
   then obtain q where "p = focus X q" ..
   thus ?thesis by simp
 qed
 
 lemma image_focus_ideal: "focus X ` ideal F = ideal (focus X ` F) \<inter> range (focus X)"
 proof
   from focus_plus focus_times have "focus X ` ideal F \<subseteq> ideal (focus X ` F)"
     by (rule image_ideal_subset)
   moreover from subset_UNIV have "focus X ` ideal F \<subseteq> range (focus X)" by (rule image_mono)
   ultimately show "focus X ` ideal F \<subseteq> ideal (focus X ` F) \<inter> range (focus X)" by blast
 next
   show "ideal (focus X ` F) \<inter> range (focus X) \<subseteq> focus X ` ideal F"
   proof
     fix p
     assume "p \<in> ideal (focus X ` F) \<inter> range (focus X)"
     hence "p \<in> ideal (focus X ` F)" and "p \<in> range (focus X)" by simp_all
     from this(1) obtain F0 q where "F0 \<subseteq> focus X ` F" and p: "p = (\<Sum>f'\<in>F0. q f' * f')"
       by (rule ideal.spanE)
     from this(1) obtain F' where "F' \<subseteq> F" and F0: "F0 = focus X ` F'" by (rule subset_imageE)
     from inj_focus subset_UNIV have "inj_on (focus X) F'" by (rule inj_on_subset)
     from \<open>p \<in> range _\<close> obtain p' where "p = focus X p'" ..
     hence "p = focus X (flatten p)" by simp
     also from \<open>inj_on _ F'\<close> have "\<dots> = focus X (\<Sum>f'\<in>F'. flatten (q (focus X f')) * f')"
       by (simp add: p F0 sum.reindex flatten_sum flatten_times)
     finally have "p = focus X (\<Sum>f'\<in>F'. flatten (q (focus X f')) * f')" .
     moreover have "(\<Sum>f'\<in>F'. flatten (q (focus X f')) * f') \<in> ideal F"
     proof
       show "(\<Sum>f'\<in>F'. flatten (q (focus X f')) * f') \<in> ideal F'" by (rule ideal.sum_in_spanI)
     next
       from \<open>F' \<subseteq> F\<close> show "ideal F' \<subseteq> ideal F" by (rule ideal.span_mono)
     qed
     ultimately show "p \<in> focus X ` ideal F" by (rule image_eqI)
   qed
 qed
 
 lemma image_flatten_ideal: "flatten ` ideal F = ideal (flatten ` F)"
   using flatten_plus flatten_times surj_flatten by (rule image_ideal_eq_surj)
 
 lemma poly_eval_focus:
   "poly_eval a (focus X p) = poly_subst (\<lambda>x. if x \<in> X then a x else monomial 1 (Poly_Mapping.single x 1)) p"
 proof -
   let ?b = "\<lambda>x. if x \<in> X then a x else monomial 1 (Poly_Mapping.single x 1)"
   have *: "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
               (subst_pp (\<lambda>x. monomial (a x) 0) (except t (- X)))) 0 =
             punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" for t
   proof -
     have 1: "subst_pp ?b (except t X) = monomial 1 (except t X)"
       by (rule subst_pp_id) (simp add: keys_except)
     from refl have 2: "subst_pp ?b (except t (- X)) = subst_pp a (except t (-X))"
       by (rule subst_pp_cong) (simp add: keys_except)
     have "lookup (punit.monom_mult (monomial (lookup p t) (except t X)) 0
                       (subst_pp (\<lambda>x. monomial (a x) 0) (except t (- X)))) 0 =
           punit.monom_mult (lookup p t) (except t X) (subst_pp a (except t (- X)))"
       by (simp add: lookup_times_zero subst_pp_def lookup_prod_zero lookup_power_zero
                 flip: times_monomial_left)
     also have "\<dots> = punit.monom_mult (lookup p t) 0 (monomial 1 (except t X) * subst_pp a (except t (- X)))"
       by (simp add: times_monomial_monomial flip: times_monomial_left mult.assoc)
     also have "\<dots> = punit.monom_mult (lookup p t) 0 (subst_pp ?b (except t X + except t (- X)))"
       by (simp only: subst_pp_plus 1 2)
     also have "\<dots> = punit.monom_mult (lookup p t) 0 (subst_pp ?b t)" by (simp flip: except_decomp)
     finally show ?thesis .
   qed
   show ?thesis by (simp add: poly_eval_def focus_def poly_subst_sum lookup_sum poly_subst_monomial *
                         flip: poly_subst_def)
 qed
 
 corollary poly_eval_poly_eval_focus:
   "poly_eval a (poly_eval b (focus X p)) = poly_eval (\<lambda>x::'x. if x \<in> X then poly_eval a (b x) else a x) p"
 proof -
   have eq: "monomial (lookup (poly_subst (\<lambda>y. monomial (a y) (0::'x \<Rightarrow>\<^sub>0 nat)) q) 0) 0 =
               poly_subst (\<lambda>y. monomial (a y) (0::'x \<Rightarrow>\<^sub>0 nat)) q" for q
     by (intro poly_deg_zero_imp_monomial poly_deg_poly_subst_eq_zeroI) simp
   show ?thesis unfolding poly_eval_focus
     by (simp add: poly_eval_def poly_subst_poly_subst if_distrib poly_subst_monomial subst_pp_single eq
             cong: if_cong)
 qed
 
 lemma indets_poly_eval_focus_subset:
   "indets (poly_eval a (focus X p)) \<subseteq> \<Union> (indets ` a ` X) \<union> (indets p - X)"
 proof
   fix x
   assume "x \<in> indets (poly_eval a (focus X p))"
   also have "\<dots> = indets (poly_subst (\<lambda>x. if x \<in> X then a x else monomial 1 (Poly_Mapping.single x 1)) p)"
     (is "_ = indets (poly_subst ?f _)") by (simp only: poly_eval_focus)
   finally obtain y where "y \<in> indets p" and "x \<in> indets (?f y)" by (rule in_indets_poly_substE)
   from this(2) have "(x \<notin> X \<and> x = y) \<or> (y \<in> X \<and> x \<in> indets (a y))"
     by (simp add: indets_monomial split: if_split_asm)
   thus "x \<in> \<Union> (indets ` a ` X) \<union> (indets p - X)"
   proof (elim disjE conjE)
     assume "x \<notin> X" and "x = y"
     with \<open>y \<in> indets p\<close> have "x \<in> indets p - X" by simp
     thus ?thesis ..
   next
     assume "y \<in> X" and "x \<in> indets (a y)"
     hence "x \<in> \<Union> (indets ` a ` X)" by blast
     thus ?thesis ..
   qed
 qed
 
 lemma lookup_poly_eval_focus:
   "lookup (poly_eval (\<lambda>x. monomial (a x) 0) (focus X p)) t = poly_eval a (lookup (focus (- X) p) t)"
 proof -
   let ?f = "\<lambda>x. if x \<in> X then monomial (a x) 0 else monomial 1 (Poly_Mapping.single x 1)"
   have eq: "subst_pp ?f s = monomial (\<Prod>x\<in>keys s \<inter> X. a x ^ lookup s x) (except s X)" for s
   proof -
     have "subst_pp ?f s = (\<Prod>x\<in>(keys s \<inter> X) \<union> (keys s - X). ?f x ^ lookup s x)"
       unfolding subst_pp_def by (rule prod.cong) blast+
     also have "\<dots> = (\<Prod>x\<in>keys s \<inter> X. ?f x ^ lookup s x) * (\<Prod>x\<in>keys s - X. ?f x ^ lookup s x)"
       by (rule prod.union_disjoint) auto
     also have "\<dots> = monomial (\<Prod>x\<in>keys s \<inter> X. a x ^ lookup s x)
                               (\<Sum>x\<in>keys s - X. Poly_Mapping.single x (lookup s x))"
       by (simp add: monomial_power_map_scale times_monomial_monomial flip: punit.monomial_prod_sum)
     also have "(\<Sum>x\<in>keys s - X. Poly_Mapping.single x (lookup s x)) = except s X"
       by (metis (mono_tags, lifting) DiffD2 keys_except lookup_except_eq_idI
               poly_mapping_sum_monomials sum.cong)
     finally show ?thesis .
   qed
   show ?thesis
     by (simp add: poly_eval_focus poly_subst_def lookup_sum eq flip: punit.map_scale_eq_monom_mult)
        (simp add: focus_def lookup_sum poly_eval_sum lookup_single when_distrib poly_eval_monomial
                   keys_except lookup_except_when)
 qed
 
 lemma keys_poly_eval_focus_subset:
   "keys (poly_eval (\<lambda>x. monomial (a x) 0) (focus X p)) \<subseteq> (\<lambda>t. except t X) ` keys p"
 proof
   fix t
   assume "t \<in> keys (poly_eval (\<lambda>x. monomial (a x) 0) (focus X p))"
   hence "lookup (poly_eval (\<lambda>x. monomial (a x) 0) (focus X p)) t \<noteq> 0" by (simp add: in_keys_iff)
   hence "poly_eval a (lookup (focus (- X) p) t) \<noteq> 0" by (simp add: lookup_poly_eval_focus)
   hence "t \<in> keys (focus (- X) p)" by (auto simp flip: lookup_not_eq_zero_eq_in_keys)
   thus "t \<in> (\<lambda>t. except t X) ` keys p" by (simp add: keys_focus)
 qed
 
 lemma poly_eval_focus_in_Polys:
   assumes "p \<in> P[X]"
   shows "poly_eval (\<lambda>x. monomial (a x) 0) (focus Y p) \<in> P[X - Y]"
 proof (rule PolysI_alt)
   have "indets (poly_eval (\<lambda>x. monomial (a x) 0) (focus Y p)) \<subseteq>
           \<Union> (indets ` (\<lambda>x. monomial (a x) 0) ` Y) \<union> (indets p - Y)"
     by (fact indets_poly_eval_focus_subset)
   also have "\<dots> = indets p - Y" by simp
   also from assms have "\<dots> \<subseteq> X - Y" by (auto dest: PolysD)
   finally show "indets (poly_eval (\<lambda>x. monomial (a x) 0) (focus Y p)) \<subseteq> X - Y" .
 qed
 
 lemma image_poly_eval_focus_ideal:
   "poly_eval (\<lambda>x. monomial (a x) 0) ` focus X ` ideal F =
     ideal (poly_eval (\<lambda>x. monomial (a x) 0) ` focus X ` F) \<inter>
       (P[- X]::(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) set)"
 proof -
   let ?h = "\<lambda>f. poly_eval (\<lambda>x. monomial (a x) 0) (focus X f)"
   have h_id: "?h p = p" if "p \<in> P[- X]" for p
   proof -
     from that have "focus X p \<in> P[- X \<inter> X]" by (rule focus_in_Polys')
     also have "\<dots> = P[{}]" by simp
     finally obtain c where eq: "focus X p = monomial c 0" unfolding Polys_empty ..
     hence "flatten (focus X p) = flatten (monomial c 0)" by (rule arg_cong)
     hence "c = p" by (simp add: flatten_monomial)
     thus "?h p = p" by (simp add: eq poly_eval_monomial)
   qed
   have rng: "range ?h = P[- X]"
   proof (intro subset_antisym subsetI, elim rangeE)
     fix b f
     assume b: "b = ?h f"
     have "?h f \<in> P[UNIV - X]" by (rule poly_eval_focus_in_Polys) simp
     thus "b \<in> P[- X]" by (simp add: b Compl_eq_Diff_UNIV)
   next
     fix p :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a"
     assume "p \<in> P[- X]"
     hence "?h p = p" by (rule h_id)
     hence "p = ?h p" by (rule sym)
     thus "p \<in> range ?h" by (rule range_eqI)
   qed
   have "poly_eval (\<lambda>x. monomial (a x) 0) ` focus X ` ideal F = ?h ` ideal F" by (fact image_image)
   also have "\<dots> = ideal (?h ` F) \<inter> range ?h"
   proof (rule image_ideal_eq_Int)
     fix p
     have "?h p \<in> range ?h" by (fact rangeI)
     also have "\<dots> = P[- X]" by fact
     finally show "?h (?h p) = ?h p" by (rule h_id)
   qed (simp_all only: focus_plus poly_eval_plus focus_times poly_eval_times)
   also have "\<dots> = ideal (poly_eval (\<lambda>x. monomial (a x) 0) ` focus X ` F) \<inter> P[- X]"
     by (simp only: image_image rng)
   finally show ?thesis .
 qed
 
 subsection \<open>Locale @{term pm_powerprod}\<close>
 
 lemma varnum_eq_zero_iff: "varnum X t = 0 \<longleftrightarrow> t \<in> .[X]"
   by (auto simp: varnum_def PPs_def)
 
 lemma dgrad_set_varnum: "dgrad_set (varnum X) 0 = .[X]"
   by (simp add: dgrad_set_def PPs_def varnum_eq_zero_iff)
 
 context ordered_powerprod
 begin
 
 abbreviation "lcf \<equiv> punit.lc"
 abbreviation "tcf \<equiv> punit.tc"
 abbreviation "lpp \<equiv> punit.lt"
 abbreviation "tpp \<equiv> punit.tt"
 
 end (* ordered_powerprod *)
 
 locale pm_powerprod =
   ordered_powerprod ord ord_strict
   for ord::"('x::{countable,linorder} \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool" (infixl "\<preceq>" 50)
   and ord_strict (infixl "\<prec>" 50)
 begin
 
 sublocale gd_powerprod ..
 
 lemma PPs_closed_lpp:
   assumes "p \<in> P[X]"
   shows "lpp p \<in> .[X]"
 proof (cases "p = 0")
   case True
   thus ?thesis by (simp add: zero_in_PPs)
 next
   case False
   hence "lpp p \<in> keys p" by (rule punit.lt_in_keys)
   also from assms have "\<dots> \<subseteq> .[X]" by (rule PolysD)
   finally show ?thesis .
 qed
 
 lemma PPs_closed_tpp:
   assumes "p \<in> P[X]"
   shows "tpp p \<in> .[X]"
 proof (cases "p = 0")
   case True
   thus ?thesis by (simp add: zero_in_PPs)
 next
   case False
   hence "tpp p \<in> keys p" by (rule punit.tt_in_keys)
   also from assms have "\<dots> \<subseteq> .[X]" by (rule PolysD)
   finally show ?thesis .
 qed
 
 corollary PPs_closed_image_lpp: "F \<subseteq> P[X] \<Longrightarrow> lpp ` F \<subseteq> .[X]"
   by (auto intro: PPs_closed_lpp)
 
 corollary PPs_closed_image_tpp: "F \<subseteq> P[X] \<Longrightarrow> tpp ` F \<subseteq> .[X]"
   by (auto intro: PPs_closed_tpp)
 
 lemma hom_component_lpp:
   assumes "p \<noteq> 0"
   shows "hom_component p (deg_pm (lpp p)) \<noteq> 0" (is "?p \<noteq> 0")
     and "lpp (hom_component p (deg_pm (lpp p))) = lpp p"
 proof -
   from assms have "lpp p \<in> keys p" by (rule punit.lt_in_keys)
   hence *: "lpp p \<in> keys ?p" by (simp add: keys_hom_component)
   thus "?p \<noteq> 0" by auto
 
   from * show "lpp ?p = lpp p"
   proof (rule punit.lt_eqI_keys)
     fix t
     assume "t \<in> keys ?p"
     hence "t \<in> keys p" by (simp add: keys_hom_component)
     thus "t \<preceq> lpp p" by (rule punit.lt_max_keys)
   qed
 qed
 
 definition is_hom_ord :: "'x \<Rightarrow> bool"
   where "is_hom_ord x \<longleftrightarrow> (\<forall>s t. deg_pm s = deg_pm t \<longrightarrow> (s \<preceq> t \<longleftrightarrow> except s {x} \<preceq> except t {x}))"
 
 lemma is_hom_ordD: "is_hom_ord x \<Longrightarrow> deg_pm s = deg_pm t \<Longrightarrow> s \<preceq> t \<longleftrightarrow> except s {x} \<preceq> except t {x}"
   by (simp add: is_hom_ord_def)
 
 lemma dgrad_p_set_varnum: "punit.dgrad_p_set (varnum X) 0 = P[X]"
   by (simp add: punit.dgrad_p_set_def dgrad_set_varnum Polys_def)
 
 end
 
 text \<open>We must create a copy of @{locale pm_powerprod} to avoid infinite chains of interpretations.\<close>
 
 instantiation option :: (linorder) linorder
 begin
 
 fun less_eq_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
   "less_eq_option None _ = True" |
   "less_eq_option (Some x) None = False" |
   "less_eq_option (Some x) (Some y) = (x \<le> y)"
 
 definition less_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
   where "less_option x y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
 
 instance proof
   fix x :: "'a option"
   show "x \<le> x" using less_eq_option.elims(3) by fastforce
 qed (auto simp: less_option_def elim!: less_eq_option.elims)
 
 end
 
 locale extended_ord_pm_powerprod = pm_powerprod
 begin
 
 definition extended_ord :: "('a option \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('a option \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool"
   where "extended_ord s t \<longleftrightarrow> (restrict_indets_pp s \<prec> restrict_indets_pp t \<or>
                           (restrict_indets_pp s = restrict_indets_pp t \<and> lookup s None \<le> lookup t None))"
 
 definition extended_ord_strict :: "('a option \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('a option \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool"
   where "extended_ord_strict s t \<longleftrightarrow> (restrict_indets_pp s \<prec> restrict_indets_pp t \<or>
                           (restrict_indets_pp s = restrict_indets_pp t \<and> lookup s None < lookup t None))"
 
 sublocale extended_ord: pm_powerprod extended_ord extended_ord_strict
 proof -
   have 1: "s = t" if "lookup s None = lookup t None" and "restrict_indets_pp s = restrict_indets_pp t"
     for s t :: "'a option \<Rightarrow>\<^sub>0 nat"
   proof (rule poly_mapping_eqI)
     fix y
     show "lookup s y = lookup t y"
     proof (cases y)
       case None
       with that(1) show ?thesis by simp
     next
       case y: (Some z)
       have "lookup s y = lookup (restrict_indets_pp s) z" by (simp only: lookup_restrict_indets_pp y)
       also have "\<dots> = lookup (restrict_indets_pp t) z" by (simp only: that(2))
       also have "\<dots> = lookup t y" by (simp only: lookup_restrict_indets_pp y)
       finally show ?thesis .
     qed
   qed
   have 2: "0 \<prec> t" if "t \<noteq> 0" for t::"'a \<Rightarrow>\<^sub>0 nat"
     using that zero_min by (rule ordered_powerprod_lin.dual_order.not_eq_order_implies_strict)
   show "pm_powerprod extended_ord extended_ord_strict"
     by standard (auto simp: extended_ord_def extended_ord_strict_def restrict_indets_pp_plus lookup_add 1
                   dest: plus_monotone_strict 2)
 qed
 
 lemma extended_ord_is_hom_ord: "extended_ord.is_hom_ord None"
   by (auto simp add: extended_ord_def lookup_restrict_indets_pp lookup_except extended_ord.is_hom_ord_def
             simp flip: deg_pm_restrict_indets_pp)
 
 end
 
 end (* theory *)
diff --git a/thys/Transition_Systems_and_Automata/Automata/DBA/DBA_Combine.thy b/thys/Transition_Systems_and_Automata/Automata/DBA/DBA_Combine.thy
--- a/thys/Transition_Systems_and_Automata/Automata/DBA/DBA_Combine.thy
+++ b/thys/Transition_Systems_and_Automata/Automata/DBA/DBA_Combine.thy
@@ -1,303 +1,304 @@
 section \<open>Deterministic Büchi Automata Combinations\<close>
 
 theory DBA_Combine
 imports "DBA" "DGBA"
 begin
 
   definition dbgail :: "('label, 'state) dba list \<Rightarrow> ('label, 'state list) dgba" where
     "dbgail AA \<equiv> dgba
-      (INTER (set AA) dba.alphabet)
+      (\<Inter> (dba.alphabet ` set AA))
       (map dba.initial AA)
       (\<lambda> a pp. map2 (\<lambda> A p. dba.transition A a p) AA pp)
       (map (\<lambda> k pp. dba.accepting (AA ! k) (pp ! k)) [0 ..< length AA])"
 
   lemma dbgail_trace_smap:
     assumes "length pp = length AA" "k < length AA"
     shows "smap (\<lambda> pp. pp ! k) (dgba.trace (dbgail AA) w pp) = dba.trace (AA ! k) w (pp ! k)"
     using assms unfolding dbgail_def by (coinduction arbitrary: w pp) (force)
   lemma dbgail_nodes_length:
     assumes "pp \<in> DGBA.nodes (dbgail AA)"
     shows "length pp = length AA"
     using assms unfolding dbgail_def by induct auto
   lemma dbgail_nodes[intro]:
     assumes "pp \<in> DGBA.nodes (dbgail AA)" "k < length pp"
     shows "pp ! k \<in> DBA.nodes (AA ! k)"
     using assms unfolding dbgail_def by induct auto
 
   lemma dbgail_nodes_finite[intro]:
     assumes "list_all (finite \<circ> DBA.nodes) AA"
     shows "finite (DGBA.nodes (dbgail AA))"
   proof (rule finite_subset)
     show "DGBA.nodes (dbgail AA) \<subseteq> listset (map DBA.nodes AA)"
       by (force simp: listset_member list_all2_conv_all_nth dbgail_nodes_length)
     have "finite (listset (map DBA.nodes AA)) \<longleftrightarrow> list_all finite (map DBA.nodes AA)"
       by (rule listset_finite) (auto simp: list_all_iff)
     then show "finite (listset (map DBA.nodes AA))" using assms by (simp add: list.pred_map)
   qed
   lemma dbgail_nodes_card:
     assumes "list_all (finite \<circ> DBA.nodes) AA"
     shows "card (DGBA.nodes (dbgail AA)) \<le> prod_list (map (card \<circ> DBA.nodes) AA)"
   proof -
     have "card (DGBA.nodes (dbgail AA)) \<le> card (listset (map DBA.nodes AA))"
     proof (rule card_mono)
       have "finite (listset (map DBA.nodes AA)) \<longleftrightarrow> list_all finite (map DBA.nodes AA)"
         by (rule listset_finite) (auto simp: list_all_iff)
       then show "finite (listset (map DBA.nodes AA))" using assms by (simp add: list.pred_map)
       show "DGBA.nodes (dbgail AA) \<subseteq> listset (map DBA.nodes AA)"
         by (force simp: listset_member list_all2_conv_all_nth dbgail_nodes_length)
     qed
     also have "\<dots> = prod_list (map (card \<circ> DBA.nodes) AA)" by simp
     finally show ?thesis by this
   qed
 
-  lemma dbgail_language[simp]: "DGBA.language (dbgail AA) = INTER (set AA) DBA.language"
+  lemma dbgail_language[simp]: "DGBA.language (dbgail AA) = \<Inter> (DBA.language ` set AA)"
   proof safe
     fix w A
     assume 1: "w \<in> DGBA.language (dbgail AA)" "A \<in> set AA"
     obtain 2:
       "dgba.run (dbgail AA) w (dgba.initial (dbgail AA))"
       "gen infs (dgba.accepting (dbgail AA)) (dgba.trace (dbgail AA) w (dgba.initial (dbgail AA)))"
       using 1(1) by rule
     obtain k where 3: "A = AA ! k" "k < length AA" using 1(2) unfolding in_set_conv_nth by auto
     have 4: "(\<lambda> pp. dba.accepting A (pp ! k)) \<in> set (dgba.accepting (dbgail AA))"
       using 3 unfolding dbgail_def by auto
     show "w \<in> DBA.language A"
     proof
       show "dba.run A w (dba.initial A)"
         using 1(2) 2(1) unfolding DBA.run_alt_def DGBA.run_alt_def dbgail_def by auto
       have "True \<longleftrightarrow> infs (\<lambda> pp. dba.accepting A (pp ! k)) (dgba.trace (dbgail AA) w (map dba.initial AA))"
         using 2(2) 4 unfolding dbgail_def by auto
       also have "\<dots> \<longleftrightarrow> infs (dba.accepting A) (smap (\<lambda> pp. pp ! k)
         (dgba.trace (dbgail AA) w (map dba.initial AA)))" by (simp add: comp_def)
       also have "smap (\<lambda> pp. pp ! k) (dgba.trace (dbgail AA) w (map dba.initial AA)) =
         dba.trace (AA ! k) w (map dba.initial AA ! k)" using 3(2) by (fastforce intro: dbgail_trace_smap)
       also have "\<dots> = dba.trace A w (dba.initial A)" using 3 by auto
       finally show "infs (dba.accepting A) (dba.trace A w (dba.initial A))" by simp
     qed
   next
     fix w
-    assume 1: "w \<in> INTER (set AA) DBA.language"
+    assume 1: "w \<in> \<Inter> (DBA.language ` set AA)"
     have 2: "dba.run A w (dba.initial A)" "infs (dba.accepting A) (dba.trace A w (dba.initial A))"
       if "A \<in> set AA" for A using 1 that by auto
     show "w \<in> DGBA.language (dbgail AA)"
     proof (intro DGBA.language ballI gen)
       show "dgba.run (dbgail AA) w (dgba.initial (dbgail AA))"
         using 2(1) unfolding DBA.run_alt_def DGBA.run_alt_def dbgail_def by auto
     next
       fix P
       assume 3: "P \<in> set (dgba.accepting (dbgail AA))"
       obtain k where 4: "P = (\<lambda> pp. dba.accepting (AA ! k) (pp ! k))" "k < length AA"
         using 3 unfolding dbgail_def by auto
       have "True \<longleftrightarrow> infs (dba.accepting (AA ! k)) (dba.trace (AA ! k) w (map dba.initial AA ! k))"
         using 2(2) 4(2) by auto
       also have "dba.trace (AA ! k) w (map dba.initial AA ! k) =
         smap (\<lambda> pp. pp ! k) (dgba.trace (dbgail AA) w (map dba.initial AA))"
         using 4(2) by (fastforce intro: dbgail_trace_smap[symmetric])
       also have "infs (dba.accepting (AA ! k)) \<dots> \<longleftrightarrow> infs P (dgba.trace (dbgail AA) w (map dba.initial AA))"
         unfolding 4(1) by (simp add: comp_def)
       also have "map dba.initial AA = dgba.initial (dbgail AA)" unfolding dbgail_def by simp
       finally show "infs P (dgba.trace (dbgail AA) w (dgba.initial (dbgail AA)))" by simp
     qed
   qed
 
   definition dbail :: "('label, 'state) dba list \<Rightarrow> ('label, 'state list degen) dba" where
     "dbail = dgbad \<circ> dbgail"
 
   lemma dbail_nodes_finite[intro]:
     assumes "list_all (finite \<circ> DBA.nodes) AA"
     shows "finite (DBA.nodes (dbail AA))"
     using dbgail_nodes_finite assms unfolding dbail_def by auto
   lemma dbail_nodes_card:
     assumes"list_all (finite \<circ> DBA.nodes) AA"
     shows "card (DBA.nodes (dbail AA)) \<le> max 1 (length AA) * prod_list (map (card \<circ> DBA.nodes) AA)"
   proof -
     have "card (DBA.nodes (dbail AA)) \<le>
       max 1 (length (dgba.accepting (dbgail AA))) * card (DGBA.nodes (dbgail AA))"
       unfolding dbail_def using dgbad_nodes_card by simp
     also have "length (dgba.accepting (dbgail AA)) = length AA" unfolding dbgail_def by simp
     also have "card (DGBA.nodes (dbgail AA)) \<le> prod_list (map (card \<circ> DBA.nodes) AA)"
       using dbgail_nodes_card assms by this
     finally show ?thesis by simp
   qed
 
-  lemma dbail_language[simp]: "DBA.language (dbail AA) = INTER (set AA) DBA.language"
-    unfolding dbail_def using dgbad_language dbgail_language by auto
+  lemma dbail_language [simp]:
+    "DBA.language (dbail AA) = \<Inter> (DBA.language ` set AA)"
+    by (simp add: dbail_def)
 
   definition dbau :: "('label, 'state\<^sub>1) dba \<Rightarrow> ('label, 'state\<^sub>2) dba \<Rightarrow>
     ('label, 'state\<^sub>1 \<times> 'state\<^sub>2) dba" where
     "dbau A B \<equiv> dba
       (dba.alphabet A \<union> dba.alphabet B)
       (dba.initial A, dba.initial B)
       (\<lambda> a (p, q). (dba.transition A a p, dba.transition B a q))
       (\<lambda> (p, q). dba.accepting A p \<or> dba.accepting B q)"
 
   (* TODO: can these be extracted as more general theorems about sscan? *)
   lemma dbau_fst[iff]: "infs (P \<circ> fst) (dba.trace (dbau A B) w (p, q)) \<longleftrightarrow> infs P (dba.trace A w p)"
   proof -
     let ?t = "dba.trace (dbau A B) w (p, q)"
     have "infs (P \<circ> fst) ?t \<longleftrightarrow> infs P (smap fst ?t)" by (simp add: comp_def)
     also have "smap fst ?t = dba.trace A w p" unfolding dbau_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dbau_snd[iff]: "infs (P \<circ> snd) (dba.trace (dbau A B) w (p, q)) \<longleftrightarrow> infs P (dba.trace B w q)"
   proof -
     let ?t = "dba.trace (dbau A B) w (p, q)"
     have "infs (P \<circ> snd) ?t \<longleftrightarrow> infs P (smap snd ?t)" by (simp add: comp_def)
     also have "smap snd ?t = dba.trace B w q" unfolding dbau_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dbau_nodes_fst[intro]:
     assumes "dba.alphabet A = dba.alphabet B"
     shows "fst ` DBA.nodes (dbau A B) \<subseteq> DBA.nodes A"
   proof (rule subsetI, erule imageE)
     fix pq p
     assume "pq \<in> DBA.nodes (dbau A B)" "p = fst pq"
     then show "p \<in> DBA.nodes A" using assms unfolding dbau_def by (induct arbitrary: p) (auto)
   qed
   lemma dbau_nodes_snd[intro]:
     assumes "dba.alphabet A = dba.alphabet B"
     shows "snd ` DBA.nodes (dbau A B) \<subseteq> DBA.nodes B"
   proof (rule subsetI, erule imageE)
     fix pq q
     assume "pq \<in> DBA.nodes (dbau A B)" "q = snd pq"
     then show "q \<in> DBA.nodes B" using assms unfolding dbau_def by (induct arbitrary: q) (auto)
   qed
 
   lemma dbau_nodes_finite[intro]:
     assumes "dba.alphabet A = dba.alphabet B"
     assumes "finite (DBA.nodes A)" "finite (DBA.nodes B)"
     shows "finite (DBA.nodes (dbau A B))"
   proof (rule finite_subset)
     show "DBA.nodes (dbau A B) \<subseteq> DBA.nodes A \<times> DBA.nodes B"
       using dbau_nodes_fst[OF assms(1)] dbau_nodes_snd[OF assms(1)] unfolding image_subset_iff by force
     show "finite (DBA.nodes A \<times> DBA.nodes B)" using assms(2, 3) by simp
   qed
   lemma dbau_nodes_card[intro]:
     assumes "dba.alphabet A = dba.alphabet B"
     assumes "finite (DBA.nodes A)" "finite (DBA.nodes B)"
     shows "card (DBA.nodes (dbau A B)) \<le> card (DBA.nodes A) * card (DBA.nodes B)"
   proof -
     have "card (DBA.nodes (dbau A B)) \<le> card (DBA.nodes A \<times> DBA.nodes B)"
     proof (rule card_mono)
       show "finite (DBA.nodes A \<times> DBA.nodes B)" using assms(2, 3) by simp
       show "DBA.nodes (dbau A B) \<subseteq> DBA.nodes A \<times> DBA.nodes B"
         using dbau_nodes_fst[OF assms(1)] dbau_nodes_snd[OF assms(1)] unfolding image_subset_iff by force
     qed
     also have "\<dots> = card (DBA.nodes A) * card (DBA.nodes B)" using card_cartesian_product by this
     finally show ?thesis by this
   qed
 
   lemma dbau_language[simp]:
     assumes "dba.alphabet A = dba.alphabet B"
     shows "DBA.language (dbau A B) = DBA.language A \<union> DBA.language B"
   proof -
     have 1: "dba.alphabet (dbau A B) = dba.alphabet A \<union> dba.alphabet B" unfolding dbau_def by simp
     have 2: "dba.initial (dbau A B) = (dba.initial A, dba.initial B)" unfolding dbau_def by simp
     have 3: "dba.accepting (dbau A B) = (\<lambda> pq. (dba.accepting A \<circ> fst) pq \<or> (dba.accepting B \<circ> snd) pq)"
       unfolding dbau_def by auto
     have 4: "infs (dba.accepting (dbau A B)) (DBA.trace (dbau A B) w (p, q)) \<longleftrightarrow>
       infs (dba.accepting A) (DBA.trace A w p) \<or> infs (dba.accepting B) (DBA.trace B w q)" for w p q
       unfolding 3 by blast
     show ?thesis using assms unfolding DBA.language_def DBA.run_alt_def 1 2 4 by auto
   qed
 
   definition dbaul :: "('label, 'state) dba list \<Rightarrow> ('label, 'state list) dba" where
     "dbaul AA \<equiv> dba
-      (UNION (set AA) dba.alphabet)
+      (\<Union> (dba.alphabet ` set AA))
       (map dba.initial AA)
       (\<lambda> a pp. map2 (\<lambda> A p. dba.transition A a p) AA pp)
       (\<lambda> pp. \<exists> k < length AA. dba.accepting (AA ! k) (pp ! k))"
 
   lemma dbaul_trace_smap:
     assumes "length pp = length AA" "k < length AA"
     shows "smap (\<lambda> pp. pp ! k) (dba.trace (dbaul AA) w pp) = dba.trace (AA ! k) w (pp ! k)"
     using assms unfolding dbaul_def by (coinduction arbitrary: w pp) (force)
   lemma dbaul_nodes_length:
     assumes "pp \<in> DBA.nodes (dbaul AA)"
     shows "length pp = length AA"
     using assms unfolding dbaul_def by induct auto
   lemma dbaul_nodes[intro]:
-    assumes "INTER (set AA) dba.alphabet = UNION (set AA) dba.alphabet"
+    assumes "\<Inter> (dba.alphabet ` set AA) = \<Union> (dba.alphabet ` set AA)"
     assumes "pp \<in> DBA.nodes (dbaul AA)" "k < length pp"
     shows "pp ! k \<in> DBA.nodes (AA ! k)"
     using assms(2, 3, 1) unfolding dbaul_def by induct force+
 
   lemma dbaul_nodes_finite[intro]:
-    assumes "INTER (set AA) dba.alphabet = UNION (set AA) dba.alphabet"
+    assumes "\<Inter> (dba.alphabet ` set AA) = \<Union> (dba.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DBA.nodes) AA"
     shows "finite (DBA.nodes (dbaul AA))"
   proof (rule finite_subset)
     show "DBA.nodes (dbaul AA) \<subseteq> listset (map DBA.nodes AA)"
       using assms(1) by (force simp: listset_member list_all2_conv_all_nth dbaul_nodes_length)
     have "finite (listset (map DBA.nodes AA)) \<longleftrightarrow> list_all finite (map DBA.nodes AA)"
       by (rule listset_finite) (auto simp: list_all_iff)
     then show "finite (listset (map DBA.nodes AA))" using assms(2) by (simp add: list.pred_map)
   qed
   lemma dbaul_nodes_card:
-    assumes "INTER (set AA) dba.alphabet = UNION (set AA) dba.alphabet"
+    assumes "\<Inter> (dba.alphabet ` set AA) = \<Union> (dba.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DBA.nodes) AA"
     shows "card (DBA.nodes (dbaul AA)) \<le> prod_list (map (card \<circ> DBA.nodes) AA)"
   proof -
     have "card (DBA.nodes (dbaul AA)) \<le> card (listset (map DBA.nodes AA))"
     proof (rule card_mono)
       have "finite (listset (map DBA.nodes AA)) \<longleftrightarrow> list_all finite (map DBA.nodes AA)"
         by (rule listset_finite) (auto simp: list_all_iff)
       then show "finite (listset (map DBA.nodes AA))" using assms(2) by (simp add: list.pred_map)
       show "DBA.nodes (dbaul AA) \<subseteq> listset (map DBA.nodes AA)"
         using assms(1) by (force simp: listset_member list_all2_conv_all_nth dbaul_nodes_length)
     qed
     also have "\<dots> = prod_list (map (card \<circ> DBA.nodes) AA)" by simp
     finally show ?thesis by this
   qed
 
   lemma dbaul_language[simp]:
-    assumes "INTER (set AA) dba.alphabet = UNION (set AA) dba.alphabet"
-    shows "DBA.language (dbaul AA) = UNION (set AA) DBA.language"
+    assumes "\<Inter> (dba.alphabet ` set AA) = \<Union> (dba.alphabet ` set AA)"
+    shows "DBA.language (dbaul AA) = \<Union> (DBA.language ` set AA)"
   proof safe
     fix w
     assume 1: "w \<in> DBA.language (dbaul AA)"
     obtain 2:
       "dba.run (dbaul AA) w (dba.initial (dbaul AA))"
       "infs (dba.accepting (dbaul AA)) (dba.trace (dbaul AA) w (dba.initial (dbaul AA)))"
       using 1 by rule
     obtain k where 3:
       "k < length AA"
       "infs (\<lambda> pp. dba.accepting (AA ! k) (pp ! k)) (dba.trace (dbaul AA) w (map dba.initial AA))"
       using 2(2) unfolding dbaul_def by auto
-    show "w \<in> UNION (set AA) DBA.language"
+    show "w \<in> \<Union> (DBA.language ` set AA)"
     proof (intro UN_I DBA.language)
       show "AA ! k \<in> set AA" using 3(1) by simp
       show "dba.run (AA ! k) w (dba.initial (AA ! k))"
         using assms 2(1) 3(1) unfolding DBA.run_alt_def DGBA.run_alt_def dbaul_def by force
       have "True \<longleftrightarrow> infs (\<lambda> pp. dba.accepting (AA ! k) (pp ! k))
         (dba.trace (dbaul AA) w (map dba.initial AA))" using 3(2) by auto
       also have "\<dots> \<longleftrightarrow> infs (dba.accepting (AA ! k))
         (smap (\<lambda> pp. pp ! k) (dba.trace (dbaul AA) w (map dba.initial AA)))" by (simp add: comp_def)
       also have "smap (\<lambda> pp. pp ! k) (dba.trace (dbaul AA) w (map dba.initial AA)) =
         dba.trace (AA ! k) w (map dba.initial AA ! k)" using 3(1) by (fastforce intro: dbaul_trace_smap)
       also have "\<dots> = dba.trace (AA ! k) w (dba.initial (AA ! k))" using 3 by auto
       finally show "infs (dba.accepting (AA ! k)) (dba.trace (AA ! k) w (dba.initial (AA ! k)))" by simp
     qed
   next
     fix A w
     assume 1: "A \<in> set AA" "w \<in> DBA.language A"
     obtain 2: "dba.run A w (dba.initial A)" "infs (dba.accepting A) (dba.trace A w (dba.initial A))"
       using 1(2) by rule
     obtain k where 3: "A = AA ! k" "k < length AA" using 1(1) unfolding in_set_conv_nth by auto
     show "w \<in> DBA.language (dbaul AA)"
     proof
       show "dba.run (dbaul AA) w (dba.initial (dbaul AA))"
         using 1(1) 2(1) unfolding DBA.run_alt_def DGBA.run_alt_def dbaul_def by auto
       have "True \<longleftrightarrow> infs (dba.accepting (AA ! k)) (dba.trace (AA ! k) w (map dba.initial AA ! k))"
         using 2(2) 3 by auto
       also have "dba.trace (AA ! k) w (map dba.initial AA ! k) =
         smap (\<lambda> pp. pp ! k) (dba.trace (dbaul AA) w (map dba.initial AA))"
         using 3(2) by (fastforce intro: dbaul_trace_smap[symmetric])
       also have "infs (dba.accepting (AA ! k)) \<dots> \<longleftrightarrow> infs (\<lambda> pp. dba.accepting (AA ! k) (pp ! k))
         (dba.trace (dbaul AA) w (map dba.initial AA))" by (simp add: comp_def)
       finally show "infs (dba.accepting (dbaul AA)) (dba.trace (dbaul AA) w (dba.initial (dbaul AA)))"
         using 3(2) unfolding dbaul_def by auto
     qed
   qed
 
 end
\ No newline at end of file
diff --git a/thys/Transition_Systems_and_Automata/Automata/DCA/DCA_Combine.thy b/thys/Transition_Systems_and_Automata/Automata/DCA/DCA_Combine.thy
--- a/thys/Transition_Systems_and_Automata/Automata/DCA/DCA_Combine.thy
+++ b/thys/Transition_Systems_and_Automata/Automata/DCA/DCA_Combine.thy
@@ -1,298 +1,298 @@
 section \<open>Deterministic Co-Büchi Automata Combinations\<close>
 
 theory DCA_Combine
 imports "DCA" "DGCA"
 begin
 
   definition dcai :: "('label, 'state\<^sub>1) dca \<Rightarrow> ('label, 'state\<^sub>2) dca \<Rightarrow>
     ('label, 'state\<^sub>1 \<times> 'state\<^sub>2) dca" where
     "dcai A B \<equiv> dca
       (dca.alphabet A \<inter> dca.alphabet B)
       (dca.initial A, dca.initial B)
       (\<lambda> a (p, q). (dca.transition A a p, dca.transition B a q))
       (\<lambda> (p, q). dca.rejecting A p \<or> dca.rejecting B q)"
 
   lemma dcai_fst[iff]: "infs (P \<circ> fst) (dca.trace (dcai A B) w (p, q)) \<longleftrightarrow> infs P (dca.trace A w p)"
   proof -
     let ?t = "dca.trace (dcai A B) w (p, q)"
     have "infs (P \<circ> fst) ?t \<longleftrightarrow> infs P (smap fst ?t)" by (simp add: comp_def)
     also have "smap fst ?t = dca.trace A w p" unfolding dcai_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dcai_snd[iff]: "infs (P \<circ> snd) (dca.trace (dcai A B) w (p, q)) \<longleftrightarrow> infs P (dca.trace B w q)"
   proof -
     let ?t = "dca.trace (dcai A B) w (p, q)"
     have "infs (P \<circ> snd) ?t \<longleftrightarrow> infs P (smap snd ?t)" by (simp add: comp_def)
     also have "smap snd ?t = dca.trace B w q" unfolding dcai_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dcai_nodes_fst[intro]: "fst ` DCA.nodes (dcai A B) \<subseteq> DCA.nodes A"
   proof (rule subsetI, erule imageE)
     fix pq p
     assume "pq \<in> DCA.nodes (dcai A B)" "p = fst pq"
     then show "p \<in> DCA.nodes A" unfolding dcai_def by (induct arbitrary: p) (auto)
   qed
   lemma dcai_nodes_snd[intro]: "snd ` DCA.nodes (dcai A B) \<subseteq> DCA.nodes B"
   proof (rule subsetI, erule imageE)
     fix pq q
     assume "pq \<in> DCA.nodes (dcai A B)" "q = snd pq"
     then show "q \<in> DCA.nodes B" unfolding dcai_def by (induct arbitrary: q) (auto)
   qed
 
   lemma dcai_nodes_finite[intro]:
     assumes "finite (DCA.nodes A)" "finite (DCA.nodes B)"
     shows "finite (DCA.nodes (dcai A B))"
   proof (rule finite_subset)
     show "DCA.nodes (dcai A B) \<subseteq> DCA.nodes A \<times> DCA.nodes B"
       using dcai_nodes_fst dcai_nodes_snd unfolding image_subset_iff by force
     show "finite (DCA.nodes A \<times> DCA.nodes B)" using assms by simp
   qed
   lemma dcai_nodes_card[intro]:
     assumes "finite (DCA.nodes A)" "finite (DCA.nodes B)"
     shows "card (DCA.nodes (dcai A B)) \<le> card (DCA.nodes A) * card (DCA.nodes B)"
   proof -
     have "card (DCA.nodes (dcai A B)) \<le> card (DCA.nodes A \<times> DCA.nodes B)"
     proof (rule card_mono)
       show "finite (DCA.nodes A \<times> DCA.nodes B)" using assms by simp
       show "DCA.nodes (dcai A B) \<subseteq> DCA.nodes A \<times> DCA.nodes B"
         using dcai_nodes_fst dcai_nodes_snd unfolding image_subset_iff by force
     qed
     also have "\<dots> = card (DCA.nodes A) * card (DCA.nodes B)" using card_cartesian_product by this
     finally show ?thesis by this
   qed
 
   lemma dcai_language[simp]: "DCA.language (dcai A B) = DCA.language A \<inter> DCA.language B"
   proof -
     have 1: "dca.alphabet (dcai A B) = dca.alphabet A \<inter> dca.alphabet B" unfolding dcai_def by simp
     have 2: "dca.initial (dcai A B) = (dca.initial A, dca.initial B)" unfolding dcai_def by simp
     have 3: "dca.rejecting (dcai A B) = (\<lambda> pq. (dca.rejecting A \<circ> fst) pq \<or> (dca.rejecting B \<circ> snd) pq)"
       unfolding dcai_def by auto
     have 4: "infs (dca.rejecting (dcai A B)) (DCA.trace (dcai A B) w (p, q)) \<longleftrightarrow>
       infs (dca.rejecting A) (DCA.trace A w p) \<or> infs (dca.rejecting B) (DCA.trace B w q)" for w p q
       unfolding 3 by blast
     show ?thesis unfolding DCA.language_def DCA.run_alt_def 1 2 4 by auto
   qed
 
   definition dcail :: "('label, 'state) dca list \<Rightarrow> ('label, 'state list) dca" where
     "dcail AA \<equiv> dca
-      (INTER (set AA) dca.alphabet)
+      (\<Inter> (dca.alphabet ` set AA))
       (map dca.initial AA)
       (\<lambda> a pp. map2 (\<lambda> A p. dca.transition A a p) AA pp)
       (\<lambda> pp. \<exists> k < length AA. dca.rejecting (AA ! k) (pp ! k))"
 
   lemma dcail_trace_smap:
     assumes "length pp = length AA" "k < length AA"
     shows "smap (\<lambda> pp. pp ! k) (dca.trace (dcail AA) w pp) = dca.trace (AA ! k) w (pp ! k)"
     using assms unfolding dcail_def by (coinduction arbitrary: w pp) (force)
   lemma dcail_nodes_length:
     assumes "pp \<in> DCA.nodes (dcail AA)"
     shows "length pp = length AA"
     using assms unfolding dcail_def by induct auto
   lemma dcail_nodes[intro]:
     assumes "pp \<in> DCA.nodes (dcail AA)" "k < length pp"
     shows "pp ! k \<in> DCA.nodes (AA ! k)"
     using assms unfolding dcail_def by induct auto
 
   lemma dcail_finite[intro]:
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "finite (DCA.nodes (dcail AA))"
   proof (rule finite_subset)
     show "DCA.nodes (dcail AA) \<subseteq> listset (map DCA.nodes AA)"
       by (force simp: listset_member list_all2_conv_all_nth dcail_nodes_length)
     have "finite (listset (map DCA.nodes AA)) \<longleftrightarrow> list_all finite (map DCA.nodes AA)"
       by (rule listset_finite) (auto simp: list_all_iff)
     then show "finite (listset (map DCA.nodes AA))" using assms by (simp add: list.pred_map)
   qed
   lemma dcail_nodes_card:
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "card (DCA.nodes (dcail AA)) \<le> prod_list (map (card \<circ> DCA.nodes) AA)"
   proof -
     have "card (DCA.nodes (dcail AA)) \<le> card (listset (map DCA.nodes AA))"
     proof (rule card_mono)
       have "finite (listset (map DCA.nodes AA)) \<longleftrightarrow> list_all finite (map DCA.nodes AA)"
         by (rule listset_finite) (auto simp: list_all_iff)
       then show "finite (listset (map DCA.nodes AA))" using assms by (simp add: list.pred_map)
       show "DCA.nodes (dcail AA) \<subseteq> listset (map DCA.nodes AA)"
         by (force simp: listset_member list_all2_conv_all_nth dcail_nodes_length)
     qed
     also have "\<dots> = prod_list (map (card \<circ> DCA.nodes) AA)" by simp
     finally show ?thesis by this
   qed
 
-  lemma dcail_language[simp]: "DCA.language (dcail AA) = INTER (set AA) DCA.language"
+  lemma dcail_language[simp]: "DCA.language (dcail AA) = \<Inter> (DCA.language ` set AA)"
   proof safe
     fix A w
     assume 1: "w \<in> DCA.language (dcail AA)" "A \<in> set AA"
     obtain 2:
       "dca.run (dcail AA) w (dca.initial (dcail AA))"
       "fins (dca.rejecting (dcail AA)) (dca.trace (dcail AA) w (dca.initial (dcail AA)))"
       using 1(1) by rule
     obtain k where 3: "A = AA ! k" "k < length AA" using 1(2) unfolding in_set_conv_nth by auto
     have 4: "fins (\<lambda> pp. dca.rejecting A (pp ! k)) (dca.trace (dcail AA) w (map dca.initial AA))"
       using 2(2) 3 unfolding dcail_def by auto
     show "w \<in> DCA.language A"
     proof
       show "dca.run A w (dca.initial A)"
         using 1(2) 2(1) unfolding DCA.run_alt_def dcail_def by auto
       have "True \<longleftrightarrow> fins (\<lambda> pp. dca.rejecting A (pp ! k)) (dca.trace (dcail AA) w (map dca.initial AA))"
         using 4 by simp
       also have "\<dots> \<longleftrightarrow> fins (dca.rejecting A) (smap (\<lambda> pp. pp ! k)
         (dca.trace (dcail AA) w (map dca.initial AA)))" by (simp add: comp_def)
       also have "smap (\<lambda> pp. pp ! k) (dca.trace (dcail AA) w (map dca.initial AA)) =
         dca.trace (AA ! k) w (map dca.initial AA ! k)" using 3(2) by (fastforce intro: dcail_trace_smap)
       also have "\<dots> = dca.trace A w (dca.initial A)" using 3 by auto
       finally show "fins (dca.rejecting A) (DCA.trace A w (dca.initial A))" by simp
     qed
   next
     fix w
-    assume 1: "w \<in> INTER (set AA) DCA.language"
+    assume 1: "w \<in> \<Inter> (DCA.language `set AA)"
     have 2: "dca.run A w (dca.initial A)" "fins (dca.rejecting A) (dca.trace A w (dca.initial A))"
       if "A \<in> set AA" for A using 1 that by auto
     have 3: "fins (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k)) (dca.trace (dcail AA) w (map dca.initial AA))"
       if "k < length AA" for k
     proof -
       have "True \<longleftrightarrow> fins (dca.rejecting (AA ! k)) (dca.trace (AA ! k) w (map dca.initial AA ! k))"
         using 2(2) that by auto
       also have "dca.trace (AA ! k) w (map dca.initial AA ! k) =
         smap (\<lambda> pp. pp ! k) (dca.trace (dcail AA) w (map dca.initial AA))"
         using that by (fastforce intro: dcail_trace_smap[symmetric])
       also have "infs (dca.rejecting (AA ! k)) \<dots> \<longleftrightarrow> infs (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k))
         (dca.trace (dcail AA) w (map dca.initial AA))" by (simp add: comp_def)
       finally show ?thesis by simp
     qed
     show "w \<in> DCA.language (dcail AA)"
     proof
       show "dca.run (dcail AA) w (dca.initial (dcail AA))"
         using 2(1) unfolding DCA.run_alt_def dcail_def by auto
       show "fins (dca.rejecting (dcail AA)) (dca.trace (dcail AA) w (dca.initial (dcail AA)))"
         using 3 unfolding dcail_def by auto
     qed
   qed
 
   definition dcgaul :: "('label, 'state) dca list \<Rightarrow> ('label, 'state list) dgca" where
     "dcgaul AA \<equiv> dgca
-      (UNION (set AA) dca.alphabet)
+      (\<Union> (dca.alphabet ` set AA))
       (map dca.initial AA)
       (\<lambda> a pp. map2 (\<lambda> A p. dca.transition A a p) AA pp)
       (map (\<lambda> k pp. dca.rejecting (AA ! k) (pp ! k)) [0 ..< length AA])"
 
   lemma dcgaul_trace_smap:
     assumes "length pp = length AA" "k < length AA"
     shows "smap (\<lambda> pp. pp ! k) (dgca.trace (dcgaul AA) w pp) = dca.trace (AA ! k) w (pp ! k)"
     using assms unfolding dcgaul_def by (coinduction arbitrary: w pp) (force)
   lemma dcgaul_nodes_length:
     assumes "pp \<in> DGCA.nodes (dcgaul AA)"
     shows "length pp = length AA"
     using assms unfolding dcgaul_def by induct auto
   lemma dcgaul_nodes[intro]:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
     assumes "pp \<in> DGCA.nodes (dcgaul AA)" "k < length pp"
     shows "pp ! k \<in> DCA.nodes (AA ! k)"
     using assms(2, 3, 1) unfolding dcgaul_def by induct force+
 
   lemma dcgaul_nodes_finite[intro]:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "finite (DGCA.nodes (dcgaul AA))"
   proof (rule finite_subset)
     show "DGCA.nodes (dcgaul AA) \<subseteq> listset (map DCA.nodes AA)"
       using assms(1) by (force simp: listset_member list_all2_conv_all_nth dcgaul_nodes_length)
     have "finite (listset (map DCA.nodes AA)) \<longleftrightarrow> list_all finite (map DCA.nodes AA)"
       by (rule listset_finite) (auto simp: list_all_iff)
     then show "finite (listset (map DCA.nodes AA))" using assms(2) by (simp add: list.pred_map)
   qed
   lemma dcgaul_nodes_card:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "card (DGCA.nodes (dcgaul AA)) \<le> prod_list (map (card \<circ> DCA.nodes) AA)"
   proof -
     have "card (DGCA.nodes (dcgaul AA)) \<le> card (listset (map DCA.nodes AA))"
     proof (rule card_mono)
       have "finite (listset (map DCA.nodes AA)) \<longleftrightarrow> list_all finite (map DCA.nodes AA)"
         by (rule listset_finite) (auto simp: list_all_iff)
       then show "finite (listset (map DCA.nodes AA))" using assms(2) by (simp add: list.pred_map)
       show "DGCA.nodes (dcgaul AA) \<subseteq> listset (map DCA.nodes AA)"
         using assms(1) by (force simp: listset_member list_all2_conv_all_nth dcgaul_nodes_length)
     qed
     also have "\<dots> = prod_list (map (card \<circ> DCA.nodes) AA)" by simp
     finally show ?thesis by this
   qed
 
   lemma dcgaul_language[simp]:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
-    shows "DGCA.language (dcgaul AA) = UNION (set AA) DCA.language"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
+    shows "DGCA.language (dcgaul AA) = \<Union> (DCA.language ` set AA)"
   proof safe
     fix w
     assume 1: "w \<in> DGCA.language (dcgaul AA)"
     obtain k where 2:
       "dgca.run (dcgaul AA) w (dgca.initial (dcgaul AA))"
       "k < length AA"
       "fins (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k)) (dgca.trace (dcgaul AA) w (dgca.initial (dcgaul AA)))"
       using 1 unfolding dcgaul_def by force
-    show "w \<in> UNION (set AA) DCA.language"
+    show "w \<in> \<Union> (DCA.language ` set AA)"
     proof (intro UN_I DCA.language)
       show "AA ! k \<in> set AA" using 2(2) by simp
       show "dca.run (AA ! k) w (dca.initial (AA ! k))"
         using assms 2(1, 2) unfolding DCA.run_alt_def DGCA.run_alt_def dcgaul_def by force
       have "True \<longleftrightarrow> fins (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k))
         (dgca.trace (dcgaul AA) w (map dca.initial AA))" using 2(3) unfolding dcgaul_def by auto
       also have "\<dots> \<longleftrightarrow> fins (dca.rejecting (AA ! k))
         (smap (\<lambda> pp. pp ! k) (dgca.trace (dcgaul AA) w (map dca.initial AA)))" by (simp add: comp_def)
       also have "smap (\<lambda> pp. pp ! k) (dgca.trace (dcgaul AA) w (map dca.initial AA)) =
         dca.trace (AA ! k) w (map dca.initial AA ! k)" using 2(2) by (fastforce intro: dcgaul_trace_smap)
       also have "\<dots> = dca.trace (AA ! k) w (dca.initial (AA ! k))" using 2(2) by auto
       finally show "fins (dca.rejecting (AA ! k)) (dca.trace (AA ! k) w (dca.initial (AA ! k)))" by simp
     qed
   next
     fix A w
     assume 1: "A \<in> set AA" "w \<in> DCA.language A"
     obtain 2: "dca.run A w (dca.initial A)" "fins (dca.rejecting A) (dca.trace A w (dca.initial A))"
       using 1(2) by rule
     obtain k where 3: "A = AA ! k" "k < length AA" using 1(1) unfolding in_set_conv_nth by auto
     show "w \<in> DGCA.language (dcgaul AA)"
     proof (intro DGCA.language bexI cogen)
       show "dgca.run (dcgaul AA) w (dgca.initial (dcgaul AA))"
         using 1(1) 2(1) unfolding DCA.run_alt_def DGCA.run_alt_def dcgaul_def by auto
       have "True \<longleftrightarrow> fins (dca.rejecting (AA ! k)) (dca.trace (AA ! k) w (map dca.initial AA ! k))"
         using 2(2) 3 by auto
       also have "dca.trace (AA ! k) w (map dca.initial AA ! k) =
         smap (\<lambda> pp. pp ! k) (dgca.trace (dcgaul AA) w (map dca.initial AA))"
         using 3(2) by (fastforce intro: dcgaul_trace_smap[symmetric])
       also have "fins (dca.rejecting (AA ! k)) \<dots> \<longleftrightarrow> fins (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k))
         (dgca.trace (dcgaul AA) w (map dca.initial AA))" by (simp add: comp_def)
       also have "map dca.initial AA = dgca.initial (dcgaul AA)" unfolding dcgaul_def by simp
       finally show "fins (\<lambda> pp. dca.rejecting (AA ! k) (pp ! k)) (dgca.trace (dcgaul AA) w (dgca.initial (dcgaul AA)))"
         by simp
       show "(\<lambda> pp. dca.rejecting (AA ! k) (pp ! k)) \<in> set (dgca.rejecting (dcgaul AA))"
         unfolding dcgaul_def using 3(2) by simp
     qed
   qed
 
   definition dcaul :: "('label, 'state) dca list \<Rightarrow> ('label, 'state list degen) dca" where
     "dcaul = dgcad \<circ> dcgaul"
 
   lemma dcaul_nodes_finite[intro]:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "finite (DCA.nodes (dcaul AA))"
     using dcgaul_nodes_finite assms unfolding dcaul_def by auto
   lemma dcaul_nodes_card:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
+    assumes "\<Inter> (dca.alphabet ` set AA)  = \<Union> (dca.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DCA.nodes) AA"
     shows "card (DCA.nodes (dcaul AA)) \<le> max 1 (length AA) * prod_list (map (card \<circ> DCA.nodes) AA)"
   proof -
     have "card (DCA.nodes (dcaul AA)) \<le>
       max 1 (length (dgca.rejecting (dcgaul AA))) * card (DGCA.nodes (dcgaul AA))"
       unfolding dcaul_def using dgcad_nodes_card by simp
     also have "length (dgca.rejecting (dcgaul AA)) = length AA" unfolding dcgaul_def by simp
     also have "card (DGCA.nodes (dcgaul AA)) \<le> prod_list (map (card \<circ> DCA.nodes) AA)"
       using dcgaul_nodes_card assms by this
     finally show ?thesis by simp
   qed
 
   lemma dcaul_language[simp]:
-    assumes "INTER (set AA) dca.alphabet = UNION (set AA) dca.alphabet"
-    shows "DCA.language (dcaul AA) = UNION (set AA) DCA.language"
+    assumes "\<Inter> (dca.alphabet ` set AA) = \<Union> (dca.alphabet ` set AA)"
+    shows "DCA.language (dcaul AA) = \<Union> (DCA.language ` set AA)"
     unfolding dcaul_def using dgcad_language dcgaul_language[OF assms] by auto
 
 end
\ No newline at end of file
diff --git a/thys/Transition_Systems_and_Automata/Automata/DRA/DRA_Combine.thy b/thys/Transition_Systems_and_Automata/Automata/DRA/DRA_Combine.thy
--- a/thys/Transition_Systems_and_Automata/Automata/DRA/DRA_Combine.thy
+++ b/thys/Transition_Systems_and_Automata/Automata/DRA/DRA_Combine.thy
@@ -1,223 +1,223 @@
 section \<open>Deterministic Rabin Automata Combinations\<close>
 
 theory DRA_Combine
 imports "DRA" "../DBA/DBA" "../DCA/DCA"
 begin
 
   definition from_dba :: "('label, 'state) dba \<Rightarrow> ('label, 'state) dra" where
     "from_dba A \<equiv> dra (dba.alphabet A) (dba.initial A) (dba.transition A) [(dba.accepting A, bot)]"
 
   lemma from_dba_language[simp]: "DRA.language (from_dba A) = DBA.language A"
     unfolding DBA.language_def DRA.language_def from_dba_def DBA.run_def DRA.run_def by (auto 0 3)
 
   definition from_dca :: "('label, 'state) dca \<Rightarrow> ('label, 'state) dra" where
     "from_dca A \<equiv> dra (dca.alphabet A) (dca.initial A) (dca.transition A) [(top, dca.rejecting A)]"
 
   lemma from_dca_language[simp]: "DRA.language (from_dca A) = DCA.language A"
     unfolding DCA.language_def DRA.language_def from_dca_def DCA.run_def DRA.run_def by (auto 0 3)
 
   definition dbcrai :: "('label, 'state\<^sub>1) dba \<Rightarrow> ('label, 'state\<^sub>2) dca \<Rightarrow> ('label, 'state\<^sub>1 \<times> 'state\<^sub>2) dra" where
     "dbcrai A B \<equiv> dra
       (dba.alphabet A \<inter> dca.alphabet B)
       (dba.initial A, dca.initial B)
       (\<lambda> a (p, q). (dba.transition A a p, dca.transition B a q))
       [(dba.accepting A \<circ> fst, dca.rejecting B \<circ> snd)]"
 
   lemma dbcrai_fst[iff]: "infs (P \<circ> fst) (dra.trace (dbcrai A B) w (p, q)) \<longleftrightarrow> infs P (dba.trace A w p)"
   proof -
     let ?t = "dra.trace (dbcrai A B) w (p, q)"
     have "infs (P \<circ> fst) ?t \<longleftrightarrow> infs P (smap fst ?t)" by (simp add: comp_def)
     also have "smap fst ?t = dba.trace A w p" unfolding dbcrai_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dbcrai_snd[iff]: "infs (P \<circ> snd) (dra.trace (dbcrai A B) w (p, q)) \<longleftrightarrow> infs P (dca.trace B w q)"
   proof -
     let ?t = "dra.trace (dbcrai A B) w (p, q)"
     have "infs (P \<circ> snd) ?t \<longleftrightarrow> infs P (smap snd ?t)" by (simp add: comp_def)
     also have "smap snd ?t = dca.trace B w q" unfolding dbcrai_def by (coinduction arbitrary: w p q) (auto)
     finally show ?thesis by this
   qed
   lemma dbcrai_nodes_fst[intro]: "fst ` DRA.nodes (dbcrai A B) \<subseteq> DBA.nodes A"
   proof (rule subsetI, erule imageE)
     fix pq p
     assume "pq \<in> DRA.nodes (dbcrai A B)" "p = fst pq"
     then show "p \<in> DBA.nodes A" unfolding dbcrai_def by (induct arbitrary: p) (auto)
   qed
   lemma dbcrai_nodes_snd[intro]: "snd ` DRA.nodes (dbcrai A B) \<subseteq> DCA.nodes B"
   proof (rule subsetI, erule imageE)
     fix pq q
     assume "pq \<in> DRA.nodes (dbcrai A B)" "q = snd pq"
     then show "q \<in> DCA.nodes B" unfolding dbcrai_def by (induct arbitrary: q) (auto)
   qed
 
   lemma dbcrai_nodes_finite[intro]:
     assumes "finite (DBA.nodes A)" "finite (DCA.nodes B)"
     shows "finite (DRA.nodes (dbcrai A B))"
   proof (rule finite_subset)
     show "DRA.nodes (dbcrai A B) \<subseteq> DBA.nodes A \<times> DCA.nodes B"
       using dbcrai_nodes_fst dbcrai_nodes_snd unfolding image_subset_iff by force
     show "finite (DBA.nodes A \<times> DCA.nodes B)" using assms by simp
   qed
   lemma dbcrai_nodes_card[intro]:
     assumes "finite (DBA.nodes A)" "finite (DCA.nodes B)"
     shows "card (DRA.nodes (dbcrai A B)) \<le> card (DBA.nodes A) * card (DCA.nodes B)"
   proof -
     have "card (DRA.nodes (dbcrai A B)) \<le> card (DBA.nodes A \<times> DCA.nodes B)"
     proof (rule card_mono)
       show "finite (DBA.nodes A \<times> DCA.nodes B)" using assms by simp
       show "DRA.nodes (dbcrai A B) \<subseteq> DBA.nodes A \<times> DCA.nodes B"
         using dbcrai_nodes_fst dbcrai_nodes_snd unfolding image_subset_iff by force
     qed
     also have "\<dots> = card (DBA.nodes A) * card (DCA.nodes B)" using card_cartesian_product by this
     finally show ?thesis by this
   qed
 
   lemma dbcrai_language[simp]: "DRA.language (dbcrai A B) = DBA.language A \<inter> DCA.language B"
   proof -
     have 1: "dra.alphabet (dbcrai A B) = dba.alphabet A \<inter> dca.alphabet B" unfolding dbcrai_def by simp
     have 2: "dra.initial (dbcrai A B) = (dba.initial A, dca.initial B)" unfolding dbcrai_def by simp
     have 3: "dra.accepting (dbcrai A B) = [(dba.accepting A \<circ> fst, dca.rejecting B \<circ> snd)]"
       unfolding dbcrai_def by simp
     have 4: "cogen rabin (dra.accepting (dbcrai A B)) (DRA.trace (dbcrai A B) w (p, q)) \<longleftrightarrow>
       infs (dba.accepting A) (DBA.trace A w p) \<and> fins (rejecting B) (DCA.trace B w q)" for w p q
       unfolding cogen_def rabin_def 3 by simp
     show ?thesis
       unfolding DRA.language_def DBA.language_def DCA.language_def
       unfolding DRA.run_alt_def DBA.run_alt_def DCA.run_alt_def
       unfolding 1 2 4 by auto
   qed
 
   abbreviation (input) "get k pp \<equiv> pp ! k"
 
   definition draul :: "('label, 'state) dra list \<Rightarrow> ('label, 'state list) dra" where
     "draul AA \<equiv> dra
-      (UNION (set AA) dra.alphabet)
+      (\<Union> (dra.alphabet ` set AA))
       (map dra.initial AA)
       (\<lambda> a pp. map2 (\<lambda> A p. dra.transition A a p) AA pp)
       (do { k \<leftarrow> [0 ..< length AA]; (f, g) \<leftarrow> dra.accepting (AA ! k); [(f \<circ> get k, g \<circ> get k)] })"
 
   lemma draul_get:
     assumes "length pp = length AA" "k < length AA"
     shows "infs (P \<circ> get k) (dra.trace (draul AA) w pp) \<longleftrightarrow>
       infs P (dra.trace (AA ! k) w (pp ! k))"
   proof -
     have "infs (P \<circ> get k) (dra.trace (draul AA) w pp) \<longleftrightarrow>
       infs P (smap (get k) (dra.trace (draul AA) w pp))" by (simp add: comp_def)
     also have "smap (get k) (dra.trace (draul AA) w pp) = dra.trace (AA ! k) w (pp ! k)"
       using assms unfolding draul_def by (coinduction arbitrary: w pp) (force)
     finally show ?thesis by this
   qed
   lemma draul_nodes_length:
     assumes "pp \<in> DRA.nodes (draul AA)"
     shows "length pp = length AA"
     using assms unfolding draul_def by induct auto
   lemma draul_nodes[intro]:
-    assumes "INTER (set AA) dra.alphabet = UNION (set AA) dra.alphabet"
+    assumes "\<Inter> (dra.alphabet ` set AA)  = \<Union> (dra.alphabet ` set AA)"
     assumes "pp \<in> DRA.nodes (draul AA)" "k < length pp"
     shows "pp ! k \<in> DRA.nodes (AA ! k)"
     using assms(2, 3, 1) unfolding draul_def by induct force+
 
   lemma draul_nodes_finite[intro]:
-    assumes "INTER (set AA) dra.alphabet = UNION (set AA) dra.alphabet"
+    assumes "\<Inter> (dra.alphabet ` set AA)  = \<Union> (dra.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DRA.nodes) AA"
     shows "finite (DRA.nodes (draul AA))"
   proof (rule finite_subset)
     show "DRA.nodes (draul AA) \<subseteq> listset (map DRA.nodes AA)"
       using assms(1) by (force simp: listset_member list_all2_conv_all_nth draul_nodes_length)
     have "finite (listset (map DRA.nodes AA)) \<longleftrightarrow> list_all finite (map DRA.nodes AA)"
       by (rule listset_finite) (auto simp: list_all_iff)
     then show "finite (listset (map DRA.nodes AA))" using assms(2) by (simp add: list.pred_map)
   qed
   lemma draul_nodes_card:
-    assumes "INTER (set AA) dra.alphabet = UNION (set AA) dra.alphabet"
+    assumes "\<Inter> (dra.alphabet ` set AA)  = \<Union> (dra.alphabet ` set AA)"
     assumes "list_all (finite \<circ> DRA.nodes) AA"
     shows "card (DRA.nodes (draul AA)) \<le> prod_list (map (card \<circ> DRA.nodes) AA)"
   proof -
     have "card (DRA.nodes (draul AA)) \<le> card (listset (map DRA.nodes AA))"
     proof (rule card_mono)
       have "finite (listset (map DRA.nodes AA)) \<longleftrightarrow> list_all finite (map DRA.nodes AA)"
         by (rule listset_finite) (auto simp: list_all_iff)
       then show "finite (listset (map DRA.nodes AA))" using assms(2) by (simp add: list.pred_map)
       show "DRA.nodes (draul AA) \<subseteq> listset (map DRA.nodes AA)"
         using assms(1) by (force simp: listset_member list_all2_conv_all_nth draul_nodes_length)
     qed
     also have "\<dots> = prod_list (map (card \<circ> DRA.nodes) AA)" by simp
     finally show ?thesis by this
   qed
 
   lemma draul_language[simp]:
-    assumes "INTER (set AA) dra.alphabet = UNION (set AA) dra.alphabet"
-    shows "DRA.language (draul AA) = UNION (set AA) DRA.language"
+    assumes "\<Inter> (dra.alphabet ` set AA)  = \<Union> (dra.alphabet ` set AA)"
+    shows "DRA.language (draul AA) = \<Union> (DRA.language ` set AA)"
   proof safe
     fix w
     assume 1: "w \<in> DRA.language (draul AA)"
     obtain 2:
       "dra.run (draul AA) w (dra.initial (draul AA))"
       "cogen rabin (dra.accepting (draul AA)) (dra.trace (draul AA) w (dra.initial (draul AA)))"
       using 1 by rule
     obtain I F where 3:
       "(I, F) \<in> set (dra.accepting (draul AA))"
       "infs I (dra.trace (draul AA) w (dra.initial (draul AA)))"
       "fins F (dra.trace (draul AA) w (dra.initial (draul AA)))"
       using 2(2) by blast
     obtain k P Q where 4:
       "k < length AA" "I = P \<circ> get k" "F = Q \<circ> get k" "(P, Q) \<in> set (dra.accepting (AA ! k))"
       using 3(1) unfolding draul_def List.bind_def by (auto simp: comp_def)
-    show "w \<in> UNION (set AA) DRA.language"
+    show "w \<in> \<Union> (DRA.language ` set AA)"
     proof (intro UN_I DRA.language cogen rabin)
       show "AA ! k \<in> set AA" using 4(1) by auto
       show "DRA.run (AA ! k) w (dra.initial (AA ! k))"
         using assms 2(1) 4(1) unfolding DRA.run_alt_def draul_def by force
       show "(P, Q) \<in> set (dra.accepting (AA ! k))" using 4(4) by this
       show "(P, Q) = (P, Q)" by rule
       have "True \<longleftrightarrow> infs (P \<circ> get k) (dra.trace (draul AA) w (map dra.initial AA))"
         using 3(2) unfolding draul_def 4(2) by simp
       also have "\<dots> \<longleftrightarrow> infs P (dra.trace (AA ! k) w (map dra.initial AA ! k))"
         using 4(1) by (force intro!: draul_get)
       also have "map dra.initial AA ! k = dra.initial (AA ! k)" using 4(1) by simp
       finally show "infs P (dra.trace (AA ! k) w (dra.initial (AA ! k)))" by simp
       have "False \<longleftrightarrow> infs (Q \<circ> get k) (dra.trace (draul AA) w (map dra.initial AA))"
         using 3(3) unfolding draul_def 4(3) by simp
       also have "\<dots> \<longleftrightarrow> infs Q (dra.trace (AA ! k) w (map dra.initial AA ! k))"
         using 4(1) by (force intro!: draul_get)
       also have "map dra.initial AA ! k = dra.initial (AA ! k)" using 4(1) by simp
       finally show "fins Q (dra.trace (AA ! k) w (dra.initial (AA ! k)))" by simp
     qed
   next
     fix A w
     assume 1: "A \<in> set AA" "w \<in> DRA.language A"
     obtain 2:
       "dra.run A w (dra.initial A)"
       "cogen rabin (dra.accepting A) (dra.trace A w (dra.initial A))"
       using 1(2) by rule
     obtain I F where 3:
       "(I, F) \<in> set (dra.accepting A)"
       "infs I (dra.trace A w (dra.initial A))"
       "fins F (dra.trace A w (dra.initial A))"
       using 2(2) by blast
     obtain k where 4: "A = AA ! k" "k < length AA" using 1(1) unfolding in_set_conv_nth by auto
     show "w \<in> DRA.language (draul AA)"
     proof (intro DRA.language cogen rabin)
       show "dra.run (draul AA) w (dra.initial (draul AA))"
         using 1(1) 2(1) unfolding DRA.run_alt_def draul_def by auto
       show "(I \<circ> get k, F \<circ> get k) \<in> set (dra.accepting (draul AA))"
         unfolding draul_def List.bind_def using 3(1) 4 by (force simp: comp_def)
       show "(I \<circ> get k, F \<circ> get k) = (I \<circ> get k, F \<circ> get k)" by rule
       have "infs (I \<circ> get k) (dra.trace (draul AA) w (dra.initial (draul AA))) \<longleftrightarrow>
         infs (I \<circ> get k) (dra.trace (draul AA) w (map dra.initial AA))"
         unfolding draul_def by simp
       also have "\<dots> \<longleftrightarrow> infs I (dra.trace (AA ! k) w (map dra.initial AA ! k))"
         using 4(2) by (force intro!: draul_get)
       also have "\<dots> \<longleftrightarrow> True" using 3(2) 4 by simp
       finally show "infs (I \<circ> get k) (dra.trace (draul AA) w (dra.initial (draul AA)))" by simp
       have "infs (F \<circ> get k) (dra.trace (draul AA) w (dra.initial (draul AA))) \<longleftrightarrow>
         infs (F \<circ> get k) (dra.trace (draul AA) w (map dra.initial AA))"
         unfolding draul_def by simp
       also have "\<dots> \<longleftrightarrow> infs F (dra.trace (AA ! k) w (map dra.initial AA ! k))"
         using 4(2) by (force intro!: draul_get)
       also have "\<dots> \<longleftrightarrow> False" using 3(3) 4 by simp
       finally show "fins (F \<circ> get k) (dra.trace (draul AA) w (dra.initial (draul AA)))" by simp
     qed
   qed
 
 end
\ No newline at end of file
diff --git a/thys/UTP/toolkit/Countable_Set_Extra.thy b/thys/UTP/toolkit/Countable_Set_Extra.thy
--- a/thys/UTP/toolkit/Countable_Set_Extra.thy
+++ b/thys/UTP/toolkit/Countable_Set_Extra.thy
@@ -1,365 +1,365 @@
 (******************************************************************************)
 (* Project: Isabelle/UTP Toolkit                                              *)
 (* File: Countable_Set_Extra.thy                                              *)
 (* Authors: Simon Foster and Frank Zeyda                                      *)
 (* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
 (******************************************************************************)
 
 section \<open> Countable Sets: Extra functions and properties \<close>
 
 theory Countable_Set_Extra
 imports
   "HOL-Library.Countable_Set_Type"
   Sequence
   FSet_Extra
 begin
 
 subsection \<open> Extra syntax \<close>
 
 notation cempty ("{}\<^sub>c")
 notation cin (infix "\<in>\<^sub>c" 50)
 notation cUn (infixl "\<union>\<^sub>c" 65)
 notation cInt (infixl "\<inter>\<^sub>c" 70)
 notation cDiff (infixl "-\<^sub>c" 65)
 notation cUnion ("\<Union>\<^sub>c_" [900] 900)
 notation cimage (infixr "`\<^sub>c" 90)
 
 abbreviation csubseteq :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" ("(_/ \<subseteq>\<^sub>c _)" [51, 51] 50)
 where "A \<subseteq>\<^sub>c B \<equiv> A \<le> B"
 
 abbreviation csubset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" ("(_/ \<subset>\<^sub>c _)" [51, 51] 50)
 where "A \<subset>\<^sub>c B \<equiv> A < B"
 
 subsection \<open> Countable set functions \<close>
 
 setup_lifting type_definition_cset
 
 lift_definition cnin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" (infix "\<notin>\<^sub>c" 50) is "(\<notin>)" .
 
 definition cBall :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
 "cBall A P = (\<forall>x. x \<in>\<^sub>c A \<longrightarrow> P x)"
 
 definition cBex :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
 "cBex A P = (\<exists>x. x \<in>\<^sub>c A \<longrightarrow> P x)"
 
 declare cBall_def [mono,simp]
 declare cBex_def [mono,simp]
 
 syntax
   "_cBall" :: "pttrn => 'a cset => bool => bool" ("(3\<forall> _\<in>\<^sub>c_./ _)" [0, 0, 10] 10)
   "_cBex"  :: "pttrn => 'a cset => bool => bool" ("(3\<exists> _\<in>\<^sub>c_./ _)" [0, 0, 10] 10)
 
 translations
   "\<forall> x\<in>\<^sub>cA. P" == "CONST cBall A (%x. P)"
   "\<exists> x\<in>\<^sub>cA. P" == "CONST cBex  A (%x. P)"
 
 definition cset_Collect :: "('a \<Rightarrow> bool) \<Rightarrow> 'a cset" where
 "cset_Collect = (acset o Collect)"
 
 lift_definition cset_Coll :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a cset" is "\<lambda> A P. {x \<in> A. P x}"
   by (auto)
 
 lemma cset_Coll_equiv: "cset_Coll A P = cset_Collect (\<lambda> x. x \<in>\<^sub>c A \<and> P x)"
   by (simp add:cset_Collect_def cset_Coll_def cin_def)
 
 declare cset_Collect_def [simp]
 
 syntax
   "_cColl" :: "pttrn => bool => 'a cset" ("(1{_./ _}\<^sub>c)")
 
 translations
   "{x . P}\<^sub>c" \<rightleftharpoons> "(CONST cset_Collect) (\<lambda> x . P)"
 
 syntax (xsymbols)
   "_cCollect" :: "pttrn => 'a cset => bool => 'a cset"    ("(1{_ \<in>\<^sub>c/ _./ _}\<^sub>c)")
 translations
   "{x \<in>\<^sub>c A. P}\<^sub>c" => "CONST cset_Coll A (\<lambda> x. P)"
 
 lemma cset_CollectI: "P (a :: 'a::countable) \<Longrightarrow> a \<in>\<^sub>c {x. P x}\<^sub>c"
   by (simp add: cin_def)
 
 lemma cset_CollI: "\<lbrakk> a \<in>\<^sub>c A; P a \<rbrakk> \<Longrightarrow> a \<in>\<^sub>c {x \<in>\<^sub>c A. P x}\<^sub>c"
   by (simp add: cin.rep_eq cset_Coll.rep_eq)
 
 lemma cset_CollectD: "(a :: 'a::countable) \<in>\<^sub>c {x. P x}\<^sub>c \<Longrightarrow> P a"
   by (simp add: cin_def)
 
 lemma cset_Collect_cong: "(\<And>x. P x = Q x) ==> {x. P x}\<^sub>c = {x. Q x}\<^sub>c"
   by simp
 
 text \<open> Avoid eta-contraction for robust pretty-printing. \<close>
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs_tr'
    @{const_syntax cset_Collect} @{syntax_const "_cColl"}]
 \<close>
 
 lift_definition cset_set :: "'a list \<Rightarrow> 'a cset" is set
   using countable_finite by blast
 
 lemma countable_finite_power:
   "countable(A) \<Longrightarrow> countable {B. B \<subseteq> A \<and> finite(B)}"
   by (metis Collect_conj_eq Int_commute countable_Collect_finite_subset)
 
-lift_definition cINTER :: "'a cset \<Rightarrow> ('a \<Rightarrow> 'b cset) \<Rightarrow> 'b cset" is
-"\<lambda> A f. if (A = {}) then {} else INTER A f"
-  by (auto)
+lift_definition cInter :: "'a cset cset \<Rightarrow> 'a cset"  ("\<Inter>\<^sub>c_" [900] 900)
+  is "\<lambda>A. if A = {} then {} else \<Inter> A"
+  using countable_INT [of _ _ id] by auto
 
-definition cInter :: "'a cset cset \<Rightarrow> 'a cset" ("\<Inter>\<^sub>c_" [900] 900) where
-"\<Inter>\<^sub>c A = cINTER A id"
+abbreviation (input) cINTER :: "'a cset \<Rightarrow> ('a \<Rightarrow> 'b cset) \<Rightarrow> 'b cset"
+  where "cINTER A f \<equiv> cInter (cimage f A)"
 
 lift_definition cfinite :: "'a cset \<Rightarrow> bool" is finite .
 lift_definition cInfinite :: "'a cset \<Rightarrow> bool" is infinite .
 lift_definition clist :: "'a::linorder cset \<Rightarrow> 'a list" is sorted_list_of_set .
 lift_definition ccard :: "'a cset \<Rightarrow> nat" is card .
 lift_definition cPow :: "'a cset \<Rightarrow> 'a cset cset" is "\<lambda> A. {B. B \<subseteq>\<^sub>c A \<and> cfinite(B)}"
 proof -
   fix A
   have "{B :: 'a cset. B \<subseteq>\<^sub>c A \<and> cfinite B} = acset ` {B :: 'a set. B \<subseteq> rcset A \<and> finite B}"
     apply (auto simp add: cfinite.rep_eq cin_def less_eq_cset_def countable_finite)
     using image_iff apply fastforce
     done
 
   moreover have "countable {B :: 'a set. B \<subseteq> rcset A \<and> finite B}"
     by (auto intro: countable_finite_power)
 
   ultimately show "countable {B. B \<subseteq>\<^sub>c A \<and> cfinite B}"
     by simp
 qed
 
 definition CCollect :: "('a \<Rightarrow> bool option) \<Rightarrow> 'a cset option" where
 "CCollect p = (if (None \<notin> range p) then Some (cset_Collect (the \<circ> p)) else None)"
 
 definition cset_mapM :: "'a option cset \<Rightarrow> 'a cset option" where
 "cset_mapM A = (if (None \<in>\<^sub>c A) then None else Some (the `\<^sub>c A))"
 
 lemma cset_mapM_Some_image [simp]:
   "cset_mapM (cimage Some A) = Some A"
   apply (auto simp add: cset_mapM_def)
   apply (metis cimage_cinsert cinsertI1 option.sel set_cinsert)
   done
 
 definition CCollect_ext :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> bool option) \<Rightarrow> 'b cset option" where
 "CCollect_ext f p = do { xs \<leftarrow> CCollect p; cset_mapM (f `\<^sub>c xs) }"
 
 lemma the_Some_image [simp]:
   "the ` Some ` xs = xs"
   by (auto simp add:image_iff)
 
 lemma CCollect_ext_Some [simp]:
   "CCollect_ext Some xs = CCollect xs"
   apply (case_tac "CCollect xs")
    apply (auto simp add:CCollect_ext_def)
   done
 
 lift_definition list_of_cset :: "'a :: linorder cset \<Rightarrow> 'a list" is sorted_list_of_set .
 
 lift_definition fset_cset :: "'a fset \<Rightarrow> 'a cset" is id
   using uncountable_infinite by auto
 
 definition cset_count :: "'a cset \<Rightarrow> 'a \<Rightarrow> nat" where
 "cset_count A =
   (if (finite (rcset A))
    then (SOME f::'a\<Rightarrow>nat. inj_on f (rcset A))
    else (SOME f::'a\<Rightarrow>nat. bij_betw f (rcset A) UNIV))"
 
 lemma cset_count_inj_seq:
   "inj_on (cset_count A) (rcset A)"
 proof (cases "finite (rcset A)")
   case True note fin = this
   obtain count :: "'a \<Rightarrow> nat" where count_inj: "inj_on count (rcset A)"
     by (metis countable_def mem_Collect_eq rcset)
   with fin show ?thesis
     by (metis (poly_guards_query) cset_count_def someI_ex)
 next
   case False note inf = this
   obtain count :: "'a \<Rightarrow> nat" where count_bij: "bij_betw count (rcset A) UNIV"
     by (metis countableE_infinite inf mem_Collect_eq rcset)
   with inf have "bij_betw (cset_count A) (rcset A) UNIV"
     by (metis (poly_guards_query) cset_count_def someI_ex)
   thus ?thesis
     by (metis bij_betw_imp_inj_on)
 qed
 
 lemma cset_count_infinite_bij:
   assumes "infinite (rcset A)"
   shows "bij_betw (cset_count A) (rcset A) UNIV"
 proof -
   from assms obtain count :: "'a \<Rightarrow> nat" where count_bij: "bij_betw count (rcset A) UNIV"
     by (metis countableE_infinite mem_Collect_eq rcset)
   with assms show ?thesis
     by (metis (poly_guards_query) cset_count_def someI_ex)
 qed
 
 definition cset_seq :: "'a cset \<Rightarrow> (nat \<rightharpoonup> 'a)" where
 "cset_seq A i = (if (i \<in> range (cset_count A) \<and> inv_into (rcset A) (cset_count A) i \<in>\<^sub>c A)
                  then Some (inv_into (rcset A) (cset_count A) i)
                  else None)"
 
 lemma cset_seq_ran: "ran (cset_seq A) = rcset(A)"
   apply (auto simp add: ran_def cset_seq_def cin.rep_eq)
   apply (metis cset_count_inj_seq inv_into_f_f rangeI)
   done
 
 lemma cset_seq_inj: "inj cset_seq"
 proof (rule injI)
   fix A B :: "'a cset"
   assume "cset_seq A = cset_seq B"
   thus "A = B"
     by (metis cset_seq_ran rcset_inverse)
 qed
 
 lift_definition cset2seq :: "'a cset \<Rightarrow> 'a seq"
 is "(\<lambda> A i. if (i \<in> cset_count A ` rcset A) then inv_into (rcset A) (cset_count A) i else (SOME x. x \<in>\<^sub>c A))" .
 
 lemma range_cset2seq:
   "A \<noteq> {}\<^sub>c \<Longrightarrow> range (Rep_seq (cset2seq A)) = rcset A"
   by (force intro: someI2 simp add: cset2seq.rep_eq cset_count_inj_seq bot_cset.rep_eq cin.rep_eq)
 
 lemma infinite_cset_count_surj: "infinite (rcset A) \<Longrightarrow> surj (cset_count A)"
   using bij_betw_imp_surj cset_count_infinite_bij by auto
 
 lemma cset2seq_inj:
   "inj_on cset2seq {A. A \<noteq> {}\<^sub>c}"
   apply (rule inj_onI)
   apply (simp)
   apply (metis range_cset2seq rcset_inject)
   done
 
 lift_definition nat_seq2set :: "nat seq \<Rightarrow> nat set" is
 "\<lambda> f. prod_encode ` {(x, f x) | x. True}" .
 
 lemma inj_nat_seq2set: "inj nat_seq2set"
 proof (rule injI, transfer)
   fix f g
   assume "prod_encode ` {(x, f x) |x. True} = prod_encode ` {(x, g x) |x. True}"
   hence "{(x, f x) |x. True} = {(x, g x) |x. True}"
     by (simp add: inj_image_eq_iff[OF inj_prod_encode])
   thus "f = g"
     by (auto simp add: set_eq_iff)
 qed
 
 lift_definition bit_seq_of_nat_set :: "nat set \<Rightarrow> bool seq"
 is "\<lambda> A i. i \<in> A" .
 
 lemma bit_seq_of_nat_set_inj: "inj bit_seq_of_nat_set"
   apply (rule injI)
   apply transfer
   apply (auto simp add: fun_eq_iff)
   done
 
 lemma bit_seq_of_nat_cset_bij: "bij bit_seq_of_nat_set"
   apply (rule bijI)
    apply (fact bit_seq_of_nat_set_inj)
   apply transfer
   apply (rule surjI)
   apply auto
   done
 
 text \<open> This function is a partial injection from countable sets of natural sets to natural sets.
         When used with the Schroeder-Bernstein theorem, it can be used to conjure a total
         bijection between these two types. \<close>
 
 definition nat_set_cset_collapse :: "nat set cset \<Rightarrow> nat set" where
 "nat_set_cset_collapse = inv bit_seq_of_nat_set \<circ> seq_inj \<circ> cset2seq \<circ> (\<lambda> A. (bit_seq_of_nat_set `\<^sub>c A))"
 
 lemma nat_set_cset_collapse_inj: "inj_on nat_set_cset_collapse {A. A \<noteq> {}\<^sub>c}"
 proof -
   have "(`\<^sub>c) bit_seq_of_nat_set ` {A. A \<noteq> {}\<^sub>c} \<subseteq> {A. A \<noteq> {}\<^sub>c}"
     by (auto simp add:cimage.rep_eq)
   thus ?thesis
     apply (simp add: nat_set_cset_collapse_def)
     apply (rule comp_inj_on)
      apply (meson bit_seq_of_nat_set_inj cset.inj_map injD inj_onI)
     apply (rule comp_inj_on)
      apply (metis cset2seq_inj subset_inj_on)
     apply (rule comp_inj_on)
      apply (rule subset_inj_on)
       apply (rule seq_inj)
      apply (simp)
     apply (meson UNIV_I bij_imp_bij_inv bij_is_inj bit_seq_of_nat_cset_bij subsetI subset_inj_on)
     done
 qed
 
 lemma inj_csingle:
   "inj csingle"
   by (auto intro: injI simp add: cinsert_def bot_cset.rep_eq)
 
 lemma range_csingle:
   "range csingle \<subseteq> {A. A \<noteq> {}\<^sub>c}"
   by (auto)
 
 lift_definition csets :: "'a set \<Rightarrow> 'a cset set" is
 "\<lambda> A. {B. B \<subseteq> A \<and> countable B}" by auto
 
 lemma csets_finite: "finite A \<Longrightarrow> finite (csets A)"
   by (auto simp add: csets_def)
 
 lemma csets_infinite: "infinite A \<Longrightarrow> infinite (csets A)"
   by (auto simp add: csets_def, metis csets.abs_eq csets.rep_eq finite_countable_subset finite_imageI)
 
 lemma csets_UNIV:
   "csets (UNIV :: 'a set) = (UNIV :: 'a cset set)"
   by (auto simp add: csets_def, metis image_iff rcset rcset_inverse)
 
 lemma infinite_nempty_cset:
   assumes "infinite (UNIV :: 'a set)"
   shows "infinite ({A. A \<noteq> {}\<^sub>c} :: 'a cset set)"
 proof -
   have "infinite (UNIV :: 'a cset set)"
     by (metis assms csets_UNIV csets_infinite)
   hence "infinite ((UNIV :: 'a cset set) - {{}\<^sub>c})"
     by (rule infinite_remove)
   thus ?thesis
     by (auto)
 qed
 
 lemma nat_set_cset_partial_bij:
   obtains f :: "nat set cset \<Rightarrow> nat set" where "bij_betw f {A. A \<noteq> {}\<^sub>c} UNIV"
   using Schroeder_Bernstein[OF nat_set_cset_collapse_inj, of UNIV csingle, simplified, OF inj_csingle range_csingle]
   by (auto)
 
 lemma nat_set_cset_bij:
   obtains f :: "nat set cset \<Rightarrow> nat set" where "bij f"
 proof -
   obtain g :: "nat set cset \<Rightarrow> nat set" where "bij_betw g {A. A \<noteq> {}\<^sub>c} UNIV"
     using nat_set_cset_partial_bij by blast
   moreover obtain h :: "nat set cset \<Rightarrow> nat set cset" where "bij_betw h UNIV {A. A \<noteq> {}\<^sub>c}"
   proof -
     have "infinite (UNIV :: nat set cset set)"
       by (metis Finite_Set.finite_set csets_UNIV csets_infinite infinite_UNIV_char_0)
     then obtain h' :: "nat set cset \<Rightarrow> nat set cset" where "bij_betw h' UNIV (UNIV - {{}\<^sub>c})"
       using infinite_imp_bij_betw[of "UNIV :: nat set cset set" "{}\<^sub>c"] by auto
     moreover have "(UNIV :: nat set cset set) - {{}\<^sub>c} = {A. A \<noteq> {}\<^sub>c}"
       by (auto)
     ultimately show ?thesis
       using that by (auto)
   qed
   ultimately have "bij (g \<circ> h)"
     using bij_betw_trans by blast
   with that show ?thesis
     by (auto)
 qed
 
 definition "nat_set_cset_bij = (SOME f :: nat set cset \<Rightarrow> nat set. bij f)"
 
 lemma bij_nat_set_cset_bij:
   "bij nat_set_cset_bij"
   by (metis nat_set_cset_bij nat_set_cset_bij_def someI_ex)
 
 lemma inj_on_image_csets:
   "inj_on f A \<Longrightarrow> inj_on ((`\<^sub>c) f) (csets A)"
   by (fastforce simp add: inj_on_def cimage_def cin_def csets_def)
 
 lemma image_csets_surj:
   "\<lbrakk> inj_on f A; f ` A = B \<rbrakk> \<Longrightarrow> (`\<^sub>c) f ` csets A = csets B"
   apply (auto simp add: cimage_def csets_def image_mono map_fun_def)
   apply (simp add: image_comp)
   apply (auto simp add: image_Collect)
   apply (erule subset_imageE)
   using countable_image_inj_on subset_inj_on by blast
 
 lemma bij_betw_image_csets:
   "bij_betw f A B \<Longrightarrow> bij_betw ((`\<^sub>c) f) (csets A) (csets B)"
   by (simp add: bij_betw_def inj_on_image_csets image_csets_surj)
 end
\ No newline at end of file
diff --git a/thys/UTP/utp/utp_healthy.thy b/thys/UTP/utp/utp_healthy.thy
--- a/thys/UTP/utp/utp_healthy.thy
+++ b/thys/UTP/utp/utp_healthy.thy
@@ -1,318 +1,318 @@
 section \<open> Healthiness Conditions \<close>
 
 theory utp_healthy
   imports utp_pred_laws
 begin
 
 subsection \<open> Main Definitions \<close>
 
 text \<open> We collect closure laws for healthiness conditions in the following theorem attribute. \<close>
 
 named_theorems closure
   
 type_synonym '\<alpha> health = "'\<alpha> upred \<Rightarrow> '\<alpha> upred"
 
 text \<open> A predicate $P$ is healthy, under healthiness function $H$, if $P$ is a fixed-point of $H$. \<close>
 
 definition Healthy :: "'\<alpha> upred \<Rightarrow> '\<alpha> health \<Rightarrow> bool" (infix "is" 30)
 where "P is H \<equiv> (H P = P)"
 
 lemma Healthy_def': "P is H \<longleftrightarrow> (H P = P)"
   unfolding Healthy_def by auto
 
 lemma Healthy_if: "P is H \<Longrightarrow> (H P = P)"
   unfolding Healthy_def by auto
 
 lemma Healthy_intro: "H(P) = P \<Longrightarrow> P is H"
   by (simp add: Healthy_def)
     
 declare Healthy_def' [upred_defs]
 
 abbreviation Healthy_carrier :: "'\<alpha> health \<Rightarrow> '\<alpha> upred set" ("\<lbrakk>_\<rbrakk>\<^sub>H")
 where "\<lbrakk>H\<rbrakk>\<^sub>H \<equiv> {P. P is H}"
 
 lemma Healthy_carrier_image:
   "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<Longrightarrow> \<H> ` A = A"
     by (auto simp add: image_def, (metis Healthy_if mem_Collect_eq subsetCE)+)
 
 lemma Healthy_carrier_Collect: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> A = {H(P) | P. P \<in> A}"
   by (simp add: Healthy_carrier_image Setcompr_eq_image)
 
 lemma Healthy_func:
   "\<lbrakk> F \<in> \<lbrakk>\<H>\<^sub>1\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<^sub>2\<rbrakk>\<^sub>H; P is \<H>\<^sub>1 \<rbrakk> \<Longrightarrow> \<H>\<^sub>2(F(P)) = F(P)"
   using Healthy_if by blast
 
 lemma Healthy_comp:
   "\<lbrakk> P is \<H>\<^sub>1; P is \<H>\<^sub>2 \<rbrakk> \<Longrightarrow> P is \<H>\<^sub>1 \<circ> \<H>\<^sub>2"
   by (simp add: Healthy_def)
     
 lemma Healthy_apply_closed:
   assumes "F \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H" "P is H"
   shows "F(P) is H"
   using assms(1) assms(2) by auto
 
 lemma Healthy_set_image_member:
   "\<lbrakk> P \<in> F ` A; \<And> x. F x is H \<rbrakk> \<Longrightarrow> P is H"
   by blast
 
 lemma Healthy_case_prod [closure]: 
   "\<lbrakk> \<And> x y. P x y is H \<rbrakk> \<Longrightarrow> case_prod P v is H"
   by (simp add: prod.case_eq_if)
 
 lemma Healthy_SUPREMUM:
-  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> SUPREMUM A H = \<Sqinter> A"
+  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Sup (H ` A) = \<Sqinter> A"
   by (drule Healthy_carrier_image, presburger)
 
 lemma Healthy_INFIMUM:
-  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> INFIMUM A H = \<Squnion> A"
+  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Inf (H ` A) = \<Squnion> A"
   by (drule Healthy_carrier_image, presburger)
 
 lemma Healthy_nu [closure]:
   assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
   shows "\<nu> F is H"
   by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff lfp_unfold)
 
 lemma Healthy_mu [closure]:
   assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
   shows "\<mu> F is H"
   by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff gfp_unfold)
 
 lemma Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> H(P) = P"
   by (meson Ball_Collect Healthy_if)
 
 lemma is_Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> P is H"
   by blast
 
 subsection \<open> Properties of Healthiness Conditions \<close>
 
 definition Idempotent :: "'\<alpha> health \<Rightarrow> bool" where
   "Idempotent(H) \<longleftrightarrow> (\<forall> P. H(H(P)) = H(P))"
 
 abbreviation Monotonic :: "'\<alpha> health \<Rightarrow> bool" where
   "Monotonic(H) \<equiv> mono H"
 
 definition IMH :: "'\<alpha> health \<Rightarrow> bool" where
   "IMH(H) \<longleftrightarrow> Idempotent(H) \<and> Monotonic(H)"
 
 definition Antitone :: "'\<alpha> health \<Rightarrow> bool" where
   "Antitone(H) \<longleftrightarrow> (\<forall> P Q. Q \<sqsubseteq> P \<longrightarrow> (H(P) \<sqsubseteq> H(Q)))"
 
 definition Conjunctive :: "'\<alpha> health \<Rightarrow> bool" where
   "Conjunctive(H) \<longleftrightarrow> (\<exists> Q. \<forall> P. H(P) = (P \<and> Q))"
 
 definition FunctionalConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
   "FunctionalConjunctive(H) \<longleftrightarrow> (\<exists> F. \<forall> P. H(P) = (P \<and> F(P)) \<and> Monotonic(F))"
 
 definition WeakConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
   "WeakConjunctive(H) \<longleftrightarrow> (\<forall> P. \<exists> Q. H(P) = (P \<and> Q))"
 
 definition Disjunctuous :: "'\<alpha> health \<Rightarrow> bool" where
   [upred_defs]: "Disjunctuous H = (\<forall> P Q. H(P \<sqinter> Q) = (H(P) \<sqinter> H(Q)))"
 
 definition Continuous :: "'\<alpha> health \<Rightarrow> bool" where
   [upred_defs]: "Continuous H = (\<forall> A. A \<noteq> {} \<longrightarrow> H (\<Sqinter> A) = \<Sqinter> (H ` A))"
 
 lemma Healthy_Idempotent [closure]:
   "Idempotent H \<Longrightarrow> H(P) is H"
   by (simp add: Healthy_def Idempotent_def)
 
 lemma Healthy_range: "Idempotent H \<Longrightarrow> range H = \<lbrakk>H\<rbrakk>\<^sub>H"
   by (auto simp add: image_def Healthy_if Healthy_Idempotent, metis Healthy_if)
 
 lemma Idempotent_id [simp]: "Idempotent id"
   by (simp add: Idempotent_def)
 
 lemma Idempotent_comp [intro]:
   "\<lbrakk> Idempotent f; Idempotent g; f \<circ> g = g \<circ> f \<rbrakk> \<Longrightarrow> Idempotent (f \<circ> g)"
   by (auto simp add: Idempotent_def comp_def, metis)
 
 lemma Idempotent_image: "Idempotent f \<Longrightarrow> f ` f ` A = f ` A"
   by (metis (mono_tags, lifting) Idempotent_def image_cong image_image)
 
 lemma Monotonic_id [simp]: "Monotonic id"
   by (simp add: monoI)
 
 lemma Monotonic_id' [closure]: 
   "mono (\<lambda> X. X)" 
   by (simp add: monoI)
     
 lemma Monotonic_const [closure]: 
   "Monotonic (\<lambda> x. c)"
   by (simp add: mono_def)
     
 lemma Monotonic_comp [intro]:
   "\<lbrakk> Monotonic f; Monotonic g \<rbrakk> \<Longrightarrow> Monotonic (f \<circ> g)"
   by (simp add: mono_def)
 
 lemma Monotonic_inf [closure]:
   assumes "Monotonic P" "Monotonic Q"
   shows "Monotonic (\<lambda> X. P(X) \<sqinter> Q(X))"
   using assms by (simp add: mono_def, rel_auto)
 
 lemma Monotonic_cond [closure]:
   assumes "Monotonic P" "Monotonic Q"
   shows "Monotonic (\<lambda> X. P(X) \<triangleleft> b \<triangleright> Q(X))"
   by (simp add: assms cond_monotonic)
     
 lemma Conjuctive_Idempotent:
   "Conjunctive(H) \<Longrightarrow> Idempotent(H)"
   by (auto simp add: Conjunctive_def Idempotent_def)
 
 lemma Conjunctive_Monotonic:
   "Conjunctive(H) \<Longrightarrow> Monotonic(H)"
   unfolding Conjunctive_def mono_def
   using dual_order.trans by fastforce
 
 lemma Conjunctive_conj:
   assumes "Conjunctive(HC)"
   shows "HC(P \<and> Q) = (HC(P) \<and> Q)"
   using assms unfolding Conjunctive_def
   by (metis utp_pred_laws.inf.assoc utp_pred_laws.inf.commute)
 
 lemma Conjunctive_distr_conj:
   assumes "Conjunctive(HC)"
   shows "HC(P \<and> Q) = (HC(P) \<and> HC(Q))"
   using assms unfolding Conjunctive_def
   by (metis Conjunctive_conj assms utp_pred_laws.inf.assoc utp_pred_laws.inf_right_idem)
 
 lemma Conjunctive_distr_disj:
   assumes "Conjunctive(HC)"
   shows "HC(P \<or> Q) = (HC(P) \<or> HC(Q))"
   using assms unfolding Conjunctive_def
   using utp_pred_laws.inf_sup_distrib2 by fastforce
 
 lemma Conjunctive_distr_cond:
   assumes "Conjunctive(HC)"
   shows "HC(P \<triangleleft> b \<triangleright> Q) = (HC(P) \<triangleleft> b \<triangleright> HC(Q))"
   using assms unfolding Conjunctive_def
   by (metis cond_conj_distr utp_pred_laws.inf_commute)
 
 lemma FunctionalConjunctive_Monotonic:
   "FunctionalConjunctive(H) \<Longrightarrow> Monotonic(H)"
   unfolding FunctionalConjunctive_def by (metis mono_def utp_pred_laws.inf_mono)
 
 lemma WeakConjunctive_Refinement:
   assumes "WeakConjunctive(HC)"
   shows "P \<sqsubseteq> HC(P)"
   using assms unfolding WeakConjunctive_def by (metis utp_pred_laws.inf.cobounded1)
 
 lemma WeakCojunctive_Healthy_Refinement:
   assumes "WeakConjunctive(HC)" and "P is HC"
   shows "HC(P) \<sqsubseteq> P"
   using assms unfolding WeakConjunctive_def Healthy_def by simp
 
 lemma WeakConjunctive_implies_WeakConjunctive:
   "Conjunctive(H) \<Longrightarrow> WeakConjunctive(H)"
   unfolding WeakConjunctive_def Conjunctive_def by pred_auto
 
 declare Conjunctive_def [upred_defs]
 declare mono_def [upred_defs]
 
 lemma Disjunctuous_Monotonic: "Disjunctuous H \<Longrightarrow> Monotonic H"
   by (metis Disjunctuous_def mono_def semilattice_sup_class.le_iff_sup)
 
 lemma ContinuousD [dest]: "\<lbrakk> Continuous H; A \<noteq> {} \<rbrakk> \<Longrightarrow> H (\<Sqinter> A) = (\<Sqinter> P\<in>A. H(P))"
   by (simp add: Continuous_def)
 
 lemma Continuous_Disjunctous: "Continuous H \<Longrightarrow> Disjunctuous H"
   apply (auto simp add: Continuous_def Disjunctuous_def)
   apply (rename_tac P Q)
   apply (drule_tac x="{P,Q}" in spec)
   apply (simp)
   done
 
 lemma Continuous_Monotonic [closure]: "Continuous H \<Longrightarrow> Monotonic H"
   by (simp add: Continuous_Disjunctous Disjunctuous_Monotonic)
 
 lemma Continuous_comp [intro]:
   "\<lbrakk> Continuous f; Continuous g \<rbrakk> \<Longrightarrow> Continuous (f \<circ> g)"
   by (simp add: Continuous_def)
 
 lemma Continuous_const [closure]: "Continuous (\<lambda> X. P)"
   by pred_auto
 
 lemma Continuous_cond [closure]:
   assumes "Continuous F" "Continuous G"
   shows "Continuous (\<lambda> X. F(X) \<triangleleft> b \<triangleright> G(X))"
   using assms by (pred_auto)
 
 text \<open> Closure laws derived from continuity \<close>
 
 lemma Sup_Continuous_closed [closure]:
   "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A. P(i)) is H"
   by (drule ContinuousD[of H "P ` A"], simp add: UINF_mem_UNIV[THEN sym] UINF_as_Sup[THEN sym])
      (metis (no_types, lifting) Healthy_def' SUP_cong image_image)
 
 lemma UINF_mem_Continuous_closed [closure]:
   "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> P(i)) is H"
   by (simp add: Sup_Continuous_closed UINF_as_Sup_collect)
 
 lemma UINF_mem_Continuous_closed_pair [closure]:
   assumes "Continuous H" "\<And> i j. (i, j) \<in> A \<Longrightarrow> P i j is H" "A \<noteq> {}"
   shows "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) is H"
 proof -
   have "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (snd x))"
     by (rel_auto)
   also have "... is H"
     by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
   finally show ?thesis .
 qed
 
 lemma UINF_mem_Continuous_closed_triple [closure]:
   assumes "Continuous H" "\<And> i j k. (i, j, k) \<in> A \<Longrightarrow> P i j k is H" "A \<noteq> {}"
   shows "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) is H"
 proof -
   have "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (snd (snd x)))"
     by (rel_auto)
   also have "... is H"
     by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
   finally show ?thesis .
 qed
 
 lemma UINF_mem_Continuous_closed_quad [closure]:
   assumes "Continuous H" "\<And> i j k l. (i, j, k, l) \<in> A \<Longrightarrow> P i j k l is H" "A \<noteq> {}"
   shows "(\<Sqinter> (i,j,k,l)\<in>A \<bullet> P i j k l) is H"
 proof -
   have "(\<Sqinter> (i,j,k,l)\<in>A \<bullet> P i j k l) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (fst (snd (snd x))) (snd (snd (snd x))))"
     by (rel_auto)
   also have "... is H"
     by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
   finally show ?thesis .
 qed
 
 lemma UINF_mem_Continuous_closed_quint [closure]:
   assumes "Continuous H" "\<And> i j k l m. (i, j, k, l, m) \<in> A \<Longrightarrow> P i j k l m is H" "A \<noteq> {}"
   shows "(\<Sqinter> (i,j,k,l,m)\<in>A \<bullet> P i j k l m) is H"
 proof -
   have "(\<Sqinter> (i,j,k,l,m)\<in>A \<bullet> P i j k l m) 
          = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (fst (snd (snd x))) (fst (snd (snd (snd x)))) (snd (snd (snd (snd x)))))"
     by (rel_auto)
   also have "... is H"
     by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
   finally show ?thesis .
 qed
 
 lemma UINF_ind_closed [closure]:
   assumes "Continuous H" "\<And> i. P i = true" "\<And> i. Q i is H"
   shows "UINF P Q is H"
 proof -
   from assms(2) have "UINF P Q = (\<Sqinter> i \<bullet> Q i)"
     by (rel_auto)
   also have "... is H"
     using UINF_mem_Continuous_closed[of H UNIV P]
     by (simp add: Sup_Continuous_closed UINF_as_Sup_collect' assms)
   finally show ?thesis .
 qed
 
 text \<open> All continuous functions are also Scott-continuous \<close>
 
 lemma sup_continuous_Continuous [closure]: "Continuous F \<Longrightarrow> sup_continuous F"
   by (simp add: Continuous_def sup_continuous_def)
 
 lemma USUP_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> F(H(P)))"
   by (rule USUP_cong, simp add: Healthy_subset_member)
 
 lemma UINF_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> F(H(P)))"
   by (rule UINF_cong, simp add: Healthy_subset_member)
   
 end
\ No newline at end of file
diff --git a/thys/UTP/utp/utp_rel_laws.thy b/thys/UTP/utp/utp_rel_laws.thy
--- a/thys/UTP/utp/utp_rel_laws.thy
+++ b/thys/UTP/utp/utp_rel_laws.thy
@@ -1,997 +1,997 @@
 section \<open> Relational Calculus Laws \<close>
 
 theory utp_rel_laws
   imports 
     utp_rel
     utp_recursion
 begin
 
 subsection \<open> Conditional Laws \<close>
   
 lemma comp_cond_left_distr:
   "((P \<triangleleft> b \<triangleright>\<^sub>r Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright>\<^sub>r (Q ;; R))"
   by (rel_auto)
 
 lemma cond_seq_left_distr:
   "out\<alpha> \<sharp> b \<Longrightarrow> ((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
   by (rel_auto)
 
 lemma cond_seq_right_distr:
   "in\<alpha> \<sharp> b \<Longrightarrow> (P ;; (Q \<triangleleft> b \<triangleright> R)) = ((P ;; Q) \<triangleleft> b \<triangleright> (P ;; R))"
   by (rel_auto)
 
 text \<open> Alternative expression of conditional using assumptions and choice \<close>
 
 lemma rcond_rassume_expand: "P \<triangleleft> b \<triangleright>\<^sub>r Q = ([b]\<^sup>\<top> ;; P) \<sqinter> ([(\<not> b)]\<^sup>\<top> ;; Q)"
   by (rel_auto)
 
 subsection \<open> Precondition and Postcondition Laws \<close>
   
 theorem precond_equiv:
   "P = (P ;; true) \<longleftrightarrow> (out\<alpha> \<sharp> P)"
   by (rel_auto)
 
 theorem postcond_equiv:
   "P = (true ;; P) \<longleftrightarrow> (in\<alpha> \<sharp> P)"
   by (rel_auto)
 
 lemma precond_right_unit: "out\<alpha> \<sharp> p \<Longrightarrow> (p ;; true) = p"
   by (metis precond_equiv)
 
 lemma postcond_left_unit: "in\<alpha> \<sharp> p \<Longrightarrow> (true ;; p) = p"
   by (metis postcond_equiv)
 
 theorem precond_left_zero:
   assumes "out\<alpha> \<sharp> p" "p \<noteq> false"
   shows "(true ;; p) = true"
   using assms by (rel_auto)
 
 theorem feasibile_iff_true_right_zero:
   "P ;; true = true \<longleftrightarrow> `\<exists> out\<alpha> \<bullet> P`"
   by (rel_auto)
     
 subsection \<open> Sequential Composition Laws \<close>
     
 lemma seqr_assoc: "(P ;; Q) ;; R = P ;; (Q ;; R)"
   by (rel_auto)
 
 lemma seqr_left_unit [simp]:
   "II ;; P = P"
   by (rel_auto)
 
 lemma seqr_right_unit [simp]:
   "P ;; II = P"
   by (rel_auto)
 
 lemma seqr_left_zero [simp]:
   "false ;; P = false"
   by pred_auto
 
 lemma seqr_right_zero [simp]:
   "P ;; false = false"
   by pred_auto
 
 lemma impl_seqr_mono: "\<lbrakk> `P \<Rightarrow> Q`; `R \<Rightarrow> S` \<rbrakk> \<Longrightarrow> `(P ;; R) \<Rightarrow> (Q ;; S)`"
   by (pred_blast)
 
 lemma seqr_mono:
   "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 ;; Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 ;; Q\<^sub>2)"
   by (rel_blast)
     
 lemma seqr_monotonic:
   "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X ;; Q X)"
   by (simp add: mono_def, rel_blast)
     
 lemma Monotonic_seqr_tail [closure]:
   assumes "Monotonic F"
   shows "Monotonic (\<lambda> X. P ;; F(X))"
   by (simp add: assms monoD monoI seqr_mono)
     
 lemma seqr_exists_left:
   "((\<exists> $x \<bullet> P) ;; Q) = (\<exists> $x \<bullet> (P ;; Q))"
   by (rel_auto)
 
 lemma seqr_exists_right:
   "(P ;; (\<exists> $x\<acute> \<bullet> Q)) = (\<exists> $x\<acute> \<bullet> (P ;; Q))"
   by (rel_auto)
 
 lemma seqr_or_distl:
   "((P \<or> Q) ;; R) = ((P ;; R) \<or> (Q ;; R))"
   by (rel_auto)
 
 lemma seqr_or_distr:
   "(P ;; (Q \<or> R)) = ((P ;; Q) \<or> (P ;; R))"
   by (rel_auto)
 
 lemma seqr_inf_distl:
   "((P \<sqinter> Q) ;; R) = ((P ;; R) \<sqinter> (Q ;; R))"
   by (rel_auto)
 
 lemma seqr_inf_distr:
   "(P ;; (Q \<sqinter> R)) = ((P ;; Q) \<sqinter> (P ;; R))"
   by (rel_auto)
 
 lemma seqr_and_distr_ufunc:
   "ufunctional P \<Longrightarrow> (P ;; (Q \<and> R)) = ((P ;; Q) \<and> (P ;; R))"
   by (rel_auto)
 
 lemma seqr_and_distl_uinj:
   "uinj R \<Longrightarrow> ((P \<and> Q) ;; R) = ((P ;; R) \<and> (Q ;; R))"
   by (rel_auto)
 
 lemma seqr_unfold:
   "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<^bold>v\<acute>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$\<^bold>v\<rbrakk>)"
   by (rel_auto)
 
 lemma seqr_middle:
   assumes "vwb_lens x"
   shows "(P ;; Q) = (\<^bold>\<exists> v \<bullet> P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
   using assms
   by (rel_auto', metis vwb_lens_wb wb_lens.source_stability)
 
 lemma seqr_left_one_point:
   assumes "vwb_lens x"
   shows "((P \<and> $x\<acute> =\<^sub>u \<guillemotleft>v\<guillemotright>) ;; Q) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
   using assms
   by (rel_auto, metis vwb_lens_wb wb_lens.get_put)
 
 lemma seqr_right_one_point:
   assumes "vwb_lens x"
   shows "(P ;; ($x =\<^sub>u \<guillemotleft>v\<guillemotright> \<and> Q)) = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>)"
   using assms
   by (rel_auto, metis vwb_lens_wb wb_lens.get_put)
 
 lemma seqr_left_one_point_true:
   assumes "vwb_lens x"
   shows "((P \<and> $x\<acute>) ;; Q) = (P\<lbrakk>true/$x\<acute>\<rbrakk> ;; Q\<lbrakk>true/$x\<rbrakk>)"
   by (metis assms seqr_left_one_point true_alt_def upred_eq_true)
 
 lemma seqr_left_one_point_false:
   assumes "vwb_lens x"
   shows "((P \<and> \<not>$x\<acute>) ;; Q) = (P\<lbrakk>false/$x\<acute>\<rbrakk> ;; Q\<lbrakk>false/$x\<rbrakk>)"
   by (metis assms false_alt_def seqr_left_one_point upred_eq_false)
 
 lemma seqr_right_one_point_true:
   assumes "vwb_lens x"
   shows "(P ;; ($x \<and> Q)) = (P\<lbrakk>true/$x\<acute>\<rbrakk> ;; Q\<lbrakk>true/$x\<rbrakk>)"
   by (metis assms seqr_right_one_point true_alt_def upred_eq_true)
 
 lemma seqr_right_one_point_false:
   assumes "vwb_lens x"
   shows "(P ;; (\<not>$x \<and> Q)) = (P\<lbrakk>false/$x\<acute>\<rbrakk> ;; Q\<lbrakk>false/$x\<rbrakk>)"
   by (metis assms false_alt_def seqr_right_one_point upred_eq_false)
 
 lemma seqr_insert_ident_left:
   assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
   shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; Q) = (P ;; Q)"
   using assms
   by (rel_simp, meson vwb_lens_wb wb_lens_weak weak_lens.put_get)
 
 lemma seqr_insert_ident_right:
   assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
   shows "(P ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = (P ;; Q)"
   using assms
   by (rel_simp, metis (no_types, hide_lams) vwb_lens_def wb_lens_def weak_lens.put_get)
 
 lemma seq_var_ident_lift:
   assumes "vwb_lens x" "$x\<acute> \<sharp> P" "$x \<sharp> Q"
   shows "(($x\<acute> =\<^sub>u $x \<and> P) ;; ($x\<acute> =\<^sub>u $x \<and> Q)) = ($x\<acute> =\<^sub>u $x \<and> (P ;; Q))"
   using assms by (rel_auto', metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)
 
 lemma seqr_bool_split:
   assumes "vwb_lens x"
   shows "P ;; Q = (P\<lbrakk>true/$x\<acute>\<rbrakk> ;; Q\<lbrakk>true/$x\<rbrakk> \<or> P\<lbrakk>false/$x\<acute>\<rbrakk> ;; Q\<lbrakk>false/$x\<rbrakk>)"
   using assms
   by (subst seqr_middle[of x], simp_all)
 
 lemma cond_inter_var_split:
   assumes "vwb_lens x"
   shows "(P \<triangleleft> $x\<acute> \<triangleright> Q) ;; R = (P\<lbrakk>true/$x\<acute>\<rbrakk> ;; R\<lbrakk>true/$x\<rbrakk> \<or> Q\<lbrakk>false/$x\<acute>\<rbrakk> ;; R\<lbrakk>false/$x\<rbrakk>)"
 proof -
   have "(P \<triangleleft> $x\<acute> \<triangleright> Q) ;; R = (($x\<acute> \<and> P) ;; R \<or> (\<not> $x\<acute> \<and> Q) ;; R)"
     by (simp add: cond_def seqr_or_distl)
   also have "... = ((P \<and> $x\<acute>) ;; R \<or> (Q \<and> \<not>$x\<acute>) ;; R)"
     by (rel_auto)
   also have "... = (P\<lbrakk>true/$x\<acute>\<rbrakk> ;; R\<lbrakk>true/$x\<rbrakk> \<or> Q\<lbrakk>false/$x\<acute>\<rbrakk> ;; R\<lbrakk>false/$x\<rbrakk>)"
     by (simp add: seqr_left_one_point_true seqr_left_one_point_false assms)
   finally show ?thesis .
 qed
 
 theorem seqr_pre_transfer: "in\<alpha> \<sharp> q \<Longrightarrow> ((P \<and> q) ;; R) = (P ;; (q\<^sup>- \<and> R))"
   by (rel_auto)
 
 theorem seqr_pre_transfer':
   "((P \<and> \<lceil>q\<rceil>\<^sub>>) ;; R) = (P ;; (\<lceil>q\<rceil>\<^sub>< \<and> R))"
   by (rel_auto)
 
 theorem seqr_post_out: "in\<alpha> \<sharp> r \<Longrightarrow> (P ;; (Q \<and> r)) = ((P ;; Q) \<and> r)"
   by (rel_blast)
 
 lemma seqr_post_var_out:
   fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
   shows "(P ;; (Q \<and> $x\<acute>)) = ((P ;; Q) \<and> $x\<acute>)"
   by (rel_auto)
 
 theorem seqr_post_transfer: "out\<alpha> \<sharp> q \<Longrightarrow> (P ;; (q \<and> R)) = ((P \<and> q\<^sup>-) ;; R)"
   by (rel_auto)
 
 lemma seqr_pre_out: "out\<alpha> \<sharp> p \<Longrightarrow> ((p \<and> Q) ;; R) = (p \<and> (Q ;; R))"
   by (rel_blast)
 
 lemma seqr_pre_var_out:
   fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
   shows "(($x \<and> P) ;; Q) = ($x \<and> (P ;; Q))"
   by (rel_auto)
 
 lemma seqr_true_lemma:
   "(P = (\<not> ((\<not> P) ;; true))) = (P = (P ;; true))"
   by (rel_auto)
 
 lemma seqr_to_conj: "\<lbrakk> out\<alpha> \<sharp> P; in\<alpha> \<sharp> Q \<rbrakk> \<Longrightarrow> (P ;; Q) = (P \<and> Q)"
   by (metis postcond_left_unit seqr_pre_out utp_pred_laws.inf_top.right_neutral)
 
 lemma shEx_lift_seq_1 [uquant_lift]:
   "((\<^bold>\<exists> x \<bullet> P x) ;; Q) = (\<^bold>\<exists> x \<bullet> (P x ;; Q))"
   by rel_auto
 
 lemma shEx_mem_lift_seq_1 [uquant_lift]:
   assumes "out\<alpha> \<sharp> A"
   shows "((\<^bold>\<exists> x \<in> A \<bullet> P x) ;; Q) = (\<^bold>\<exists> x \<in> A \<bullet> (P x ;; Q))"
   using assms by rel_blast
 
 lemma shEx_lift_seq_2 [uquant_lift]:
   "(P ;; (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P ;; Q x))"
   by rel_auto
 
 lemma shEx_mem_lift_seq_2 [uquant_lift]:
   assumes "in\<alpha> \<sharp> A"
   shows "(P ;; (\<^bold>\<exists> x \<in> A \<bullet> Q x)) = (\<^bold>\<exists> x \<in> A \<bullet> (P ;; Q x))"
   using assms by rel_blast
 
 subsection \<open> Iterated Sequential Composition Laws \<close>
   
 lemma iter_seqr_nil [simp]: "(;; i : [] \<bullet> P(i)) = II"
   by (simp add: seqr_iter_def)
     
 lemma iter_seqr_cons [simp]: "(;; i : (x # xs) \<bullet> P(i)) = P(x) ;; (;; i : xs \<bullet> P(i))"
   by (simp add: seqr_iter_def)
 
 subsection \<open> Quantale Laws \<close>
 
 lemma seq_Sup_distl: "P ;; (\<Sqinter> A) = (\<Sqinter> Q\<in>A. P ;; Q)"
   by (transfer, auto)
 
 lemma seq_Sup_distr: "(\<Sqinter> A) ;; Q = (\<Sqinter> P\<in>A. P ;; Q)"
   by (transfer, auto)
 
 lemma seq_UINF_distl: "P ;; (\<Sqinter> Q\<in>A \<bullet> F(Q)) = (\<Sqinter> Q\<in>A \<bullet> P ;; F(Q))"
   by (simp add: UINF_as_Sup_collect seq_Sup_distl)
 
 lemma seq_UINF_distl': "P ;; (\<Sqinter> Q \<bullet> F(Q)) = (\<Sqinter> Q \<bullet> P ;; F(Q))"
   by (metis UINF_mem_UNIV seq_UINF_distl)
 
 lemma seq_UINF_distr: "(\<Sqinter> P\<in>A \<bullet> F(P)) ;; Q = (\<Sqinter> P\<in>A \<bullet> F(P) ;; Q)"
   by (simp add: UINF_as_Sup_collect seq_Sup_distr)
 
 lemma seq_UINF_distr': "(\<Sqinter> P \<bullet> F(P)) ;; Q = (\<Sqinter> P \<bullet> F(P) ;; Q)"
   by (metis UINF_mem_UNIV seq_UINF_distr)
 
 lemma seq_SUP_distl: "P ;; (\<Sqinter>i\<in>A. Q(i)) = (\<Sqinter>i\<in>A. P ;; Q(i))"
   by (metis image_image seq_Sup_distl)
 
 lemma seq_SUP_distr: "(\<Sqinter>i\<in>A. P(i)) ;; Q = (\<Sqinter>i\<in>A. P(i) ;; Q)"
   by (simp add: seq_Sup_distr)
 
 subsection \<open> Skip Laws \<close>
     
 lemma cond_skip: "out\<alpha> \<sharp> b \<Longrightarrow> (b \<and> II) = (II \<and> b\<^sup>-)"
   by (rel_auto)
 
 lemma pre_skip_post: "(\<lceil>b\<rceil>\<^sub>< \<and> II) = (II \<and> \<lceil>b\<rceil>\<^sub>>)"
   by (rel_auto)
 
 lemma skip_var:
   fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
   shows "($x \<and> II) = (II \<and> $x\<acute>)"
   by (rel_auto)
 
 lemma skip_r_unfold:
   "vwb_lens x \<Longrightarrow> II = ($x\<acute> =\<^sub>u $x \<and> II\<restriction>\<^sub>\<alpha>x)"
   by (rel_simp, metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)
 
 lemma skip_r_alpha_eq:
   "II = ($\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"
   by (rel_auto)
 
 lemma skip_ra_unfold:
   "II\<^bsub>x;y\<^esub> = ($x\<acute> =\<^sub>u $x \<and> II\<^bsub>y\<^esub>)"
   by (rel_auto)
 
 lemma skip_res_as_ra:
   "\<lbrakk> vwb_lens y; x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L; x \<bowtie> y \<rbrakk> \<Longrightarrow> II\<restriction>\<^sub>\<alpha>x = II\<^bsub>y\<^esub>"
   apply (rel_auto)
    apply (metis (no_types, lifting) lens_indep_def)
   apply (metis vwb_lens.put_eq)
   done
 
 subsection \<open> Assignment Laws \<close>
   
 lemma assigns_subst [usubst]:
   "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ> \<sigma>\<rangle>\<^sub>a"
   by (rel_auto)
 
 lemma assigns_r_comp: "(\<langle>\<sigma>\<rangle>\<^sub>a ;; P) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P)"
   by (rel_auto)
 
 lemma assigns_r_feasible:
   "(\<langle>\<sigma>\<rangle>\<^sub>a ;; true) = true"
   by (rel_auto)
 
 lemma assign_subst [usubst]:
   "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> [$x \<mapsto>\<^sub>s \<lceil>u\<rceil>\<^sub><] \<dagger> (y := v) = (x, y) := (u, [x \<mapsto>\<^sub>s u] \<dagger> v)"
   by (rel_auto)
 
 lemma assign_vacuous_skip:
   assumes "vwb_lens x"
   shows "(x := &x) = II"
   using assms by rel_auto
 
 text \<open> The following law shows the case for the above law when $x$ is only mainly-well behaved. We
   require that the state is one of those in which $x$ is well defined using and assumption. \<close>
 
 lemma assign_vacuous_assume:
   assumes "mwb_lens x"
   shows "[(&\<^bold>v \<in>\<^sub>u \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>)]\<^sup>\<top> ;; (x := &x) = [(&\<^bold>v \<in>\<^sub>u \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>)]\<^sup>\<top>"
   using assms by rel_auto
 
 lemma assign_simultaneous:
   assumes "vwb_lens y" "x \<bowtie> y"
   shows "(x,y) := (e, &y) = (x := e)"
   by (simp add: assms usubst_upd_comm usubst_upd_var_id)
 
 lemma assigns_idem: "mwb_lens x \<Longrightarrow> (x,x) := (u,v) = (x := v)"
   by (simp add: usubst)
 
 lemma assigns_comp: "(\<langle>f\<rangle>\<^sub>a ;; \<langle>g\<rangle>\<^sub>a) = \<langle>g \<circ> f\<rangle>\<^sub>a"
   by (simp add: assigns_r_comp usubst)
 
 lemma assigns_cond: "(\<langle>f\<rangle>\<^sub>a \<triangleleft> b \<triangleright>\<^sub>r \<langle>g\<rangle>\<^sub>a) = \<langle>f \<triangleleft> b \<triangleright>\<^sub>s g\<rangle>\<^sub>a"
   by (rel_auto)
 
 lemma assigns_r_conv:
   "bij f \<Longrightarrow> \<langle>f\<rangle>\<^sub>a\<^sup>- = \<langle>inv f\<rangle>\<^sub>a"
   by (rel_auto, simp_all add: bij_is_inj bij_is_surj surj_f_inv_f)
 
 lemma assign_pred_transfer:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   assumes "$x \<sharp> b" "out\<alpha> \<sharp> b"
   shows "(b \<and> x := v) = (x := v \<and> b\<^sup>-)"
   using assms by (rel_blast)
     
 lemma assign_r_comp: "x := u ;; P = P\<lbrakk>\<lceil>u\<rceil>\<^sub></$x\<rbrakk>"
   by (simp add: assigns_r_comp usubst alpha)
     
 lemma assign_test: "mwb_lens x \<Longrightarrow> (x := \<guillemotleft>u\<guillemotright> ;; x := \<guillemotleft>v\<guillemotright>) = (x := \<guillemotleft>v\<guillemotright>)"
   by (simp add: assigns_comp usubst)
 
 lemma assign_twice: "\<lbrakk> mwb_lens x; x \<sharp> f \<rbrakk> \<Longrightarrow> (x := e ;; x := f) = (x := f)"
   by (simp add: assigns_comp usubst unrest)
  
 lemma assign_commute:
   assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
   shows "(x := e ;; y := f) = (y := f ;; x := e)"
   using assms
   by (rel_simp, simp_all add: lens_indep_comm)
 
 lemma assign_cond:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   assumes "out\<alpha> \<sharp> b"
   shows "(x := e ;; (P \<triangleleft> b \<triangleright> Q)) = ((x := e ;; P) \<triangleleft> (b\<lbrakk>\<lceil>e\<rceil>\<^sub></$x\<rbrakk>) \<triangleright> (x := e ;; Q))"
   by (rel_auto)
 
 lemma assign_rcond:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "(x := e ;; (P \<triangleleft> b \<triangleright>\<^sub>r Q)) = ((x := e ;; P) \<triangleleft> (b\<lbrakk>e/x\<rbrakk>) \<triangleright>\<^sub>r (x := e ;; Q))"
   by (rel_auto)
 
 lemma assign_r_alt_def:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "x := v = II\<lbrakk>\<lceil>v\<rceil>\<^sub></$x\<rbrakk>"
   by (rel_auto)
 
 lemma assigns_r_ufunc: "ufunctional \<langle>f\<rangle>\<^sub>a"
   by (rel_auto)
 
 lemma assigns_r_uinj: "inj f \<Longrightarrow> uinj \<langle>f\<rangle>\<^sub>a"
   by (rel_simp, simp add: inj_eq)
     
 lemma assigns_r_swap_uinj:
   "\<lbrakk> vwb_lens x; vwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> uinj ((x,y) := (&y,&x))"
   by (metis assigns_r_uinj pr_var_def swap_usubst_inj)
 
 lemma assign_unfold:
   "vwb_lens x \<Longrightarrow> (x := v) = ($x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub>< \<and> II\<restriction>\<^sub>\<alpha>x)"
   apply (rel_auto, auto simp add: comp_def)
   using vwb_lens.put_eq by fastforce
 
 subsection \<open> Non-deterministic Assignment Laws \<close>
 
 lemma nd_assign_comp:
   "x \<bowtie> y \<Longrightarrow> x := * ;; y := * = x,y := *"
   apply (rel_auto) using lens_indep_comm by fastforce+
 
 lemma nd_assign_assign:
   "\<lbrakk> vwb_lens x; x \<sharp> e \<rbrakk> \<Longrightarrow> x := * ;; x := e = x := e"
   by (rel_auto)
 
 subsection \<open> Converse Laws \<close>
 
 lemma convr_invol [simp]: "p\<^sup>-\<^sup>- = p"
   by pred_auto
 
 lemma lit_convr [simp]: "\<guillemotleft>v\<guillemotright>\<^sup>- = \<guillemotleft>v\<guillemotright>"
   by pred_auto
 
 lemma uivar_convr [simp]:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "($x)\<^sup>- = $x\<acute>"
   by pred_auto
 
 lemma uovar_convr [simp]:
   fixes x :: "('a \<Longrightarrow> '\<alpha>)"
   shows "($x\<acute>)\<^sup>- = $x"
   by pred_auto
 
 lemma uop_convr [simp]: "(uop f u)\<^sup>- = uop f (u\<^sup>-)"
   by (pred_auto)
 
 lemma bop_convr [simp]: "(bop f u v)\<^sup>- = bop f (u\<^sup>-) (v\<^sup>-)"
   by (pred_auto)
 
 lemma eq_convr [simp]: "(p =\<^sub>u q)\<^sup>- = (p\<^sup>- =\<^sub>u q\<^sup>-)"
   by (pred_auto)
 
 lemma not_convr [simp]: "(\<not> p)\<^sup>- = (\<not> p\<^sup>-)"
   by (pred_auto)
 
 lemma disj_convr [simp]: "(p \<or> q)\<^sup>- = (q\<^sup>- \<or> p\<^sup>-)"
   by (pred_auto)
 
 lemma conj_convr [simp]: "(p \<and> q)\<^sup>- = (q\<^sup>- \<and> p\<^sup>-)"
   by (pred_auto)
 
 lemma seqr_convr [simp]: "(p ;; q)\<^sup>- = (q\<^sup>- ;; p\<^sup>-)"
   by (rel_auto)
 
 lemma pre_convr [simp]: "\<lceil>p\<rceil>\<^sub><\<^sup>- = \<lceil>p\<rceil>\<^sub>>"
   by (rel_auto)
 
 lemma post_convr [simp]: "\<lceil>p\<rceil>\<^sub>>\<^sup>- = \<lceil>p\<rceil>\<^sub><"
   by (rel_auto)
 
 subsection \<open> Assertion and Assumption Laws \<close>
 
 declare sublens_def [lens_defs del]
   
 lemma assume_false: "[false]\<^sup>\<top> = false"
   by (rel_auto)
   
 lemma assume_true: "[true]\<^sup>\<top> = II"
   by (rel_auto)
     
 lemma assume_seq: "[b]\<^sup>\<top> ;; [c]\<^sup>\<top> = [(b \<and> c)]\<^sup>\<top>"
   by (rel_auto)
 
 lemma assert_false: "{false}\<^sub>\<bottom> = true"
   by (rel_auto)
 
 lemma assert_true: "{true}\<^sub>\<bottom> = II"
   by (rel_auto)
     
 lemma assert_seq: "{b}\<^sub>\<bottom> ;; {c}\<^sub>\<bottom> = {(b \<and> c)}\<^sub>\<bottom>"
   by (rel_auto)
 
 subsection \<open> Frame and Antiframe Laws \<close>
 
 named_theorems frame
 
 lemma frame_all [frame]: "\<Sigma>:[P] = P"
   by (rel_auto)
 
 lemma frame_none [frame]: 
   "\<emptyset>:[P] = (P \<and> II)"
   by (rel_auto)
 
 lemma frame_commute:
   assumes "$y \<sharp> P" "$y\<acute> \<sharp> P" "$x \<sharp> Q" "$x\<acute> \<sharp> Q" "x \<bowtie> y" 
   shows "x:[P] ;; y:[Q] = y:[Q] ;; x:[P]"
   apply (insert assms)
   apply (rel_auto)
    apply (rename_tac s s' s\<^sub>0)
    apply (subgoal_tac "(s \<oplus>\<^sub>L s' on y) \<oplus>\<^sub>L s\<^sub>0 on x = s\<^sub>0 \<oplus>\<^sub>L s' on y")
     apply (metis lens_indep_get lens_indep_sym lens_override_def)
    apply (simp add: lens_indep.lens_put_comm lens_override_def)
   apply (rename_tac s s' s\<^sub>0)
   apply (subgoal_tac "put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> s (get\<^bsub>x\<^esub> (put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')))) (get\<^bsub>y\<^esub> (put\<^bsub>y\<^esub> s (get\<^bsub>y\<^esub> s\<^sub>0))) 
                       = put\<^bsub>x\<^esub> s\<^sub>0 (get\<^bsub>x\<^esub> s')")
    apply (metis lens_indep_get lens_indep_sym)
   apply (metis lens_indep.lens_put_comm)
   done
 
 lemma frame_contract_RID:
   assumes "vwb_lens x" "P is RID(x)" "x \<bowtie> y"
   shows "(x;y):[P] = y:[P]"
 proof -
   from assms(1,3) have "(x;y):[RID(x)(P)] = y:[RID(x)(P)]"
     apply (rel_auto)
      apply (simp add: lens_indep.lens_put_comm)
     apply (metis (no_types) vwb_lens_wb wb_lens.get_put)
     done
   thus ?thesis
     by (simp add: Healthy_if assms)
 qed
  
 lemma frame_miracle [simp]:
   "x:[false] = false"
   by (rel_auto)
 
 lemma frame_skip [simp]:
   "vwb_lens x \<Longrightarrow> x:[II] = II"
   by (rel_auto)
     
 lemma frame_assign_in [frame]:
   "\<lbrakk> vwb_lens a; x \<subseteq>\<^sub>L a \<rbrakk> \<Longrightarrow> a:[x := v] = x := v"
   by (rel_auto, simp_all add: lens_get_put_quasi_commute lens_put_of_quotient)
 
 lemma frame_conj_true [frame]:
   "\<lbrakk> {$x,$x\<acute>} \<natural> P; vwb_lens x \<rbrakk> \<Longrightarrow> (P \<and> x:[true]) = x:[P]"
   by (rel_auto)
     
 lemma frame_is_assign [frame]:
   "vwb_lens x \<Longrightarrow> x:[$x\<acute> =\<^sub>u \<lceil>v\<rceil>\<^sub><] = x := v"
   by (rel_auto)
     
 lemma frame_seq [frame]:
   "\<lbrakk> vwb_lens x; {$x,$x\<acute>} \<natural> P; {$x,$x\<acute>} \<natural> Q \<rbrakk> \<Longrightarrow> x:[P ;; Q] = x:[P] ;; x:[Q]"
   apply (rel_auto)
    apply (metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens_def weak_lens.put_get)
   apply (metis mwb_lens.put_put vwb_lens_mwb)
   done
 
 lemma frame_to_antiframe [frame]:
   "\<lbrakk> x \<bowtie> y; x +\<^sub>L y = 1\<^sub>L \<rbrakk> \<Longrightarrow> x:[P] = y:\<lbrakk>P\<rbrakk>"
   by (rel_auto, metis lens_indep_def, metis lens_indep_def surj_pair)
 
 lemma rel_frext_miracle [frame]: 
   "a:[false]\<^sup>+ = false"
   by (rel_auto)
     
 lemma rel_frext_skip [frame]: 
   "vwb_lens a \<Longrightarrow> a:[II]\<^sup>+ = II"
   by (rel_auto)
 
 lemma rel_frext_seq [frame]:
   "vwb_lens a \<Longrightarrow> a:[P ;; Q]\<^sup>+ = (a:[P]\<^sup>+ ;; a:[Q]\<^sup>+)"
   apply (rel_auto)
    apply (rename_tac s s' s\<^sub>0)
    apply (rule_tac x="put\<^bsub>a\<^esub> s s\<^sub>0" in exI)
    apply (auto)
   apply (metis mwb_lens.put_put vwb_lens_mwb)
   done
 
 lemma rel_frext_assigns [frame]:
   "vwb_lens a \<Longrightarrow> a:[\<langle>\<sigma>\<rangle>\<^sub>a]\<^sup>+ = \<langle>\<sigma> \<oplus>\<^sub>s a\<rangle>\<^sub>a"
   by (rel_auto)
 
 lemma rel_frext_rcond [frame]:
   "a:[P \<triangleleft> b \<triangleright>\<^sub>r Q]\<^sup>+ = (a:[P]\<^sup>+ \<triangleleft> b \<oplus>\<^sub>p a \<triangleright>\<^sub>r a:[Q]\<^sup>+)"
   by (rel_auto)
 
 lemma rel_frext_commute: 
   "x \<bowtie> y \<Longrightarrow> x:[P]\<^sup>+ ;; y:[Q]\<^sup>+ = y:[Q]\<^sup>+ ;; x:[P]\<^sup>+"
   apply (rel_auto)
    apply (rename_tac a c b)
    apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
     apply (metis (no_types, hide_lams) lens_indep_comm lens_indep_get)
    apply (simp add: lens_indep.lens_put_irr2)
   apply (subgoal_tac "\<And>b c. get\<^bsub>x\<^esub> (put\<^bsub>y\<^esub> b c) = get\<^bsub>x\<^esub> b")
    apply (subgoal_tac "\<And>b a. get\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> b a) = get\<^bsub>y\<^esub> b")
     apply (metis (mono_tags, lifting) lens_indep_comm)
    apply (simp_all add: lens_indep.lens_put_irr2)    
   done
     
 lemma antiframe_disj [frame]: "(x:\<lbrakk>P\<rbrakk> \<or> x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P \<or> Q\<rbrakk>"
   by (rel_auto)
 
 lemma antiframe_seq [frame]:
   "\<lbrakk> vwb_lens x; $x\<acute> \<sharp> P; $x \<sharp> Q \<rbrakk>  \<Longrightarrow> (x:\<lbrakk>P\<rbrakk> ;; x:\<lbrakk>Q\<rbrakk>) = x:\<lbrakk>P ;; Q\<rbrakk>"
   apply (rel_auto)
    apply (metis vwb_lens_wb wb_lens_def weak_lens.put_get)
   apply (metis vwb_lens_wb wb_lens.put_twice wb_lens_def weak_lens.put_get)
   done
   
 lemma nameset_skip: "vwb_lens x \<Longrightarrow> (ns x \<bullet> II) = II\<^bsub>x\<^esub>"
   by (rel_auto, meson vwb_lens_wb wb_lens.get_put)
     
 lemma nameset_skip_ra: "vwb_lens x \<Longrightarrow> (ns x \<bullet> II\<^bsub>x\<^esub>) = II\<^bsub>x\<^esub>"
   by (rel_auto)
     
 declare sublens_def [lens_defs]
     
 subsection \<open> While Loop Laws \<close>
 
 theorem while_unfold:
   "while b do P od = ((P ;; while b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
 proof -
   have m:"mono (\<lambda>X. (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (auto intro: monoI seqr_mono cond_mono)
   have "(while b do P od) = (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (simp add: while_top_def)
   also have "... = ((P ;; (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (subst lfp_unfold, simp_all add: m)
   also have "... = ((P ;; while b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (simp add: while_top_def)
   finally show ?thesis .
 qed
 
 theorem while_false: "while false do P od = II"
   by (subst while_unfold, rel_auto)
 
 theorem while_true: "while true do P od = false"
   apply (simp add: while_top_def alpha)
   apply (rule antisym)
    apply (simp_all)
   apply (rule lfp_lowerbound)
   apply (rel_auto)
   done
 
 theorem while_bot_unfold:
   "while\<^sub>\<bottom> b do P od = ((P ;; while\<^sub>\<bottom> b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
 proof -
   have m:"mono (\<lambda>X. (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (auto intro: monoI seqr_mono cond_mono)
   have "(while\<^sub>\<bottom> b do P od) = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (simp add: while_bot_def)
   also have "... = ((P ;; (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (subst gfp_unfold, simp_all add: m)
   also have "... = ((P ;; while\<^sub>\<bottom> b do P od) \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (simp add: while_bot_def)
   finally show ?thesis .
 qed
 
 theorem while_bot_false: "while\<^sub>\<bottom> false do P od = II"
   by (simp add: while_bot_def mu_const alpha)
 
 theorem while_bot_true: "while\<^sub>\<bottom> true do P od = (\<mu> X \<bullet> P ;; X)"
   by (simp add: while_bot_def alpha)
 
 text \<open> An infinite loop with a feasible body corresponds to a program error (non-termination). \<close>
 
 theorem while_infinite: "P ;; true\<^sub>h = true \<Longrightarrow> while\<^sub>\<bottom> true do P od = true"
   apply (simp add: while_bot_true)
   apply (rule antisym)
    apply (simp)
   apply (rule gfp_upperbound)
   apply (simp)
   done
 
 subsection \<open> Algebraic Properties \<close>
 
 interpretation upred_semiring: semiring_1
   where times = seqr and one = skip_r and zero = false\<^sub>h and plus = Lattices.sup
   by (unfold_locales, (rel_auto)+)
 
 declare upred_semiring.power_Suc [simp del]
 
 text \<open> We introduce the power syntax derived from semirings \<close>
 
 abbreviation upower :: "'\<alpha> hrel \<Rightarrow> nat \<Rightarrow> '\<alpha> hrel" (infixr "\<^bold>^" 80) where
 "upower P n \<equiv> upred_semiring.power P n"
 
 translations
   "P \<^bold>^ i" <= "CONST power.power II op ;; P i"
   "P \<^bold>^ i" <= "(CONST power.power II op ;; P) i"
 
 text \<open> Set up transfer tactic for powers \<close>
 
 lemma upower_rep_eq:
   "\<lbrakk>P \<^bold>^ i\<rbrakk>\<^sub>e = (\<lambda> b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p} ^^ i))"
 proof (induct i arbitrary: P)
   case 0
   then show ?case
     by (auto, rel_auto)
 next
   case (Suc i)
   show ?case
     by (simp add: Suc seqr.rep_eq relpow_commute upred_semiring.power_Suc)
 qed
 
 lemma upower_rep_eq_alt:
   "\<lbrakk>power.power \<langle>id\<rangle>\<^sub>a (;;) P i\<rbrakk>\<^sub>e = (\<lambda>b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p} ^^ i))"
   by (metis skip_r_def upower_rep_eq)
 
 update_uexpr_rep_eq_thms
   
 lemma Sup_power_expand:
   fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
   shows "P(0) \<sqinter> (\<Sqinter>i. P(i+1)) = (\<Sqinter>i. P(i))"
 proof -
   have "UNIV = insert (0::nat) {1..}"
     by auto
   moreover have "(\<Sqinter>i. P(i)) = \<Sqinter> (P ` UNIV)"
     by (blast)
-  moreover have "\<Sqinter> (P ` insert 0 {1..}) = P(0) \<sqinter> SUPREMUM {1..} P"
+  moreover have "\<Sqinter> (P ` insert 0 {1..}) = P(0) \<sqinter> \<Sqinter> (P ` {1..})"
     by (simp)
-  moreover have "SUPREMUM {1..} P = (\<Sqinter>i. P(i+1))"
+  moreover have "\<Sqinter> (P ` {1..}) = (\<Sqinter>i. P(i+1))"
     by (simp add: atLeast_Suc_greaterThan greaterThan_0)
   ultimately show ?thesis
     by (simp only:)
 qed
 
 lemma Sup_upto_Suc: "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i) \<sqinter> P \<^bold>^ Suc n"
 proof -
   have "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>insert (Suc n) {0..n}. P \<^bold>^ i)"
     by (simp add: atLeast0_atMost_Suc)
   also have "... = P \<^bold>^ Suc n \<sqinter> (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i)"
     by (simp)
   finally show ?thesis
     by (simp add: Lattices.sup_commute)
 qed
 
 text \<open> The following two proofs are adapted from the AFP entry 
   \href{https://www.isa-afp.org/entries/Kleene_Algebra.shtml}{Kleene Algebra}. 
   See also~\cite{Armstrong2012,Armstrong2015}. \<close>
 
 lemma upower_inductl: "Q \<sqsubseteq> ((P ;; Q) \<sqinter> R) \<Longrightarrow> Q \<sqsubseteq> P \<^bold>^ n ;; R"
 proof (induct n)
   case 0
   then show ?case by (auto)
 next
   case (Suc n)
   then show ?case
     by (auto simp add: upred_semiring.power_Suc, metis (no_types, hide_lams) dual_order.trans order_refl seqr_assoc seqr_mono)
 qed
 
 lemma upower_inductr:
   assumes "Q \<sqsubseteq> R \<sqinter> (Q ;; P)"
   shows "Q \<sqsubseteq> R ;; (P \<^bold>^ n)"
 using assms proof (induct n)
   case 0
   then show ?case by auto
 next
   case (Suc n)
   have "R ;; P \<^bold>^ Suc n = (R ;; P \<^bold>^ n) ;; P"
     by (metis seqr_assoc upred_semiring.power_Suc2)
   also have "Q ;; P \<sqsubseteq> ..."
     by (meson Suc.hyps assms eq_iff seqr_mono)
   also have "Q \<sqsubseteq> ..."
     using assms by auto
   finally show ?case .
 qed
 
 lemma SUP_atLeastAtMost_first:
   fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
   assumes "m \<le> n"
   shows "(\<Sqinter>i\<in>{m..n}. P(i)) = P(m) \<sqinter> (\<Sqinter>i\<in>{Suc m..n}. P(i))"
   by (metis SUP_insert assms atLeastAtMost_insertL)
     
 lemma upower_seqr_iter: "P \<^bold>^ n = (;; Q : replicate n P \<bullet> Q)"
   by (induct n, simp_all add: upred_semiring.power_Suc)
 
 lemma assigns_power: "\<langle>f\<rangle>\<^sub>a \<^bold>^ n = \<langle>f ^^ n\<rangle>\<^sub>a"
   by (induct n, rel_auto+)
 
 subsection \<open> Kleene Star \<close>
 
 definition ustar :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<star>" [999] 999) where
 "P\<^sup>\<star> = (\<Sqinter>i\<in>{0..} \<bullet> P\<^bold>^i)"
 
 lemma ustar_rep_eq:
   "\<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>e = (\<lambda>b. b \<in> ({p. \<lbrakk>P\<rbrakk>\<^sub>e p}\<^sup>*))"
   by (simp add: ustar_def, rel_auto, simp_all add: relpow_imp_rtrancl rtrancl_imp_relpow)
 
 update_uexpr_rep_eq_thms
 
 subsection \<open> Kleene Plus \<close>
 
 purge_notation trancl ("(_\<^sup>+)" [1000] 999)
 
 definition uplus :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>+" [999] 999) where
 [upred_defs]: "P\<^sup>+ = P ;; P\<^sup>\<star>"
 
 lemma uplus_power_def: "P\<^sup>+ = (\<Sqinter> i \<bullet> P \<^bold>^ (Suc i))"
   by (simp add: uplus_def ustar_def seq_UINF_distl' UINF_atLeast_Suc upred_semiring.power_Suc)
 
 subsection \<open> Omega \<close>
 
 definition uomega :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<omega>" [999] 999) where
 "P\<^sup>\<omega> = (\<mu> X \<bullet> P ;; X)"
 
 subsection \<open> Relation Algebra Laws \<close>
 
 theorem RA1: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
   by (simp add: seqr_assoc)
 
 theorem RA2: "(P ;; II) = P" "(II ;; P) = P"
   by simp_all
 
 theorem RA3: "P\<^sup>-\<^sup>- = P"
   by simp
 
 theorem RA4: "(P ;; Q)\<^sup>- = (Q\<^sup>- ;; P\<^sup>-)"
   by simp
 
 theorem RA5: "(P \<or> Q)\<^sup>- = (P\<^sup>- \<or> Q\<^sup>-)"
   by (rel_auto)
 
 theorem RA6: "((P \<or> Q) ;; R) = (P;;R \<or> Q;;R)"
   using seqr_or_distl by blast
 
 theorem RA7: "((P\<^sup>- ;; (\<not>(P ;; Q))) \<or> (\<not>Q)) = (\<not>Q)"
   by (rel_auto)
 
 subsection \<open> Kleene Algebra Laws \<close>
 
 lemma ustar_alt_def: "P\<^sup>\<star> = (\<Sqinter> i \<bullet> P \<^bold>^ i)"
   by (simp add: ustar_def)
 
 theorem ustar_sub_unfoldl: "P\<^sup>\<star> \<sqsubseteq> II \<sqinter> (P;;P\<^sup>\<star>)"
   by (rel_simp, simp add: rtrancl_into_trancl2 trancl_into_rtrancl)
     
 theorem ustar_inductl:
   assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> P ;; Q"
   shows "Q \<sqsubseteq> P\<^sup>\<star> ;; R"
 proof -
   have "P\<^sup>\<star> ;; R = (\<Sqinter> i. P \<^bold>^ i ;; R)"
     by (simp add: ustar_def UINF_as_Sup_collect' seq_SUP_distr)
   also have "Q \<sqsubseteq> ..."
     by (simp add: SUP_least assms upower_inductl)
   finally show ?thesis .
 qed
 
 theorem ustar_inductr:
   assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> Q ;; P"
   shows "Q \<sqsubseteq> R ;; P\<^sup>\<star>"
 proof -
   have "R ;; P\<^sup>\<star> = (\<Sqinter> i. R ;; P \<^bold>^ i)"
     by (simp add: ustar_def UINF_as_Sup_collect' seq_SUP_distl)
   also have "Q \<sqsubseteq> ..."
     by (simp add: SUP_least assms upower_inductr)
   finally show ?thesis .
 qed
 
 lemma ustar_refines_nu: "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
   by (metis (no_types, lifting) lfp_greatest semilattice_sup_class.le_sup_iff 
       semilattice_sup_class.sup_idem upred_semiring.mult_2_right 
       upred_semiring.one_add_one ustar_inductl)
 
 lemma ustar_as_nu: "P\<^sup>\<star> = (\<nu> X \<bullet> (P ;; X) \<sqinter> II)"
 proof (rule antisym)
   show "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
     by (simp add: ustar_refines_nu)
   show "P\<^sup>\<star> \<sqsubseteq> (\<nu> X \<bullet> (P ;; X) \<sqinter> II)"
     by (metis lfp_lowerbound upred_semiring.add_commute ustar_sub_unfoldl)
 qed
 
 lemma ustar_unfoldl: "P\<^sup>\<star> = II \<sqinter> (P ;; P\<^sup>\<star>)"
   apply (simp add: ustar_as_nu)
   apply (subst lfp_unfold)
    apply (rule monoI)
    apply (rel_auto)+
   done
 
 text \<open> While loop can be expressed using Kleene star \<close>
 
 lemma while_star_form:
   "while b do P od = (P \<triangleleft> b \<triangleright>\<^sub>r II)\<^sup>\<star> ;; [(\<not>b)]\<^sup>\<top>"
 proof -
   have 1: "Continuous (\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
     by (rel_auto)
   have "while b do P od = (\<Sqinter>i. ((\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ^^ i) false)"
     by (simp add: "1" false_upred_def sup_continuous_Continuous sup_continuous_lfp while_top_def)
   also have "... = ((\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ^^ 0) false \<sqinter> (\<Sqinter>i. ((\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ^^ (i+1)) false)"
     by (subst Sup_power_expand, simp)
   also have "... = (\<Sqinter>i. ((\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ^^ (i+1)) false)"
     by (simp)
   also have "... = (\<Sqinter>i. (P \<triangleleft> b \<triangleright>\<^sub>r II)\<^bold>^i ;; (false \<triangleleft> b \<triangleright>\<^sub>r II))"
   proof (rule SUP_cong, simp_all)
     fix i
     show "P ;; ((\<lambda>X. P ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ^^ i) false \<triangleleft> b \<triangleright>\<^sub>r II = (P \<triangleleft> b \<triangleright>\<^sub>r II) \<^bold>^ i ;; (false \<triangleleft> b \<triangleright>\<^sub>r II)"
     proof (induct i)
       case 0
       then show ?case by simp
     next
       case (Suc i)
       then show ?case
         by (simp add: upred_semiring.power_Suc)
            (metis (no_types, lifting) RA1 comp_cond_left_distr cond_L6 upred_semiring.mult.left_neutral)
     qed
   qed
   also have "... = (\<Sqinter>i\<in>{0..} \<bullet> (P \<triangleleft> b \<triangleright>\<^sub>r II)\<^bold>^i ;; [(\<not>b)]\<^sup>\<top>)"
     by (rel_auto)
   also have "... = (P \<triangleleft> b \<triangleright>\<^sub>r II)\<^sup>\<star> ;; [(\<not>b)]\<^sup>\<top>"
     by (metis seq_UINF_distr ustar_def)
   finally show ?thesis .
 qed
   
 subsection \<open> Omega Algebra Laws \<close>
 
 lemma uomega_induct:
   "P ;; P\<^sup>\<omega> \<sqsubseteq> P\<^sup>\<omega>"
   by (simp add: uomega_def, metis eq_refl gfp_unfold monoI seqr_mono)
 
 subsection \<open> Refinement Laws \<close>
 
 lemma skip_r_refine:
   "(p \<Rightarrow> p) \<sqsubseteq> II"
   by pred_blast
 
 lemma conj_refine_left:
   "(Q \<Rightarrow> P) \<sqsubseteq> R \<Longrightarrow> P \<sqsubseteq> (Q \<and> R)"
   by (rel_auto)
   
 lemma pre_weak_rel:
   assumes "`Pre \<Rightarrow> I`"
   and     "(I \<Rightarrow> Post) \<sqsubseteq> P"
   shows "(Pre \<Rightarrow> Post) \<sqsubseteq> P"
   using assms by(rel_auto)
     
 lemma cond_refine_rel: 
   assumes "S \<sqsubseteq> (\<lceil>b\<rceil>\<^sub>< \<and> P)" "S \<sqsubseteq> (\<lceil>\<not>b\<rceil>\<^sub>< \<and> Q)"
   shows "S \<sqsubseteq> P \<triangleleft> b \<triangleright>\<^sub>r Q"
   by (metis aext_not assms(1) assms(2) cond_def lift_rcond_def utp_pred_laws.le_sup_iff)
 
 lemma seq_refine_pred:
   assumes "(\<lceil>b\<rceil>\<^sub>< \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> P" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> \<lceil>c\<rceil>\<^sub>>) \<sqsubseteq> Q"
   shows "(\<lceil>b\<rceil>\<^sub>< \<Rightarrow> \<lceil>c\<rceil>\<^sub>>) \<sqsubseteq> (P ;; Q)"
   using assms by rel_auto
     
 lemma seq_refine_unrest:
   assumes "out\<alpha> \<sharp> b" "in\<alpha> \<sharp> c"
   assumes "(b \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> P" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> c) \<sqsubseteq> Q"
   shows "(b \<Rightarrow> c) \<sqsubseteq> (P ;; Q)"
   using assms by rel_blast 
     
  subsection \<open> Domain and Range Laws \<close>
   
 lemma Dom_conv_Ran:
   "Dom(P\<^sup>-) = Ran(P)"
   by (rel_auto)
 
 lemma Ran_conv_Dom:
   "Ran(P\<^sup>-) = Dom(P)"
   by (rel_auto)  
 
 lemma Dom_skip:
   "Dom(II) = true"
   by (rel_auto)
 
 lemma Dom_assigns:
   "Dom(\<langle>\<sigma>\<rangle>\<^sub>a) = true"
   by (rel_auto)
    
 lemma Dom_miracle:
   "Dom(false) = false"
   by (rel_auto)
 
 lemma Dom_assume:
   "Dom([b]\<^sup>\<top>) = b"
   by (rel_auto)
     
 lemma Dom_seq:
   "Dom(P ;; Q) = Dom(P ;; [Dom(Q)]\<^sup>\<top>)"
   by (rel_auto)
     
 lemma Dom_disj:
   "Dom(P \<or> Q) = (Dom(P) \<or> Dom(Q))"
   by (rel_auto)
 
 lemma Dom_inf:
   "Dom(P \<sqinter> Q) = (Dom(P) \<or> Dom(Q))"
   by (rel_auto)
     
 lemma assume_Dom:
   "[Dom(P)]\<^sup>\<top> ;; P = P"
   by (rel_auto)
 
 end
\ No newline at end of file