diff --git a/thys/ADS_Functor/Merkle_Interface.thy b/thys/ADS_Functor/Merkle_Interface.thy
--- a/thys/ADS_Functor/Merkle_Interface.thy
+++ b/thys/ADS_Functor/Merkle_Interface.thy
@@ -1,299 +1,299 @@
 (* Author: Andreas Lochbihler, Digital Asset
    Author: Ognjen Maric, Digital Asset *)
 
 theory Merkle_Interface
 imports
   Main
   "HOL-Library.Conditional_Parametricity"
   "HOL-Library.Monad_Syntax"
 begin
 
 alias vimage2p = BNF_Def.vimage2p
 alias Grp = BNF_Def.Grp
 alias setl = Basic_BNFs.setl
 alias setr = Basic_BNFs.setr
 alias fsts = Basic_BNFs.fsts
 alias snds = Basic_BNFs.snds
 
 attribute_setup locale_witness = \<open>Scan.succeed Locale.witness_add\<close>
 
 lemma vimage2p_mono': "R \<le> S \<Longrightarrow> vimage2p f g R \<le> vimage2p f g S"
   by(auto simp add: vimage2p_def le_fun_def)
 
 lemma vimage2p_map_rel_prod: 
   "vimage2p (map_prod f g) (map_prod f' g') (rel_prod A B) = rel_prod (vimage2p f f' A) (vimage2p g g' B)"
   by(simp add: vimage2p_def prod.rel_map)
 
 lemma vimage2p_map_list_all2:
   "vimage2p (map f) (map g) (list_all2 A) = list_all2 (vimage2p f g A)"
   by(simp add: vimage2p_def list.rel_map)
 
 lemma equivclp_least:
   assumes le: "r \<le> s" and s: "equivp s"
   shows "equivclp r \<le> s"
   apply(rule predicate2I)
   subgoal by(induction rule: equivclp_induct)(auto 4 3 intro: equivp_reflp[OF s] equivp_transp[OF s] equivp_symp[OF s] le[THEN predicate2D])
   done
 
 lemma reflp_eq_onp: "reflp R \<longleftrightarrow> eq_onp (\<lambda>x. True) \<le> R"
   by(auto simp add: reflp_def eq_onp_def)
 
 lemma eq_onpE:
   assumes "eq_onp P x y"
   obtains "x = y" "P y"
   using assms by(auto simp add: eq_onp_def)
 
 lemma case_unit_parametric [transfer_rule]: "rel_fun A (rel_fun (=) A) case_unit case_unit"
   by(simp add: rel_fun_def split: unit.split)
 
 
 (************************************************************)
 section \<open>Authenticated Data Structures\<close>
 (************************************************************)
 
 (************************************************************)
 subsection \<open>Interface\<close>
 (************************************************************)
 
 (************************************************************)
 subsubsection \<open> Types \<close>
 (************************************************************)
 
 type_synonym ('a\<^sub>m, 'a\<^sub>h) hash = "'a\<^sub>m \<Rightarrow> 'a\<^sub>h" \<comment> \<open>Type of hash operation\<close>
 type_synonym 'a\<^sub>m blinding_of = "'a\<^sub>m \<Rightarrow> 'a\<^sub>m \<Rightarrow> bool"
 type_synonym 'a\<^sub>m merge = "'a\<^sub>m \<Rightarrow> 'a\<^sub>m \<Rightarrow> 'a\<^sub>m option" \<comment> \<open> merging that can fail for values with different hashes\<close>
 
 (************************************************************)
 subsubsection \<open> Properties \<close>
 (************************************************************)
 
 locale merkle_interface =
   fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
     and bo :: "'a\<^sub>m blinding_of"
     and m :: "'a\<^sub>m merge"
   assumes merge_respects_hashes: "h a = h b \<longleftrightarrow> (\<exists>ab. m a b = Some ab)"
     and idem: "m a a = Some a"
     and commute: "m a b = m b a"
     and assoc: "m a b \<bind> m c = m b c \<bind> m a"
     and bo_def: "bo a b \<longleftrightarrow> m a b = Some b"
 begin
 
 lemma reflp: "reflp bo"
   unfolding bo_def by(rule reflpI)(simp add: idem)
 
 lemma antisymp: "antisymp bo"
   unfolding bo_def by(rule antisympI)(simp add: commute)
 
 lemma transp: "transp bo"
   apply(rule transpI)
   subgoal for x y z using assoc[of x y z] by(simp add: commute bo_def)
   done
 
 lemma hash: "bo \<le> vimage2p h h (=)"
   unfolding bo_def by(auto simp add: vimage2p_def merge_respects_hashes)
 
 lemma join: "m a b = Some ab \<longleftrightarrow> bo a ab \<and> bo b ab \<and> (\<forall>u. bo a u \<longrightarrow> bo b u \<longrightarrow> bo ab u)"
   unfolding bo_def
-  by (smt Option.bind_cong bind.bind_lunit commute idem merkle_interface.assoc merkle_interface_axioms)
+  by (smt (verit) Option.bind_cong bind.bind_lunit commute idem merkle_interface.assoc merkle_interface_axioms)
 
 text \<open>The equivalence closure of the blinding relation are the equivalence classes of the hash function (the kernel).\<close>
 
 lemma equivclp_blinding_of: "equivclp bo = vimage2p h h (=)" (is "?lhs = ?rhs")
 proof(rule antisym)
   show "?lhs \<le> ?rhs" by(rule equivclp_least[OF hash])(rule equivp_vimage2p[OF identity_equivp])
   show "?rhs \<le> ?lhs" unfolding vimage2p_def
   proof(rule predicate2I)
     fix x y
     assume "h x = h y"
     then obtain xy where "m x y = Some xy" unfolding merge_respects_hashes ..
     hence "bo x xy" "bo y xy" unfolding join by blast+
     hence "equivclp bo x xy" "equivclp bo xy y" by(blast)+
     thus "equivclp bo x y" by(rule equivclp_trans)
   qed
 qed
 
 end
 
 (************************************************************)
 subsection \<open> Auxiliary definitions \<close>
 (************************************************************)
 
 text \<open> Directly proving that an interface satisfies the specification of a Merkle interface as given
 above is difficult. Instead, we provide several layers of auxiliary definitions that can easily be
 proved layer-by-layer. 
 
 In particular, proving that an interface on recursive datatypes is a Merkle interface requires
 induction. As the induction hypothesis only applies to a subset of values of a type, we add
 auxiliary definitions equipped with an explicit set @{term A} of values to which the definition
 applies. Once the induction proof is complete, we can typically instantiate @{term A} with @{term
 UNIV}. In particular, in the induction proof for a layer, we can assume that properties for the
 earlier layers hold for \<^emph>\<open>all\<close> values, not just those in the induction hypothesis.
 \<close>
 
 (************************************************************)
 subsubsection \<open> Blinding \<close>
 (************************************************************)
 locale blinding_respects_hashes =
   fixes h :: "('a\<^sub>m, 'a\<^sub>h) hash"
     and bo :: "'a\<^sub>m blinding_of"
   assumes hash: "bo \<le> vimage2p h h (=)"
 begin
 
 lemma blinding_hash_eq: "bo x y \<Longrightarrow> h x = h y"
   by(drule hash[THEN predicate2D])(simp add: vimage2p_def)
 
 end
 
 locale blinding_of_on =
   blinding_respects_hashes h bo
     for A :: "'a\<^sub>m set"
     and h :: "('a\<^sub>m, 'a\<^sub>h) hash"
     and bo :: "'a\<^sub>m blinding_of"
   + assumes refl: "x \<in> A \<Longrightarrow> bo x x"
     and trans: "\<lbrakk> bo x y; bo y z; x \<in> A \<rbrakk> \<Longrightarrow> bo x z"
     and antisym: "\<lbrakk> bo x y; bo y x; x \<in> A \<rbrakk> \<Longrightarrow> x = y"
 begin
 
 lemma refl_pointfree: "eq_onp (\<lambda>x. x \<in> A) \<le> bo"
   by(auto elim!: eq_onpE intro: refl)
 
 lemma blinding_respects_hashes: "blinding_respects_hashes h bo" ..
 lemmas hash = hash
 
 lemma trans_pointfree: "eq_onp (\<lambda>x. x \<in> A) OO bo OO bo \<le> bo"
   by(auto elim!: eq_onpE intro: trans)
 
 lemma antisym_pointfree: "inf (eq_onp (\<lambda>x. x \<in> A) OO bo) bo\<inverse>\<inverse> \<le> (=)"
   by(auto elim!: eq_onpE dest: antisym)
 
 end
 
 (************************************************************)
 subsubsection \<open> Merging \<close>
 (************************************************************)
 
 text \<open> In general, we prove the properties of blinding before the properties of merging. Thus,
   in the following definitions we assume that the blinding properties already hold on @{term UNIV}.
   The @{term Ball} restricts the argument of the merge operation on which induction will be done. \<close>
 
 locale merge_on =
   blinding_of_on UNIV h bo
     for A :: "'a\<^sub>m set"
     and h :: "('a\<^sub>m, 'a\<^sub>h) hash"
     and bo :: "'a\<^sub>m blinding_of" 
     and m :: "'a\<^sub>m merge" +
   assumes join: "\<lbrakk> h a = h b; a \<in> A \<rbrakk> 
       \<Longrightarrow> \<exists>ab. m a b = Some ab \<and> bo a ab \<and> bo b ab \<and> (\<forall>u. bo a u \<longrightarrow> bo b u \<longrightarrow> bo ab u)"
     and undefined: "\<lbrakk> h a \<noteq> h b; a \<in> A \<rbrakk> \<Longrightarrow> m a b = None"
 begin
 
 lemma same: "a \<in> A \<Longrightarrow> m a a = Some a"
   using join[of a a] refl[of a] by(auto 4 3 intro: antisym)
 
 lemma blinding_of_antisym_on: "blinding_of_on UNIV h bo" ..
 
 lemma transp: "transp bo"
   by(auto intro: transpI trans)
 
 lemmas hash = hash
   and refl = refl
   and antisym = antisym[OF _ _ UNIV_I]
 
 lemma respects_hashes:
   "a \<in> A \<Longrightarrow> h a = h b \<longleftrightarrow> (\<exists>ab. m a b = Some ab)"
   using join undefined
   by fastforce
 
 lemma join':
   "a \<in> A \<Longrightarrow> \<forall>ab. m a b = Some ab \<longleftrightarrow> bo a ab \<and> bo b ab \<and> (\<forall>u. bo a u \<longrightarrow> bo b u \<longrightarrow> bo ab u)"
   using join undefined
   by (metis (full_types) hash local.antisym option.distinct(1) option.sel predicate2D vimage2p_def)
 
 lemma merge_on_subset:
   "B \<subseteq> A \<Longrightarrow> merge_on B h bo m"
   by unfold_locales (auto dest: same join undefined)
 
 end
 
 subsection \<open> Interface equality \<close>
 
 text \<open> Here, we prove that the auxiliary definitions specify the same interface as the original ones.\<close>
 
 lemma merkle_interface_aux: "merkle_interface h bo m = merge_on UNIV h bo m" 
   (is "?lhs = ?rhs")
 proof
   show ?rhs if ?lhs
   proof
     interpret merkle_interface h bo m by(fact that)
     show "bo \<le> vimage2p h h (=)" by(fact hash)
     show "bo x x" for x using reflp by(simp add: reflp_def)
     show "bo x z" if "bo x y" "bo y z" for x y z using transp that by(rule transpD)
     show "x = y" if "bo x y" "bo y x" for x y using antisymp that by(rule antisympD)
     show "\<exists>ab. m a b = Some ab \<and> bo a ab \<and> bo b ab \<and> (\<forall>u. bo a u \<longrightarrow> bo b u \<longrightarrow> bo ab u)" if "h a = h b" for a b
       using that by(simp add: merge_respects_hashes join)
     show "m a b = None" if "h a \<noteq> h b" for a b using that by(simp add: merge_respects_hashes)
   qed
 
   show ?lhs if ?rhs
   proof
     interpret merge_on UNIV h bo m by(fact that)
     show eq: "h a = h b \<longleftrightarrow> (\<exists>ab. m a b = Some ab)" for a b by(simp add: respects_hashes)
     show idem: "m a a = Some a" for a by(simp add: same)
     show commute: "m a b = m b a" for a b 
       using join[of a b] join[of b a] undefined antisym by(cases "m a b") force+
     have undefined_partitioned: "m a c = None" if "m a b = None" "m b c = Some bc" for a b c bc
       using that eq by (metis option.distinct(1) option.exhaust)
     have merge_twice: "m a b = Some c \<Longrightarrow> m a c = Some c" for a b c by (simp add: join')
     show "m a b \<bind> m c = m b c \<bind> m a" for a b c
     proof(simp split: Option.bind_split; safe)
       show "None = m a d" if "m a b = None" "m b c = Some d" for d using that
         by(metis undefined_partitioned merge_twice)
       show "m c d = None" if "m a b = Some d" "m b c = None" for d using that
         by(metis commute merge_twice undefined_partitioned)
     next
       fix ab bc
       assume assms: "m a b = Some ab" "m b c = Some bc"
       then obtain cab and abc where cab: "m c ab = Some cab" and abc: "m a bc = Some abc"
         using eq[THEN iffD2, OF exI] eq[THEN iffD1] by (metis merge_twice)
       thus "m c ab = m a bc" using assms
         by(clarsimp simp add: join')(metis UNIV_I abc cab local.antisym local.trans)
     qed
     show "bo a b \<longleftrightarrow> m a b = Some b" for a b using idem join' by auto
   qed
 qed
 
 lemma merkle_interfaceI [locale_witness]:
   assumes "merge_on UNIV h bo m"
   shows "merkle_interface h bo m"
   using assms unfolding merkle_interface_aux by auto
 
 lemma (in merkle_interface) merkle_interfaceD: "merge_on UNIV h bo m"
   using merkle_interface_aux[of h bo m, symmetric]
   by simp unfold_locales
 
 subsection \<open> Parametricity rules \<close>
 
 context includes lifting_syntax begin
 parametric_constant le_fun_parametric[transfer_rule]: le_fun_def
 parametric_constant vimage2p_parametric[transfer_rule]: vimage2p_def
 parametric_constant blinding_respects_hashes_parametric_aux: blinding_respects_hashes_def
 
 lemma blinding_respects_hashes_parametric [transfer_rule]:
   "((A1 ===> A2) ===> (A1 ===> A1 ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>))
    blinding_respects_hashes blinding_respects_hashes"
   if [transfer_rule]: "bi_unique A2" "bi_total A1"
   by(rule blinding_respects_hashes_parametric_aux that le_fun_parametric | simp add: rel_fun_eq)+
 
 parametric_constant blinding_of_on_axioms_parametric [transfer_rule]:
   blinding_of_on_axioms_def[folded Ball_def, unfolded le_fun_def le_bool_def eq_onp_def relcompp.simps, simplified]
 parametric_constant blinding_of_on_parametric [transfer_rule]: blinding_of_on_def
 parametric_constant antisymp_parametric[transfer_rule]: antisymp_def
 parametric_constant transp_parametric[transfer_rule]: transp_def
 
 parametric_constant merge_on_axioms_parametric [transfer_rule]: merge_on_axioms_def
 parametric_constant merge_on_parametric[transfer_rule]: merge_on_def
 
 parametric_constant merkle_interface_parametric[transfer_rule]: merkle_interface_def
 end
 
 end
\ No newline at end of file
diff --git a/thys/AxiomaticCategoryTheory/AxiomaticCategoryTheory.thy b/thys/AxiomaticCategoryTheory/AxiomaticCategoryTheory.thy
--- a/thys/AxiomaticCategoryTheory/AxiomaticCategoryTheory.thy
+++ b/thys/AxiomaticCategoryTheory/AxiomaticCategoryTheory.thy
@@ -1,679 +1,679 @@
 (*<*)
 theory AxiomaticCategoryTheory imports Main
 
 abbrevs
  f_neg="\<^bold>\<not>" and f_or="\<^bold>\<or>" and f_and="\<^bold>\<and>" and f_impl="\<^bold>\<rightarrow>" and f_imp="\<^bold>\<leftarrow>" and mequ="\<^bold>\<leftrightarrow>" and f_all="\<^bold>\<forall>"
  and f_exi="\<^bold>\<exists>" and f_all2="(\<^bold>\<forall>x.)" and f_exi2="(\<^bold>\<exists>x.)" and f_kleeneeq="\<cong>" and f_primeq="\<simeq>" and
  f_comp2="(\<cdot>)" and f_comp="\<cdot>"
 
 begin
  (*Begin: some useful parameter settings*)
   nitpick_params[user_axioms, show_all, format = 2, expect = genuine]
  (*End: some useful parameter settings*)
 (*>*)
 
 section\<open>Introduction\<close>
 
   text\<open>This document provides a concise overview on the core results of our previous
        work \cite{C67,R58,C57} on the exploration of axiom systems for category theory.
        Extending the previous studies we
        include one further axiomatic theory in our experiments. This additional
        theory has been suggested by Mac Lane~\cite{MacLane48} in
        1948. We show that the axioms proposed by Mac Lane are equivalent to the ones studied
        in~\cite{R58}, which includes an axioms set suggested by Scott~\cite{Scott79}
        in the 1970s and another axioms set proposed by Freyd and Scedrov~\cite{FreydScedrov90} in 1990,
        which we slightly modified in~\cite{R58} to remedy a minor technical issue.
 
       The explanations given below are minimal, for more details we refer to the referenced
       papers, in particular, to~\cite{R58}.\<close>
 
 
 section\<open>Embedding of Free Logic in HOL\<close>
 
 text\<open>We introduce a shallow semantical embedding of free logic \cite{R58} in Isabelle/HOL.
      Definite description is omitted, since it is not needed in the studies below and also
      since the definition provided in \cite{C57} introduces the here undesired commitment
      that at least one non-existing element of type $i$ is a priori given. We here want to
      consider this an optional condition.\<close>
 
  typedecl i \<comment> \<open>Type for individuals\<close>
  consts fExistence:: "i\<Rightarrow>bool" ("E") \<comment> \<open>Existence/definedness predicate in free logic\<close>
 
  abbreviation fNot   ("\<^bold>\<not>")               where "\<^bold>\<not>\<phi> \<equiv> \<not>\<phi>"
  abbreviation fImpl  (infixr "\<^bold>\<rightarrow>" 13)  where "\<phi> \<^bold>\<rightarrow> \<psi> \<equiv> \<phi> \<longrightarrow> \<psi>"
  abbreviation fId     (infixr "\<^bold>=" 25)   where "l \<^bold>= r \<equiv> l = r"
  abbreviation fAll    ("\<^bold>\<forall>")               where "\<^bold>\<forall>\<Phi> \<equiv> \<forall>x. E x \<longrightarrow> \<Phi> x"
  abbreviation fAllBi (binder "\<^bold>\<forall>" [8]9) where "\<^bold>\<forall>x. \<phi> x \<equiv> \<^bold>\<forall>\<phi>"
  abbreviation fOr    (infixr "\<^bold>\<or>" 21)     where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<rightarrow> \<psi>"
  abbreviation fAnd   (infixr "\<^bold>\<and>" 22)     where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>(\<^bold>\<not>\<phi> \<^bold>\<or> \<^bold>\<not>\<psi>)"
  abbreviation fImpli (infixr "\<^bold>\<leftarrow>" 13)    where "\<phi> \<^bold>\<leftarrow> \<psi> \<equiv> \<psi> \<^bold>\<rightarrow> \<phi>"
  abbreviation fEquiv (infixr "\<^bold>\<leftrightarrow>" 15)    where "\<phi> \<^bold>\<leftrightarrow> \<psi> \<equiv> (\<phi> \<^bold>\<rightarrow> \<psi>) \<^bold>\<and> (\<psi> \<^bold>\<rightarrow> \<phi>)"
  abbreviation fEx     ("\<^bold>\<exists>")                 where "\<^bold>\<exists>\<Phi> \<equiv> \<^bold>\<not>(\<^bold>\<forall>(\<lambda>y. \<^bold>\<not>(\<Phi> y)))"
  abbreviation fExiBi (binder "\<^bold>\<exists>" [8]9)  where "\<^bold>\<exists>x. \<phi> x \<equiv> \<^bold>\<exists>\<phi>"
 
 
 
 section\<open>Some Basic Notions in Category Theory\<close>
 
 text \<open>Morphisms in the category are modeled as objects of type $i$.
 We introduce three partial functions,
 $dom$ (domain), $cod$ (codomain), and morphism composition ($\cdot$).
 
 For composition we assume set-theoretical composition here (i.e., functional
 composition from right to left). \label{IDMcL}\<close>
 
  consts
   domain:: "i\<Rightarrow>i" ("dom _" [108] 109)
   codomain:: "i\<Rightarrow>i" ("cod _" [110] 111)
   composition:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<cdot>" 110)
 
  \<comment> \<open>Kleene Equality\<close>
  abbreviation KlEq (infixr "\<cong>" 56) where "x \<cong> y \<equiv> (E x \<^bold>\<or> E y) \<^bold>\<rightarrow> x \<^bold>= y"
  \<comment> \<open>Existing Identity\<close>
  abbreviation ExId (infixr "\<simeq>" 56) where "x \<simeq> y \<equiv> (E x \<^bold>\<and> E y \<^bold>\<and> x \<^bold>= y)"
 
  \<comment> \<open>Identity-morphism: see also p.~4. of \cite{FreydScedrov90}.\<close>
  abbreviation "ID i \<equiv> (\<^bold>\<forall>x. E(i\<cdot>x) \<^bold>\<rightarrow> i\<cdot>x \<cong> x) \<^bold>\<and> (\<^bold>\<forall>x. E(x\<cdot>i) \<^bold>\<rightarrow> x\<cdot>i \<cong> x)"
  \<comment> \<open>Identity-morphism: Mac Lane's definition, the same as ID except for notion of equality.\<close>
  abbreviation "IDMcL \<rho> \<equiv> (\<^bold>\<forall>\<alpha>. E(\<rho>\<cdot>\<alpha>) \<^bold>\<rightarrow> \<rho>\<cdot>\<alpha> = \<alpha>) \<^bold>\<and> (\<^bold>\<forall>\<beta>. E(\<beta>\<cdot>\<rho>) \<^bold>\<rightarrow> \<beta>\<cdot>\<rho> = \<beta>)"
 
  \<comment> \<open>The two notions of identity-morphisms are obviously equivalent.\<close>
  lemma IDPredicates: "ID \<equiv> IDMcL" by auto
 
 
 section\<open>The Axioms Sets studied by Benzm\"uller and Scott \cite{R58}\<close>
 
 subsection\<open>AxiomsSet1\<close>
 
  text\<open>AxiomsSet1 generalizes the notion of a monoid by introducing a partial, strict binary
       composition operation ``$\cdot$''. The existence of left and right identity elements is
       addressed in axioms @{term "C\<^sub>i"} and @{term "D\<^sub>i"}. The notions of $dom$ (domain) and
       $cod$ (codomain)
       abstract from their common meaning in the context of sets. In category theory we
      work with just a single type of objects (the type $i$ in our setting) and therefore
      identity morphisms are employed to suitably characterize their
      meanings.\<close>
 
  locale AxiomsSet1 =
   assumes
    S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
    E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
    A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
    C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" and
    D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
 
    lemma E\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i C\<^sub>i S\<^sub>i)
    \<comment> \<open>Uniqueness of i and j in the latter two axioms.\<close>
    lemma UC\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y \<^bold>\<and> (\<^bold>\<forall>j.(ID j \<^bold>\<and> j\<cdot>y \<cong> y) \<^bold>\<rightarrow> i \<cong> j)" by (smt (verit) A\<^sub>i C\<^sub>i S\<^sub>i)
    lemma UD\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x \<^bold>\<and> (\<^bold>\<forall>i.(ID i \<^bold>\<and> x\<cdot>i \<cong> x) \<^bold>\<rightarrow> j \<cong> i)" by (smt (verit) A\<^sub>i D\<^sub>i S\<^sub>i)
    \<comment> \<open>But i and j need not to equal.\<close>
    lemma "(\<exists>C D. (\<^bold>\<forall>y. ID (C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. ID (D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
      nitpick [satisfy] oops \<comment> \<open>Model found\<close>
    lemma "(\<exists>x. E x) \<^bold>\<and> (\<exists>C D. (\<^bold>\<forall>y. ID(C y) \<^bold>\<and> (C y)\<cdot>y \<cong> y) \<^bold>\<and> (\<^bold>\<forall>x. ID(D x) \<^bold>\<and> x\<cdot>(D x) \<cong> x) \<^bold>\<and> \<^bold>\<not>(D \<^bold>= C))"
      nitpick [satisfy] oops \<comment> \<open>Model found\<close>
   end
 
 
 
 subsection\<open>AxiomsSet2\<close>
 
 text\<open>AxiomsSet2 is developed from AxiomsSet1 by Skolemization of the
      existentially quantified variables $i$ and $j$ in axioms $C_i$ and
      $D_i$. We can argue semantically that every model of AxiomsSet1 has
      such functions. Hence, we get a conservative extension of AxiomsSet1.
      The strictness axiom $S$ is extended, so
      that strictness is now also postulated for the new Skolem functions
      $dom$ and $cod$.\<close>
 
  locale AxiomsSet2 =
   assumes
    S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
    E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" and
    A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
    C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
    D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
 
    lemma E\<^sub>i\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i\<^sub>i C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
    lemma domTotal: "E x \<^bold>\<rightarrow> E(dom x)" by (metis D\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
    lemma codTotal: "E x \<^bold>\<rightarrow> E(cod x)" by (metis C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
   end
 
  subsubsection\<open>AxiomsSet2 entails AxiomsSet1\<close>
 
  context AxiomsSet2
   begin
    lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S\<^sub>i\<^sub>i by blast
    lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" using E\<^sub>i\<^sub>i by blast
    lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i by blast
    lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" by (metis C\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
    lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x" by (metis D\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
   end
 
  subsubsection\<open>AxiomsSet1 entails AxiomsSet2 (by semantic means)\<close>
  text\<open>By semantic means (Skolemization).\<close>
 
 
 
  subsection\<open>AxiomsSet3\<close>
 
  text\<open>In AxiomsSet3 the existence  axiom  $E_{ii}$ from AxiomsSet2  is simplified by taking
       advantage of the two new Skolem functions $dom$ and $cod$.
 
       The left-to-right direction of existence axiom $E_{iii}$ is implied.\<close>
 
  locale AxiomsSet3 =
   assumes
    S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
    E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
    A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
    C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" and
    D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
 
    lemma E\<^sub>i\<^sub>i\<^sub>iImpl: "E(x\<cdot>y) \<^bold>\<rightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
   end
 
 
  subsubsection\<open>AxiomsSet3 entails AxiomsSet2\<close>
 
  context AxiomsSet3
   begin
    lemma S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>i\<^sub>i by blast
    lemma E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
    lemma A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i\<^sub>i by blast
    lemma C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>i\<^sub>i\<^sub>i by auto
    lemma D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using D\<^sub>i\<^sub>i\<^sub>i by auto
   end
 
 
  subsubsection\<open>AxiomsSet2 entails AxiomsSet3\<close>
 
  context AxiomsSet2
   begin
    lemma S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>i by blast
    lemma E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis C\<^sub>i\<^sub>i D\<^sub>i\<^sub>i E\<^sub>i\<^sub>i S\<^sub>i\<^sub>i)
    lemma A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i by blast
    lemma C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>i\<^sub>i by auto
    lemma D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using D\<^sub>i\<^sub>i by auto
   end
 
 
 
 
   subsection\<open>The Axioms Set AxiomsSet4\<close>
 
   text\<open>AxiomsSet4 simplifies the axioms $C_{iii}$ and  $D_{iii}$. However, as it turned
        out, these simplifications also require the existence axiom $E_{iii}$ to be strengthened
        into an equivalence.\<close>
 
  locale AxiomsSet4 =
   assumes
    S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  and
    E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" and
    A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
    C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" and
    D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
  subsubsection\<open>AxiomsSet4 entails AxiomsSet3\<close>
 
  context AxiomsSet4
   begin
    lemma S\<^sub>i\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S\<^sub>i\<^sub>v by blast
    lemma E\<^sub>i\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (dom x \<cong> cod y \<^bold>\<and> (E(cod y)))" using E\<^sub>i\<^sub>v by blast
    lemma A\<^sub>i\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>v by blast
    lemma C\<^sub>i\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
    lemma D\<^sub>i\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" by (metis C\<^sub>i\<^sub>v D\<^sub>i\<^sub>v E\<^sub>i\<^sub>v)
   end
 
 
  subsubsection\<open>AxiomsSet3 entails AxiomsSet4\<close>
 
  context AxiomsSet3
   begin
    lemma S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)"  using S\<^sub>i\<^sub>i\<^sub>i by blast
    lemma E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" by (metis (full_types) A\<^sub>i\<^sub>i\<^sub>i C\<^sub>i\<^sub>i\<^sub>i D\<^sub>i\<^sub>i\<^sub>i E\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i)
    lemma A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>i\<^sub>i by blast
    lemma C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" using C\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
    lemma D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x" using D\<^sub>i\<^sub>i\<^sub>i S\<^sub>i\<^sub>i\<^sub>i by blast
   end
 
 
 
 
 subsection\<open>AxiomsSet5\<close>
 
   text\<open>AxiomsSet5 has been proposed by Scott \cite{Scott79} in the 1970s. This set of
  axioms is equivalent to the axioms set presented by Freyd and Scedrov in their textbook
  ``Categories, Allegories'' \cite{FreydScedrov90} when encoded in free logic, corrected/adapted
  and further simplified, see Section 5.\<close>
 
  locale AxiomsSet5 =
   assumes
    S1: "E(dom x) \<^bold>\<rightarrow> E x" and
    S2: "E(cod y) \<^bold>\<rightarrow> E y" and
    S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
    S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" and
    S5: "(cod y)\<cdot>y \<cong> y" and
    S6: "x\<cdot>(dom x) \<cong> x"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
 
 
  subsubsection\<open>AxiomsSet5 entails AxiomsSet4\<close>
 
  context AxiomsSet5
   begin
    lemma S\<^sub>i\<^sub>v: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using S1 S2 S3 by blast
    lemma E\<^sub>i\<^sub>v: "E(x\<cdot>y) \<^bold>\<leftrightarrow> (dom x \<cong> cod y \<^bold>\<and> E(cod y))" using S3 by metis
    lemma A\<^sub>i\<^sub>v: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
    lemma C\<^sub>i\<^sub>v: "(cod y)\<cdot>y \<cong> y" using S5 by blast
    lemma D\<^sub>i\<^sub>v: "x\<cdot>(dom x) \<cong> x" using S6 by blast
   end
 
 
  subsubsection\<open>AxiomsSet4 entails AxiomsSet5\<close>
 
  context AxiomsSet4
   begin
    lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" using S\<^sub>i\<^sub>v by blast
    lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" using S\<^sub>i\<^sub>v by blast
    lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" using E\<^sub>i\<^sub>v by metis
    lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A\<^sub>i\<^sub>v by blast
    lemma S5: "(cod y)\<cdot>y \<cong> y" using C\<^sub>i\<^sub>v by blast
    lemma S6: "x\<cdot>(dom x) \<cong> x" using D\<^sub>i\<^sub>v by blast
   end
 
 
 
 
 section\<open>The Axioms Sets by Freyd and Scedrov \cite{FreydScedrov90}\<close>
 
 subsection\<open>AxiomsSet6\<close>
 text\<open>The axioms by Freyd and Scedrov  \cite{FreydScedrov90} in our notation, when being
      corrected (cf. the modification in axiom A1).
 
      Freyd and Scedrov employ a different notation for $dom\ x$ and $cod\ 
      x$. They denote these operations by $\Box x$
      and $x\Box$. Moreover, they employ diagrammatic composition instead of the set-theoretic
      definition (functional composition from right to left) used so
      far.
      We leave it to the reader to verify that their axioms corresponds to the axioms presented
      here modulo an appropriate conversion of notation.\<close>
 
  locale AxiomsSet6 =
   assumes
     A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" and
    A2a: "cod(dom x) \<cong> dom x" and
    A2b: "dom(cod y) \<cong> cod y" and
    A3a: "x\<cdot>(dom x) \<cong> x" and
    A3b: "(cod y)\<cdot>y \<cong> y" and
    A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
    A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
     A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
 end
 
 
  subsubsection\<open>AxiomsSet6 entails AxiomsSet5\<close>
 
  context AxiomsSet6
   begin
    lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" by (metis A1 A2a A3a)
    lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" using A1 A2b A3b by metis
    lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis A1)
    lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using A5 by blast
    lemma S5: "(cod y)\<cdot>y \<cong> y" using A3b by blast
    lemma S6: "x\<cdot>(dom x) \<cong> x" using A3a by blast
 
    lemma A4aRedundant: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" using A1 A2a A3a A5 by metis
    lemma A4bRedundant: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" using A1 A2b A3b A5 by (smt (verit))
-   lemma A2aRedundant: "cod(dom x) \<cong> dom x" using A1 A3a A3b A4a A4b by smt
-   lemma A2bRedundant: "dom(cod y) \<cong> cod y" using  A1 A3a A3b A4a A4b by smt
+   lemma A2aRedundant: "cod(dom x) \<cong> dom x" using A1 A3a A3b A4a A4b by (smt (verit))
+   lemma A2bRedundant: "dom(cod y) \<cong> cod y" using  A1 A3a A3b A4a A4b by (smt (verit))
   end
 
 
  subsubsection\<open>AxiomsSet5 entails AxiomsSet6\<close>
 
  context AxiomsSet5
   begin
    lemma A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" using S3 by blast
    lemma A2: "cod(dom x) \<cong> dom x" by (metis S1 S2 S3 S6)
    lemma A2b: "dom(cod y) \<cong> cod y" using S1 S2 S3 S5 by metis
    lemma A3a: "x\<cdot>(dom x) \<cong> x" using S6 by auto
    lemma A3b: "(cod y)\<cdot>y \<cong> y" using S5 by blast
    lemma A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis S1 S3 S4 S5 S6)
    lemma A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis (full_types) S2 S3 S4 S5 S6)
    lemma  A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
   end
 
 
 
 subsection\<open>AxiomsSet7 (technically flawed)\<close>
   text\<open>The axioms by Freyd and Scedrov in our notation, without the suggested correction of
        axiom A1. This axioms set is technically flawed
        when encoded in our given context. It leads to a constricted inconsistency.\<close>
 
 
  locale AxiomsSet7 =
   assumes
     A1: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
    A2a: "cod(dom x) \<cong> dom x " and
    A2b: "dom(cod y) \<cong> cod y" and
    A3a: "x\<cdot>(dom x) \<cong> x" and
    A3b: "(cod y)\<cdot>y \<cong> y" and
    A4a: "dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
    A4b: "cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
     A5: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    (*
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  --{*No model found*}
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  --{*No model found*}
    *)
    lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False" by (metis A1 A2a A3a) \<comment> \<open>Inconsistency\<close>
    lemma "\<forall>x. E x" using InconsistencyAutomatic by auto
 
    lemma InconsistencyInteractive:
     assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
     proof -
     obtain a where 1: "\<^bold>\<not>(E a)" using NEx by auto
     have 2: "a\<cdot>(dom a) \<cong> a" using A3a by blast
     have 3: "\<^bold>\<not>(E(a\<cdot>(dom a)))" using 1 2 by metis
     have 4: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> cod(dom a)" using A1 by blast
     have 5: "cod(dom a) \<cong> dom a" using A2a by blast
     have 6: "E(a\<cdot>(dom a)) \<^bold>\<leftrightarrow> dom a \<cong> dom a" using 4 5 by auto
     have 7: "E(a\<cdot>(dom a))" using 6 by blast
     then show ?thesis using 7 3 by blast
     qed
   end
 
 
 
 subsection\<open>AxiomsSet7orig (technically flawed)\<close>
 
 text\<open>The axioms by Freyd and Scedrov in their original notation, without the suggested
      correction of axiom A1.
 
       We present the constricted inconsistency argument from above once again,
       but this time in the original notation of Freyd and Scedrov.\<close>
 
  locale AxiomsSet7orig =
   fixes
    source:: "i\<Rightarrow>i" ("\<box>_" [108] 109) and
    target:: "i\<Rightarrow>i" ("_\<box>" [110] 111) and
    compositionF:: "i\<Rightarrow>i\<Rightarrow>i" (infix "\<^bold>\<cdot>" 110)
   assumes
     A1: "E(x\<^bold>\<cdot>y) \<^bold>\<leftrightarrow> (x\<box> \<cong> \<box>y)" and
    A2a: "((\<box>x)\<box>) \<cong> \<box>x" and
    A2b: "\<box>(x\<box>) \<cong> \<box>x" and
    A3a: "(\<box>x)\<^bold>\<cdot>x \<cong> x" and
    A3b: "x\<^bold>\<cdot>(x\<box>) \<cong> x" and
    A4a: "\<box>(x\<^bold>\<cdot>y) \<cong> \<box>(x\<^bold>\<cdot>(\<box>y))" and
    A4b: "(x\<^bold>\<cdot>y)\<box> \<cong> ((x\<box>)\<^bold>\<cdot>y)\<box>" and
     A5: "x\<^bold>\<cdot>(y\<^bold>\<cdot>z) \<cong> (x\<^bold>\<cdot>y)\<^bold>\<cdot>z"
   begin
    lemma True nitpick [satisfy] oops \<comment> \<open>Consistency\<close>
    (*
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  --{*No model found*}
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  --{*No model found*}
     *)
    lemma InconsistencyAutomatic: "(\<exists>x. \<^bold>\<not>(E x)) \<^bold>\<rightarrow> False" by (metis A1 A2a A3a) \<comment> \<open>Inconsistency\<close>
    lemma "\<forall>x. E x" using InconsistencyAutomatic by auto
 
    lemma InconsistencyInteractive:
     assumes NEx: "\<exists>x. \<^bold>\<not>(E x)" shows False
     proof -
     obtain a where 1: "\<^bold>\<not>(E a)" using assms by auto
     have 2: "(\<box>a)\<^bold>\<cdot>a \<cong> a" using A3a by blast
     have 3: "\<^bold>\<not>(E((\<box>a)\<^bold>\<cdot>a))" using 1 2 by metis
     have 4: "E((\<box>a)\<^bold>\<cdot>a) \<^bold>\<leftrightarrow> (\<box>a)\<box> \<cong> \<box>a" using A1 by blast
     have 5: "(\<box>a)\<box> \<cong> \<box>a" using A2a by blast
     have 6: "E((\<box>a)\<^bold>\<cdot>a)" using 4 5 by blast
     then show ?thesis using 6 3 by blast
     qed
   end
 
 
 subsection\<open>AxiomsSet8 (algebraic reading, still technically flawed)\<close>
 
  text\<open>The axioms by Freyd and Scedrov in our notation again, but this time we adopt
       an algebraic reading of the free variables, meaning that they range over existing
       morphisms only.\<close>
 
  locale AxiomsSet8 =
   assumes
     B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" and
    B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " and
    B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" and
    B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" and
    B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" and
    B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" and
    B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" and
     B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
 
  text\<open>None of the axioms in AxiomsSet5 are implied.\<close>
 
  context AxiomsSet8
   begin
    lemma S1: "E(dom x) \<^bold>\<rightarrow> E x" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
    lemma S2: "E(cod y) \<^bold>\<rightarrow> E y" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
    lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
    lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
    lemma S5: "(cod y)\<cdot>y \<cong> y"  nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
    lemma S6: "x\<cdot>(dom x) \<cong> x"  nitpick oops \<comment> \<open>Nitpick finds a countermodel\<close>
   end
 
 
 subsection\<open>AxiomsSet8Strict (algebraic reading)\<close>
 
  text\<open>The situation changes when strictness conditions are postulated. Note that in the algebraic
       framework of Freyd and Scedrov such conditions have to be assumed as given in the
       logic, while here we can explicitly encode them as axioms.\<close>
 
  locale AxiomsSet8Strict = AxiomsSet8 +
   assumes
    B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
    B0b: "E(dom x) \<^bold>\<rightarrow> E x" and
    B0c: "E(cod x) \<^bold>\<rightarrow> E x"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
 
  subsubsection\<open>AxiomsSet8Strict entails AxiomsSet5\<close>
 
  context AxiomsSet8Strict
   begin
    lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"  using B0b by blast
    lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"  using B0c by blast
    lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis B0a B0b B0c B1 B3a)
    lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (meson B0a B5)
    lemma S5: "(cod y)\<cdot>y \<cong> y" using B0a B3b by blast
    lemma S6: "x\<cdot>(dom x) \<cong> x" using B0a B3a by blast
   end
 
 
  subsubsection\<open>AxiomsSet5 entails AxiomsSet8Strict\<close>
 
  context AxiomsSet5
   begin
    lemma B0a: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S1 S2 S3 by blast
    lemma B0b: "E(dom x) \<^bold>\<rightarrow> E x" using S1 by blast
    lemma B0c: "E(cod x) \<^bold>\<rightarrow> E x" using S2 by blast
    lemma  B1: "\<^bold>\<forall>x.\<^bold>\<forall>y. E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<cong> cod y" by (metis S3 S5)
    lemma B2a: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x" using A2 by blast
    lemma B2b: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" using A2b by blast
    lemma B3a: "\<^bold>\<forall>x. x\<cdot>(dom x) \<cong> x" using S6 by blast
    lemma B3b: "\<^bold>\<forall>y. (cod y)\<cdot>y \<cong> y" using S5 by blast
    lemma B4a: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis S1 S3 S4 S6)
    lemma B4b: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis S1 S2 S3 S4 S5)
    lemma  B5: "\<^bold>\<forall>x.\<^bold>\<forall>y.\<^bold>\<forall>z. x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" using S4 by blast
   end
 
 
   subsubsection\<open>AxiomsSet8Strict is Redundant\<close>
 
   text\<open>AxiomsSet8Strict is redundant: either the B2-axioms can be omitted or the B4-axioms.\<close>
 
  context AxiomsSet8Strict
   begin
    lemma B2aRedundant: "\<^bold>\<forall>x. cod(dom x) \<cong> dom x " by (metis B0a B1 B3a)
    lemma B2bRedundant: "\<^bold>\<forall>y. dom(cod y) \<cong> cod y" by (metis B0a B1 B3b)
    lemma B4aRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. dom(x\<cdot>y) \<cong> dom((dom x)\<cdot>y)" by (metis B0a B0b B1 B3a B5)
    lemma B4bRedundant: "\<^bold>\<forall>x.\<^bold>\<forall>y. cod(x\<cdot>y) \<cong> cod(x\<cdot>(cod y))" by (metis B0a B0c B1 B3b B5)
   end
 
 
 
 
 
   section\<open>The Axioms Sets of Mac Lane \cite{MacLane48}\<close>
 
   text\<open>We analyse the axioms set suggested by Mac Lane~\cite{MacLane48} already in 1948.
       As for the theory by
        Freyd and Scedrov above, which was developed much later, we need to assume
        strictness of composition to show equivalence to our previous axiom sets.
        Note that his complicated conditions on existence of compositions proved to be
        unnecessary, as we show. It shows it is hard to think about partial operations.\<close>
 
 
  locale AxiomsSetMcL =
   assumes
    C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" and
    C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" and
    C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" and
    C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" and
    C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" and
    C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
   text\<open>Remember that IDMcL  was defined on p.~\pageref{IDMcL} and proved
        equivalent to ID.\<close>
 
 
  subsection\<open>AxiomsSetMcL entails AxiomsSet1\<close>
 
  context AxiomsSetMcL
   begin
    lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"  using C\<^sub>0 by blast
    lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis C\<^sub>2)
    lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"       by (metis C\<^sub>1 C\<^sub>1' C\<^sub>2 C\<^sub>0)
    lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y" using C\<^sub>4 by fastforce
    lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x" using C\<^sub>3 by fastforce
   end
 
 
  subsection\<open>AxiomsSet1 entails AxiomsSetMcL\<close>
 
  context AxiomsSet1
   begin
    lemma C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using S\<^sub>i by blast
    lemma C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" by (metis A\<^sub>i S\<^sub>i)
    lemma C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" by (metis A\<^sub>i S\<^sub>i)
-   lemma C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" by (smt A\<^sub>i C\<^sub>i E\<^sub>i S\<^sub>i)
+   lemma C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" by (smt (verit) A\<^sub>i C\<^sub>i E\<^sub>i S\<^sub>i)
    lemma C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" using D\<^sub>i by force
    lemma C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)" using C\<^sub>i by force
   end
 
 
 
  subsection\<open>Skolemization of the Axioms of Mac Lane\<close>
 
  text\<open>Mac Lane employs diagrammatic composition instead of the set-theoretic
      definition as used in our axiom sets. As we have seen above,
       this is not a problem as long as composition is the only primitive.
       But when adding the Skolem terms $dom$ and $cod$ care must be taken and we should
       actually transform all axioms into a common form. Below we address this (in a minimal way) by
       using $dom$ in axiom @{term "C\<^sub>3s"} and $cod$ in axiom @{term "C\<^sub>4s"}, which is opposite of
       what Mac Lane proposed. For this axioms set we then show  equivalence to AxiomsSet1/2/5.\<close>
 
  locale SkolemizedAxiomsSetMcL =
   assumes
    C\<^sub>0s : "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<and> (E(dom x) \<^bold>\<rightarrow> E x) \<and> (E(cod y) \<^bold>\<rightarrow> E y)" and
    C\<^sub>1s : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" and
    C\<^sub>1's: "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" and
    C\<^sub>2s : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" and
    C\<^sub>3s : "\<^bold>\<forall>\<gamma>. IDMcL(dom \<gamma>) \<^bold>\<and> E(\<gamma>\<cdot>(dom \<gamma>))" and
    C\<^sub>4s : "\<^bold>\<forall>\<gamma>. IDMcL(cod \<gamma>) \<^bold>\<and> E((cod \<gamma>)\<cdot>\<gamma>)"
   begin
    lemma True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "\<exists>x. \<^bold>\<not>(E x)" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
    lemma assumes "(\<exists>x. \<^bold>\<not>(E x)) \<and> (\<exists>x. (E x))" shows True nitpick [satisfy] oops  \<comment> \<open>Consistency\<close>
   end
 
 
  subsection\<open>SkolemizedAxiomsSetMcL entails AxiomsSetMcL and AxiomsSet1-5\<close>
 
  context SkolemizedAxiomsSetMcL
   begin
    lemma C\<^sub>0 : "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)" using C\<^sub>0s by blast
    lemma C\<^sub>1 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>)) \<^bold>\<rightarrow> E(\<beta>\<cdot>\<alpha>)" using C\<^sub>1s by blast
    lemma C\<^sub>1': "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<beta>\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>))) \<^bold>\<rightarrow> E(\<gamma>\<cdot>\<beta>)" using C\<^sub>1's by blast
    lemma C\<^sub>2 : "\<^bold>\<forall>\<gamma> \<beta> \<alpha>. (E(\<gamma>\<cdot>\<beta>) \<^bold>\<and> E(\<beta>\<cdot>\<alpha>)) \<^bold>\<rightarrow> (E((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) \<^bold>\<and> E(\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)) \<^bold>\<and> ((\<gamma>\<cdot>\<beta>)\<cdot>\<alpha>) = (\<gamma>\<cdot>(\<beta>\<cdot>\<alpha>)))" using C\<^sub>2s by blast
    lemma C\<^sub>3 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eD. IDMcL(eD) \<^bold>\<and> E(\<gamma>\<cdot>eD)" by (metis C\<^sub>0s C\<^sub>3s)
    lemma C\<^sub>4 : "\<^bold>\<forall>\<gamma>. \<^bold>\<exists>eR. IDMcL(eR) \<^bold>\<and> E(eR\<cdot>\<gamma>)" by (metis C\<^sub>0s C\<^sub>4s)
 
    lemma S\<^sub>i: "E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)"   using C\<^sub>0s by blast
    lemma E\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))"  by (metis C\<^sub>2s)
    lemma A\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"        by (metis C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>0s)
    lemma C\<^sub>i: "\<^bold>\<forall>y.\<^bold>\<exists>i. ID i \<^bold>\<and> i\<cdot>y \<cong> y"  by (metis C\<^sub>0s C\<^sub>4s)
    lemma D\<^sub>i: "\<^bold>\<forall>x.\<^bold>\<exists>j. ID j \<^bold>\<and> x\<cdot>j \<cong> x"  by (metis C\<^sub>0s C\<^sub>3s)
 
    lemma S\<^sub>i\<^sub>i: "(E(x\<cdot>y) \<^bold>\<rightarrow> (E x \<^bold>\<and> E y)) \<^bold>\<and> (E(dom x ) \<^bold>\<rightarrow> E x) \<^bold>\<and> (E(cod y) \<^bold>\<rightarrow> E y)" using C\<^sub>0s by blast
    lemma E\<^sub>i\<^sub>i: "E(x\<cdot>y) \<^bold>\<leftarrow> (E x \<^bold>\<and> E y \<^bold>\<and> (\<^bold>\<exists>z. z\<cdot>z \<cong> z \<^bold>\<and> x\<cdot>z \<cong> x \<^bold>\<and> z\<cdot>y \<cong> y))" by (metis C\<^sub>2s)
    lemma A\<^sub>i\<^sub>i: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z" by (metis C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>0s)
    lemma C\<^sub>i\<^sub>i: "E y \<^bold>\<rightarrow> (ID(cod y) \<^bold>\<and> (cod y)\<cdot>y \<cong> y)" using C\<^sub>4s by auto
    lemma D\<^sub>i\<^sub>i: "E x \<^bold>\<rightarrow> (ID(dom x) \<^bold>\<and> x\<cdot>(dom x) \<cong> x)" using C\<^sub>3s by auto
 
    \<comment> \<open>AxiomsSets3/4 are omitted here; we already know they are equivalent.\<close>
 
    lemma S1: "E(dom x) \<^bold>\<rightarrow> E x"         using C\<^sub>0s by blast
    lemma S2: "E(cod y) \<^bold>\<rightarrow> E y"         using C\<^sub>0s by blast
    lemma S3: "E(x\<cdot>y) \<^bold>\<leftrightarrow> dom x \<simeq> cod y" by (metis (full_types) C\<^sub>0s C\<^sub>1s C\<^sub>1's C\<^sub>2s C\<^sub>3s C\<^sub>4s)
    lemma S4: "x\<cdot>(y\<cdot>z) \<cong> (x\<cdot>y)\<cdot>z"        by (metis C\<^sub>0s C\<^sub>1s C\<^sub>1's C\<^sub>2s)
    lemma S5: "(cod y)\<cdot>y \<cong> y"           using C\<^sub>0s C\<^sub>4s by blast
    lemma S6: "x\<cdot>(dom x) \<cong> x"           using C\<^sub>0s C\<^sub>3s by blast
   end
 
 
 
 (*<*)
 end
 (*>*)
 
 
diff --git a/thys/Cubic_Quartic_Equations/Complex_Roots.thy b/thys/Cubic_Quartic_Equations/Complex_Roots.thy
--- a/thys/Cubic_Quartic_Equations/Complex_Roots.thy
+++ b/thys/Cubic_Quartic_Equations/Complex_Roots.thy
@@ -1,516 +1,516 @@
 section \<open>$n$-th roots of complex numbers\<close>
 
 theory Complex_Roots
   imports 
     Complex_Geometry.More_Complex
     Algebraic_Numbers.Complex_Algebraic_Numbers
     Factor_Algebraic_Polynomial.Roots_via_IA
     "HOL-Library.Product_Lexorder"
 begin
 
 subsection \<open>An algorithm to compute all complex roots of (algebraic) complex numbers\<close>
 
 definition all_croots :: "nat \<Rightarrow> complex \<Rightarrow> complex list" where
   "all_croots n x = (if n = 0 then [] else
      if algebraic x then
        (let p = min_int_poly x;
          q = poly_nth_root n p;
          xs = complex_roots_of_int_poly q
          in filter (\<lambda> y. y^n = x) xs)
      else (SOME ys. set ys = {y. y^n = x}))" 
 
 lemma all_croots: assumes n0: "n \<noteq> 0" shows "set (all_croots n x) = {y. y^n = x}" 
 proof (cases "algebraic x")
   case True
   hence id: "(if n = 0 then y else if algebraic x then z else u) = z" 
     for y z u :: "complex list" using n0 by auto
   define p where "p = poly_nth_root n (min_int_poly x)" 
   show ?thesis unfolding Let_def p_def[symmetric] all_croots_def id
   proof (standard, force, standard, simp)
     fix y
     assume y: "y ^n  = x"     
     have "min_int_poly x represents x" using True by auto
     from represents_nth_root[OF n0 y this]
     have "p represents y" unfolding p_def by auto
     thus "y \<in> set (complex_roots_of_int_poly p)" 
       by (subst complex_roots_of_int_poly, auto)
   qed
 next
   case False
   hence id: "(if n = 0 then y else if algebraic x then z else u) = u" 
     for y z u :: "complex list" using n0 by auto
   show ?thesis unfolding Let_def all_croots_def id
     by (rule someI_ex, rule finite_list, insert n0, blast)
 qed
 
 text \<open>TODO: One might change @{const complex_roots_of_int_poly} to @{const complex_roots_of_int_poly3}
   in order to avoid an unnecessary factorization of an integer polynomial. However, then
   this change already needs to be performed within the definition of @{const all_croots}.\<close> 
 lift_definition all_croots_part1 :: "nat \<Rightarrow> complex \<Rightarrow> complex genuine_roots_aux" is
   "\<lambda> n x. if n = 0 \<or> x = 0 \<or> \<not> algebraic x then (1,[],0, filter_fun_complex 1) 
          else let p = min_int_poly x;
               q = poly_nth_root n p;
               zeros = complex_roots_of_int_poly q;
               r = Polynomial.monom 1 n - [:x:]
          in (r,zeros, n, filter_fun_complex r)"
   subgoal for n x
   proof (cases "n = 0 \<or> x = 0 \<or> \<not> algebraic x")
     case True
     thus ?thesis by (simp add: filter_fun_complex)
   next
     case False
     hence *: "algebraic x" "n \<noteq> 0" "x \<noteq> 0" by auto
     {
       fix z
       assume zn: "z^n = x" 
       from *(1) have repr: "min_int_poly x represents x" by auto
       from represents_nth_root[OF *(2) zn repr]
       have "poly_nth_root n (min_int_poly x) represents z" .
     }
     moreover have "card {z. z ^ n = x} = n"
       by (rule card_nth_roots) (use * in auto)
     ultimately show ?thesis using * 
       by (auto simp: Let_def complex_roots_of_int_poly filter_fun_complex poly_monom)
   qed
   done
 
 lemma all_croots_code[code]: 
   "all_croots n x = (if n = 0 then [] else if x = 0 then [0]
      else if algebraic x then genuine_roots_impl (all_croots_part1 n x)
      else Code.abort (STR ''all_croots invoked on non-algebraic number'') (\<lambda> _. all_croots n x))"
 proof (cases "n = 0")
   case True
   thus ?thesis unfolding all_croots_def by simp
 next
   case n: False
   show ?thesis
   proof (cases "x = 0")
     case x: False
     show ?thesis
     proof (cases "algebraic x")
       case False
       with n x show ?thesis by simp
     next
       case True
       define t where "t = ?thesis" 
       have "t \<longleftrightarrow> filter (\<lambda>y. y ^ n = x)
                 (complex_roots_of_int_poly (poly_nth_root n (min_int_poly x)))
             = genuine_roots_impl (all_croots_part1 n x)" 
         unfolding t_def
         by (subst all_croots_def[of n x], unfold Let_def, insert n x True, auto)
       also have "\<dots>" using n x True unfolding genuine_roots_impl_def
         by (transfer, simp add: Let_def genuine_roots_def poly_monom)
       finally show ?thesis unfolding t_def by simp
     qed
   next
     case x: True
     have "set (all_croots n 0) = {0}" unfolding all_croots[OF n] using n by simp
     moreover have "distinct (all_croots n 0)" unfolding all_croots_def using n
       by (auto intro!: distinct_filter complex_roots_of_int_poly)
     ultimately have "all_croots n 0 = [0]"
       by (smt (verit, del_insts) distinct.simps(2) distinct_singleton insert_ident list.set_cases list.set_intros(1) list.simps(15) mem_Collect_eq set_empty singleton_conv)
     moreover have "?thesis \<longleftrightarrow> all_croots n 0 = [0]" using n x by simp
     ultimately show ?thesis by auto
   qed
 qed
 
 
 subsection \<open>A definition of \emph{the} complex root of a complex number\<close>
 
 text \<open>While the definition of the complex root is quite natural and easy,
   the main task is a criterion to determine which of all possible roots of a
   complex number is the chosen one.\<close>
 
 definition croot :: "nat \<Rightarrow> complex \<Rightarrow> complex" where
   "croot n x = (rcis (root n (cmod x)) (Arg x / of_nat n))" 
 
 lemma croot_0[simp]: "croot n 0 = 0" "croot 0 x = 0"
   unfolding croot_def by auto
 
 lemma croot_power: assumes n: "n \<noteq> 0" 
   shows "(croot n x) ^ n = x" 
   unfolding croot_def DeMoivre2
   by (subst real_root_pow_pos2, insert n, auto simp: rcis_cmod_Arg)
 
 lemma Arg_of_real: "Arg (of_real x) = 
   (if x < 0 then pi else 0)"
 proof (cases "x = 0")
   case False
   hence "x < 0 \<or> x > 0" by auto
   thus ?thesis by (intro cis_Arg_unique, auto
       simp: complex_sgn_def scaleR_complex.ctr complex_eq_iff)
 qed (auto simp: Arg_def)
 
 
 lemma Arg_rcis_cis[simp]: assumes "x > 0" 
   shows "Arg (rcis x y) = Arg (cis y)" 
   using assms unfolding rcis_def by simp
 
 lemma cis_Arg_1[simp]: "cis (Arg 1) = 1" 
   using Arg_of_real[of 1] by simp
 
 lemma cis_Arg_power[simp]: assumes "x \<noteq> 0" 
   shows "cis (Arg (x ^ n)) = cis (Arg x * real n)" 
 proof (induct n)
   case (Suc n)
   show ?case unfolding power.simps
   proof (subst cis_arg_mult)    
     show "cis (Arg x + Arg (x ^ n)) = cis (Arg x * real (Suc n))" 
       unfolding mult.commute[of "Arg x"] DeMoivre[symmetric]
       unfolding power.simps using Suc
       by (metis DeMoivre cis_mult mult.commute)
     show "x * x ^ n \<noteq> 0" using assms by auto
   qed
 qed simp
 
 lemma Arg_croot[simp]: "Arg (croot n x) = Arg x / real n" 
 proof (cases "n = 0 \<or> x = 0")
   case True
   thus ?thesis by (auto simp: Arg_def)
 next
   case False
   hence n: "n \<noteq> 0" and x: "x \<noteq> 0" by auto
   let ?root = "croot n x" 
   from n have n1: "real n \<ge> 1" "real n > 0" "real n \<noteq> 0" by auto
   have bounded: "- pi < Arg x / real n \<and> Arg x / real n \<le> pi" 
   proof (cases "Arg x < 0")
     case True
     from Arg_bounded[of x] have "- pi < Arg x" by auto
     also have "\<dots> \<le> Arg x / real n" using n1 True
-      by (smt (z3) div_by_1 divide_minus_left frac_le)
+      by (smt (verit) div_by_1 divide_minus_left frac_le)
     finally have one: "- pi < Arg x / real n" .
     have "Arg x / real n \<le> 0" using True n1 
       by (smt (verit) divide_less_0_iff)
     also have "\<dots> \<le> pi" by simp
     finally show ?thesis using one by auto
   next
     case False
     hence ax: "Arg x \<ge> 0" by auto
     have "Arg x / real n \<le> Arg x" using n1 ax
       by (smt (verit) div_by_1 frac_le)
     also have "\<dots> \<le> pi" using Arg_bounded[of x] by simp
     finally have one: "Arg x / real n \<le> pi" .
     have "-pi < 0" by simp
     also have "\<dots> \<le> Arg x / real n" using ax n1 by simp
     finally show ?thesis using one by auto
   qed
   have "Arg ?root = Arg (cis (Arg x / real n))" 
     unfolding croot_def using x n by simp 
   also have "\<dots> = Arg x / real n" 
     by (rule cis_Arg_unique, force, insert bounded, auto)
   finally show ?thesis .
 qed
 
 lemma cos_abs[simp]: "cos (abs x :: real) = cos x" 
 proof (cases "x < 0")
   case True
   hence abs: "abs x = - x" by simp
   show ?thesis unfolding abs by simp
 qed simp
 
 lemma cos_mono_le: assumes "abs x \<le> pi" 
   and "abs y \<le> pi" 
 shows "cos x \<le> cos y \<longleftrightarrow> abs y \<le> abs x" 
 proof -
   have "cos x \<le> cos y \<longleftrightarrow> cos (abs x) \<le> cos (abs y)" by simp
   also have "\<dots> \<longleftrightarrow> abs y \<le> abs x" 
     by (subst cos_mono_le_eq, insert assms, auto)
   finally show ?thesis .
 qed
 
 lemma abs_add_2_mult_bound: fixes x :: "'a :: linordered_idom" 
   assumes xy: "\<bar>x\<bar> \<le> y" 
   shows "\<bar>x\<bar> \<le> \<bar>x + 2 * of_int i * y\<bar>" 
 proof (cases "i = 0")
   case i: False
   let ?oi = "of_int :: int \<Rightarrow> 'a" 
   from xy have y: "y \<ge> 0" by auto
   consider (pp) "x \<ge> 0" "i \<ge> 0" 
     | (nn) "x \<le> 0" "i \<le> 0" 
     | (pn) "x \<ge> 0" "i \<le> 0" 
     | (np) "x \<le> 0" "i \<ge> 0" 
     by linarith
   thus ?thesis
   proof cases
     case pp
     thus ?thesis using y by simp
   next
     case nn 
     have "x \<ge> x + 2 * ?oi i * y" 
       using nn y by (simp add: mult_nonneg_nonpos2)
     with nn show ?thesis by linarith
   next
     case pn
     with i have "0 \<le> x" "i < 0" by auto
     define j where "j = nat (-i) - 1" 
     define z where "z = x - 2 * y" 
     define u where "u = 2 * ?oi (nat j) * y" 
     have u: "u \<ge> 0" unfolding u_def using y by auto 
     have i: "i = - int (Suc j)" 
       using \<open>i < 0\<close> unfolding j_def by simp
     have id: "x + 2 * ?oi i * y = z - u" 
       unfolding i z_def u_def by (simp add: field_simps)
     have z: "z \<le> 0" "abs z \<ge> x" using xy y pn(1)
       unfolding z_def by auto
     show ?thesis unfolding id using pn(1) z u by simp
   next
     case np
     with i have "0 \<ge> x" "i > 0" by auto
     define j where "j = nat i - 1" 
     have i: "i = int (Suc j)" 
       using \<open>i > 0\<close> unfolding j_def by simp
     define u where "u = 2 * ?oi (nat j) * y" 
     have u: "u \<ge> 0" unfolding u_def using y by auto 
     define z where "z = - x - 2 * y" 
     have id: "x + 2 * ?oi i * y = - z + u" 
       unfolding i z_def u_def by (simp add: field_simps)
     have z: "z \<le> 0" "abs z \<ge> - x" using xy y np(1)
       unfolding z_def by auto
     show ?thesis unfolding id using np(1) z u by simp
   qed
 qed simp
 
 lemma abs_eq_add_2_mult: fixes y :: "'a :: linordered_idom" 
   assumes abs_id: "\<bar>x\<bar> = \<bar>x + 2 * of_int i * y\<bar>" 
   and xy: "- y < x" "x \<le> y" 
   and i: "i \<noteq> 0" 
 shows "x = y \<and> i = -1" 
 proof -  
   let ?oi = "of_int :: int \<Rightarrow> 'a" 
   from xy have y: "y > 0" by auto
   consider (pp) "x \<ge> 0" "i \<ge> 0" 
     | (nn) "x < 0" "i \<le> 0" 
     | (pn) "x \<ge> 0" "i \<le> 0" 
     | (np) "x < 0" "i \<ge> 0" 
     by linarith
   hence "?thesis \<or> x = ?oi (- i) * y" 
   proof cases
     case pp
     thus ?thesis using y abs_id xy i by simp
   next
     case nn
     hence "\<bar>x + 2 * ?oi i * y\<bar> = 
       - (x + 2 * ?oi i * y)"
       using y nn
       by (intro abs_of_nonpos add_nonpos_nonpos, 
           force, simp, intro mult_nonneg_nonpos, auto)
     thus ?thesis using y abs_id xy i nn
       by auto
   next
     case pn
     with i have "0 \<le> x" "i < 0" by auto
     define j where "j = nat (-i) - 1" 
     define z where "z = x - 2 * y" 
     define u where "u = 2 * ?oi (nat j) * y" 
     have u: "u \<ge> 0" unfolding u_def using y by auto 
     have i: "i = - int (Suc j)" 
       using \<open>i < 0\<close> unfolding j_def by simp
     have id: "x + 2 * ?oi i * y = z - u" 
       unfolding i z_def u_def by (simp add: field_simps)
     have z: "z \<le> 0" "abs z \<ge> x" using xy y pn(1)
       unfolding z_def by auto
     from abs_id[unfolded id] have "z - u = -x " 
       using z u pn by auto
     from this[folded id] have "x = of_int (-i) * y" 
       by auto
     thus ?thesis by auto
   next
     case np
     with i have "0 \<ge> x" "i > 0" by auto
     define j where "j = nat i - 1" 
     have i: "i = int (Suc j)" 
       using \<open>i > 0\<close> unfolding j_def by simp
     define u where "u = 2 * ?oi (nat j) * y" 
     have u: "u \<ge> 0" unfolding u_def using y by auto 
     define z where "z = - x - 2 * y" 
     have id: "x + 2 * ?oi i * y = - z + u" 
       unfolding i z_def u_def by (simp add: field_simps)
     have z: "z \<le> 0" 
       using xy y np(1) unfolding z_def by auto
     from abs_id[unfolded id] have "- z + u = - x" 
       using u z np by auto
     from this[folded id] have "x = of_int (- i) * y" 
       by auto
     thus ?thesis by auto
   qed
   thus ?thesis
   proof
     assume "x = ?oi (- i) * y" 
     with xy i y
     show ?thesis
       by (smt (verit, ccfv_SIG) less_le minus_less_iff mult_le_cancel_right2 mult_minus1_right mult_minus_left mult_of_int_commute of_int_hom.hom_one of_int_le_1_iff of_int_minus)
   qed
 qed
 
 text \<open>This is the core lemma. It tells us that @{const croot} will choose the 
   principal root, i.e. the root with
   largest real part and if there are two roots with identical real part, then the largest imaginary part.
   This criterion will be crucial for implementing @{const croot}.\<close>
 
 lemma croot_principal: assumes n: "n \<noteq> 0"
   and y: "y ^ n = x"
   and neq: "y \<noteq> croot n x"
 shows "Re y < Re (croot n x) \<or> Re y = Re (croot n x) \<and> Im y < Im (croot n x)" 
 proof (cases "x = 0")
   case True
   with neq y have False by auto
   thus ?thesis ..
 next
   case x: False
   let ?root = "croot n x" 
   from n have n1: "real n \<ge> 1" "real n > 0" "real n \<noteq> 0" by auto
   from x y n have y0: "y \<noteq> 0" by auto
   from croot_power[OF n, of x] y
   have id: "?root ^ n = y ^ n" by simp
   hence "cmod (?root ^ n) = cmod (y ^ n)" by simp
   hence norm_eq: "cmod ?root = cmod y" using n unfolding norm_power
     by (meson gr_zeroI norm_ge_zero power_eq_imp_eq_base)
   have "cis (Arg y * real n) = cis (Arg (y^n))" by (subst cis_Arg_power[OF y0], simp) 
   also have "\<dots> = cis (Arg x)" using y by simp
   finally have ciseq: "cis (Arg y * real n) = cis (Arg x)" by simp
   from cis_eq[OF ciseq] obtain i where
     "Arg y * real n - Arg x = 2 * real_of_int i * pi" 
     by auto
   hence "Arg y * real n = Arg x + 2 * real_of_int i * pi" by auto
   from arg_cong[OF this, of "\<lambda> x. x / real n"] n1
   have Argy: "Arg y = Arg ?root + 2 * real_of_int i * pi / real n" 
     by (auto simp: field_simps)
   have i0: "i \<noteq> 0" 
   proof
     assume "i = 0" 
     hence "Arg y = Arg ?root" unfolding Argy by simp
     with norm_eq have "?root = y" by (metis rcis_cmod_Arg)
     with neq show False by simp
   qed
   from y0 have cy0: "cmod y > 0" by auto
   from Arg_bounded[of x] have abs_pi: "abs (Arg x) \<le> pi" by auto
   have "Re y \<le> Re ?root \<longleftrightarrow> Re y / cmod y \<le> Re ?root / cmod y"
     using cy0 unfolding divide_le_cancel by simp
   also have cosy: "Re y / cmod y = cos (Arg y)" unfolding cos_arg[OF y0] ..
   also have cosrt: "Re ?root / cmod y = cos (Arg ?root)" 
     unfolding norm_eq[symmetric] by (subst cos_arg, insert norm_eq cy0, auto)
   also have "cos (Arg y) \<le> cos (Arg ?root) \<longleftrightarrow> abs (Arg ?root) \<le> abs (Arg y)" 
     by (rule cos_mono_le, insert Arg_bounded[of y] Arg_bounded[of ?root], auto)
   also have "\<dots> \<longleftrightarrow> abs (Arg ?root) * real n \<le> abs (Arg y) * real n" 
     unfolding mult_le_cancel_right using n1 by simp
   also have "\<dots> \<longleftrightarrow> abs (Arg x) \<le> \<bar>Arg x + 2 * real_of_int i * pi\<bar>" 
     unfolding Argy using n1 by (simp add: field_simps)
   also have "\<dots>" using abs_pi
     by (rule abs_add_2_mult_bound)
   finally have le: "Re y \<le> Re (croot n x)" .
   show ?thesis
   proof (cases "Re y = Re (croot n x)")
     case False
     with le show ?thesis by auto
   next
     case True
     hence "Re y / cmod y = Re ?root / cmod y" by simp
     hence "cos (Arg y) = cos (Arg ?root)" unfolding cosy cosrt .
     hence "cos (abs (Arg y)) = cos (abs (Arg ?root))" unfolding cos_abs .
     from cos_inj_pi[OF _ _ _ _ this]
     have "abs (Arg y) = abs (Arg ?root)" 
       using Arg_bounded[of y] Arg_bounded[of ?root] by auto
     hence "abs (Arg y) * real n = abs (Arg ?root) * real n" by simp
     hence "abs (Arg x) = \<bar>Arg x + 2 * real_of_int i * pi\<bar>" unfolding Argy 
       using n1 by (simp add: field_simps)
     from abs_eq_add_2_mult[OF this _ _ \<open>i \<noteq> 0\<close>] Arg_bounded[of x]  
     have Argx: "Arg x = pi" and i: "i = -1" by auto
     have Argy: "Arg y = -pi / real n" 
       unfolding Argy Arg_croot i Argx by simp
     have "Im ?root > Im y \<longleftrightarrow> Im ?root / cmod ?root > Im y / cmod y"
       unfolding norm_eq using cy0
       by (meson divide_less_cancel divide_strict_right_mono) 
     also have "\<dots> \<longleftrightarrow> sin (Arg ?root) > sin (Arg y)" 
       by (subst (1 2) sin_arg, insert y0 norm_eq, auto)
     also have "\<dots> \<longleftrightarrow> sin (- pi / real n) < sin (pi / real n)" 
       unfolding Argy Arg_croot Argx by simp
     also have \<dots>
     proof -
       have "sin (- pi / real n) < 0" 
         using n1 by (smt (verit) Arg_bounded Argy divide_neg_pos sin_gt_zero sin_minus)
       also have "\<dots> < sin (pi / real n)" 
         using n1 calculation by fastforce
       finally show ?thesis .
     qed
     finally show ?thesis using le by auto
   qed
 qed
 
 lemma croot_unique: assumes n: "n \<noteq> 0"
   and y: "y ^ n = x"
   and y_max_Re_Im: "\<And> z. z ^ n = x \<Longrightarrow>
       Re z < Re y \<or> Re z = Re y \<and> Im z \<le> Im y" 
 shows "croot n x = y" 
 proof (rule ccontr)
   assume "croot n x \<noteq> y" 
   from croot_principal[OF n y this[symmetric]]
   have "Re y < Re (croot n x) \<or>
     Re y = Re (croot n x) \<and> Im y < Im (croot n x)" .
   with y_max_Re_Im[OF croot_power[OF n]]
   show False by auto
 qed
 
 lemma csqrt_is_croot_2: "csqrt = croot 2" 
 proof
   fix x
   show "csqrt x = croot 2 x" 
   proof (rule sym, rule croot_unique, force, force)
     let ?p = "[:-x,0,1:]" 
     let ?cx = "csqrt x" 
     have p: "?p = [:?cx,1:] * [:-?cx,1:]" 
       by (simp add: power2_eq_square[symmetric])
     fix y
     assume "y^2 = x" 
     hence "True \<longleftrightarrow> poly ?p y = 0" 
       by (auto simp: power2_eq_square)
     also have "\<dots> \<longleftrightarrow> y = - ?cx \<or> y = ?cx" 
       unfolding p poly_mult mult_eq_0_iff poly_root_factor by auto
     finally have "y = - ?cx \<or> y = ?cx" by simp
     thus "Re y < Re ?cx \<or> Re y = Re ?cx \<and> Im y \<le> Im ?cx"
     proof
       assume y: "y = - ?cx"
       show ?thesis
       proof (cases "Re ?cx = 0")
         case False
         with csqrt_principal[of x] have "Re ?cx > 0" by simp
         thus ?thesis unfolding y by simp
       next
         case True
         with csqrt_principal[of x] have "Im ?cx \<ge> 0" by simp
         thus ?thesis unfolding y using True by auto
       qed
     qed auto
   qed
 qed
 
 lemma croot_via_root_selection: assumes roots: "set ys = { y. y^n = x}" 
   and n: "n \<noteq> 0" 
 shows "croot n x = arg_min_list (\<lambda> y. (- Re y, - Im y)) ys" 
   (is "_ = arg_min_list ?f ys")
 proof (rule croot_unique[OF n])
   let ?y = "arg_min_list ?f ys" 
   have rt: "croot n x ^ n = x" using n by (rule croot_power)
   hence "croot n x \<in> set ys" unfolding roots by auto
   hence ys: "ys \<noteq> []" by auto
   from arg_min_list_in[OF this] have "?y \<in> set ys" by auto
   from this[unfolded roots] 
   show "?y^n = x" by auto
   fix z
   assume "z^n = x"
   hence z: "z \<in> set ys" unfolding roots by auto
   from f_arg_min_list_f[OF ys, of ?f] z 
   have "?f ?y \<le> ?f z" by simp
   thus "Re z < Re ?y \<or> Re z = Re ?y \<and> Im z \<le> Im ?y" by auto
 qed
 
 lemma croot_impl[code]: "croot n x = (if n = 0 then 0 else 
   arg_min_list (\<lambda> y. (- Re y, - Im y)) (all_croots n x))" 
 proof (cases "n = 0")
   case n0: False
   hence id: "(if n = 0 then y else z) = z" 
     for y z u :: complex by auto
   show ?thesis unfolding id Let_def 
     by (rule croot_via_root_selection[OF _ n0], rule all_croots[OF n0])
 qed auto
 
 end
\ No newline at end of file
diff --git a/thys/Hahn_Jordan_Decomposition/Hahn_Jordan_Decomposition.thy b/thys/Hahn_Jordan_Decomposition/Hahn_Jordan_Decomposition.thy
--- a/thys/Hahn_Jordan_Decomposition/Hahn_Jordan_Decomposition.thy
+++ b/thys/Hahn_Jordan_Decomposition/Hahn_Jordan_Decomposition.thy
@@ -1,2176 +1,2176 @@
 section \<open>Signed measures\<close>
 
 text \<open>In this section we define signed measures. These are generalizations of measures that can also 
 take negative values but cannot contain both $\infty$ and $-\infty$ in their range.\<close>
 
 subsection \<open>Basic definitions\<close>
 theory Hahn_Jordan_Decomposition imports 
   "HOL-Probability.Probability" 
   Hahn_Jordan_Prelims
 begin
 
 definition signed_measure::"'a measure \<Rightarrow> ('a set \<Rightarrow> ereal) \<Rightarrow> bool" where
   "signed_measure M \<mu> \<longleftrightarrow> \<mu> {} = 0 \<and> (-\<infinity> \<notin> range \<mu> \<or> \<infinity> \<notin> range \<mu>) \<and> 
   (\<forall>A. range A \<subseteq> sets M \<longrightarrow> disjoint_family A \<longrightarrow> \<Union> (range A) \<in> sets M \<longrightarrow> 
   (\<lambda>i. \<mu> (A i)) sums \<mu> (\<Union> (range A))) \<and>
   (\<forall>A. range A \<subseteq> sets M \<longrightarrow> disjoint_family A \<longrightarrow> \<Union> (range A) \<in> sets M \<longrightarrow> 
   \<bar>\<mu> (\<Union> (range A))\<bar> < \<infinity> \<longrightarrow> summable (\<lambda>i. real_of_ereal \<bar>\<mu> (A i)\<bar>))"
 
 lemma signed_measure_empty:
   assumes "signed_measure M \<mu>"
   shows "\<mu> {} = 0" using assms unfolding signed_measure_def by simp
 
 lemma signed_measure_sums:
   assumes "signed_measure M \<mu>"
     and "range A \<subseteq> M"
     and "disjoint_family A"
     and "\<Union> (range A) \<in> sets M"
   shows "(\<lambda>i. \<mu> (A i)) sums \<mu> (\<Union> (range A))"
   using assms unfolding signed_measure_def by simp
 
 lemma signed_measure_summable:
   assumes "signed_measure M \<mu>"
     and "range A \<subseteq> M"
     and "disjoint_family A"
     and "\<Union> (range A) \<in> sets M"
     and "\<bar>\<mu> (\<Union> (range A))\<bar> < \<infinity>"
   shows "summable (\<lambda>i. real_of_ereal \<bar>\<mu> (A i)\<bar>)"
   using assms unfolding signed_measure_def by simp
 
 lemma signed_measure_inf_sum:
   assumes "signed_measure M \<mu>"
     and "range A \<subseteq> M"
     and "disjoint_family A"
     and "\<Union> (range A) \<in> sets M"
   shows "(\<Sum>i. \<mu> (A i)) = \<mu> (\<Union> (range A))" using sums_unique assms 
     signed_measure_sums by (metis)
 
 lemma signed_measure_abs_convergent:
   assumes "signed_measure M \<mu>"
     and "range A \<subseteq> sets M"
     and "disjoint_family A"
     and "\<Union> (range A) \<in> sets M"
     and "\<bar>\<mu> (\<Union> (range A))\<bar> < \<infinity>"
   shows "summable (\<lambda>i. real_of_ereal \<bar>\<mu> (A i)\<bar>)" using assms 
   unfolding signed_measure_def by simp
 
 lemma signed_measure_additive:
   assumes "signed_measure M \<mu>"
   shows "additive M \<mu>"
 proof (auto simp add: additive_def)
   fix x y
   assume x: "x \<in> M" and y: "y \<in> M" and "x \<inter> y = {}"
   hence "disjoint_family (binaryset x y)"
     by (auto simp add: disjoint_family_on_def binaryset_def)
   have "(\<lambda>i. \<mu> ((binaryset x y) i)) sums (\<mu> x + \<mu> y)"  using binaryset_sums 
       signed_measure_empty[of M \<mu>] assms  by simp
   have "range (binaryset x y) = {x, y, {}}" using range_binaryset_eq by simp
   moreover have "{x, y, {}} \<subseteq> M" using x y by auto
   moreover have "x\<union>y \<in> sets M" using x y by simp
   moreover have "(\<Union> (range (binaryset x y))) = x\<union> y"
     by (simp add: calculation(1))
   ultimately have "(\<lambda>i. \<mu> ((binaryset x y) i)) sums \<mu> (x \<union> y)" using assms x y
       signed_measure_empty[of M \<mu>] signed_measure_sums[of M \<mu>]
       \<open>disjoint_family (binaryset x y)\<close> by (metis) 
   then show "\<mu> (x \<union> y) = \<mu> x + \<mu> y" 
     using \<open>(\<lambda>i. \<mu> ((binaryset x y) i)) sums (\<mu> x + \<mu> y)\<close> sums_unique2 by force
 qed
 
 lemma signed_measure_add:
   assumes "signed_measure M \<mu>"
     and "a\<in> sets M"
     and "b\<in> sets M"
     and "a\<inter> b = {}"
   shows "\<mu> (a\<union> b) = \<mu> a + \<mu> b" using additiveD[OF signed_measure_additive] 
     assms by auto
 
 lemma signed_measure_disj_sum:
   shows "finite I \<Longrightarrow> signed_measure M \<mu> \<Longrightarrow> disjoint_family_on A I \<Longrightarrow> 
     (\<And>i. i \<in> I \<Longrightarrow> A i \<in> sets M) \<Longrightarrow> \<mu> (\<Union> i\<in> I. A i) = (\<Sum> i\<in> I. \<mu> (A i))"
 proof (induct rule:finite_induct)
   case empty
   then show ?case  unfolding signed_measure_def by simp
 next
   case (insert x F)
   have "\<mu> (\<Union> (A ` insert x F)) = \<mu> ((\<Union> (A `F)) \<union> A x)" 
     by (simp add: Un_commute)
   also have "... = \<mu> (\<Union> (A `F)) + \<mu> (A x)"
   proof -
     have "(\<Union> (A `F)) \<inter> (A x) = {}" using insert
       by (metis disjoint_family_on_insert inf_commute) 
     moreover have "\<Union> (A `F) \<in> sets M" using insert by auto
     moreover have "A x \<in> sets M" using insert by simp
     ultimately show ?thesis by (meson insert.prems(1) signed_measure_add)
   qed
   also have "... = (\<Sum> i\<in> F. \<mu> (A i)) + \<mu> (A x)" using insert
     by (metis disjoint_family_on_insert insert_iff)
   also have "... = (\<Sum>i\<in>insert x F. \<mu> (A i))"
     by (simp add: add.commute insert.hyps(1) insert.hyps(2)) 
   finally show ?case .
 qed
 
 lemma pos_signed_measure_count_additive:
   assumes "signed_measure M \<mu>"
     and "\<forall> E \<in> sets M. 0 \<le> \<mu> E"
   shows "countably_additive (sets M) (\<lambda>A. e2ennreal (\<mu> A))" 
   unfolding countably_additive_def
 proof (intro allI impI)
   fix A::"nat \<Rightarrow> 'a set"
   assume "range A \<subseteq> sets M"
     and "disjoint_family A"
     and "\<Union> (range A) \<in> sets M" note Aprops = this
   have eq: "\<And>i. \<mu> (A i) = enn2ereal (e2ennreal (\<mu> (A i)))" 
     using assms enn2ereal_e2ennreal Aprops by simp
   have "(\<lambda>n. \<Sum>i\<le>n. \<mu> (A i)) \<longlonglongrightarrow> \<mu> (\<Union> (range A))" using 
       sums_def_le[of "\<lambda>i. \<mu> (A i)" "\<mu> (\<Union> (range A))"] assms 
       signed_measure_sums[of M] Aprops by simp
   hence "((\<lambda>n. e2ennreal (\<Sum>i\<le>n. \<mu> (A i))) \<longlongrightarrow> 
       e2ennreal (\<mu> (\<Union> (range A)))) sequentially"
     using tendsto_e2ennrealI[of "(\<lambda>n. \<Sum>i\<le>n. \<mu> (A i))" "\<mu> (\<Union> (range A))"] 
     by simp
   moreover have "\<And>n. e2ennreal (\<Sum>i\<le>n. \<mu> (A i)) = (\<Sum>i\<le>n. e2ennreal (\<mu> (A i)))"
     using e2ennreal_finite_sum by (metis enn2ereal_nonneg eq finite_atMost)
   ultimately have "((\<lambda>n. (\<Sum>i\<le>n. e2ennreal (\<mu> (A i)))) \<longlongrightarrow> 
     e2ennreal (\<mu> (\<Union> (range A)))) sequentially" by simp
   hence "(\<lambda>i. e2ennreal (\<mu> (A i))) sums e2ennreal (\<mu> (\<Union> (range A)))" 
     using sums_def_le[of "\<lambda>i. e2ennreal (\<mu> (A i))" "e2ennreal (\<mu> (\<Union> (range A)))"] 
     by simp
   thus "(\<Sum>i. e2ennreal (\<mu> (A i))) = e2ennreal (\<mu> (\<Union> (range A)))" 
     using sums_unique assms by (metis)
 qed
 
 lemma signed_measure_minus:
   assumes "signed_measure M \<mu>"
   shows "signed_measure M (\<lambda>A. - \<mu> A)" unfolding signed_measure_def
 proof (intro conjI)
   show "- \<mu> {} = 0" using assms unfolding signed_measure_def by simp
   show "- \<infinity> \<notin> range (\<lambda>A. - \<mu> A) \<or> \<infinity> \<notin> range (\<lambda>A. - \<mu> A)" 
   proof (cases "\<infinity> \<in> range \<mu>")
     case True
     hence "-\<infinity> \<notin> range \<mu>" using assms unfolding signed_measure_def by simp
     hence "\<infinity> \<notin> range (\<lambda>A. - \<mu> A)"  using ereal_uminus_eq_reorder by blast
     thus "- \<infinity> \<notin> range (\<lambda>A. - \<mu> A) \<or> \<infinity> \<notin> range (\<lambda>A. - \<mu> A)" by simp
   next
     case False
     hence "-\<infinity> \<notin> range (\<lambda>A. - \<mu> A)"  using ereal_uminus_eq_reorder 
       by (simp add: image_iff)
     thus "- \<infinity> \<notin> range (\<lambda>A. - \<mu> A) \<or> \<infinity> \<notin> range (\<lambda>A. - \<mu> A)" by simp
   qed
   show "\<forall>A. range A \<subseteq> sets M \<longrightarrow> disjoint_family A \<longrightarrow> \<Union> (range A) \<in> sets M \<longrightarrow> 
     \<bar>- \<mu> (\<Union> (range A))\<bar> < \<infinity> \<longrightarrow> summable (\<lambda>i. real_of_ereal \<bar>- \<mu> (A i)\<bar>)" 
   proof (intro allI impI)
     fix A::"nat \<Rightarrow> 'a set"
     assume  "range A \<subseteq> sets M" and "disjoint_family A" and "\<Union> (range A) \<in> sets M"
       and "\<bar>- \<mu> (\<Union> (range A))\<bar> < \<infinity>" 
     thus "summable (\<lambda>i. real_of_ereal \<bar>- \<mu> (A i)\<bar>)" using assms 
       unfolding signed_measure_def by simp
   qed
   show "\<forall>A. range A \<subseteq> sets M \<longrightarrow> disjoint_family A \<longrightarrow> \<Union> (range A) \<in> sets M \<longrightarrow> 
     (\<lambda>i. - \<mu> (A i)) sums - \<mu> (\<Union> (range A))"
   proof -
     {
       fix A::"nat \<Rightarrow> 'a set"
       assume  "range A \<subseteq> sets M" and "disjoint_family A" and 
         "\<Union> (range A) \<in> sets M" note Aprops = this
       have "- \<infinity> \<notin> range (\<lambda>i. \<mu> (A i)) \<or> \<infinity> \<notin> range (\<lambda>i. \<mu> (A i))" 
       proof -
         have "range (\<lambda>i. \<mu> (A i)) \<subseteq> range \<mu>" by auto
         thus ?thesis  using assms unfolding signed_measure_def by auto
       qed
       moreover have "(\<lambda>i. \<mu> (A i)) sums \<mu> (\<Union> (range A))" 
         using signed_measure_sums[of M] Aprops assms by simp
       ultimately have "(\<lambda>i. - \<mu> (A i)) sums - \<mu> (\<Union> (range A))" 
         using sums_minus'[of "\<lambda>i. \<mu> (A i)"] by simp
     }
     thus ?thesis by auto
   qed
 qed
 
 locale near_finite_function =
   fixes \<mu>:: "'b set \<Rightarrow> ereal"
   assumes inf_range: "- \<infinity> \<notin> range \<mu> \<or> \<infinity> \<notin> range \<mu>"
 
 lemma (in near_finite_function) finite_subset:
   assumes "\<bar>\<mu> E\<bar> < \<infinity>"
     and "A\<subseteq> E"
     and "\<mu> E = \<mu> A + \<mu> (E - A)"
   shows "\<bar>\<mu> A\<bar> < \<infinity>"
 proof (cases "\<infinity> \<in> range \<mu>")
   case False
   show ?thesis
   proof (cases "0 < \<mu> A")
     case True
     hence "\<bar>\<mu> A\<bar> = \<mu> A" by simp
     also have "... < \<infinity>" using False by (metis ereal_less_PInfty rangeI)
     finally show ?thesis .
   next
     case False
     hence "\<bar>\<mu> A\<bar> = -\<mu> A" using not_less_iff_gr_or_eq by fastforce 
     also have "... = \<mu> (E - A) - \<mu> E"
     proof -
       have "\<mu> E = \<mu> A + \<mu> (E - A)" using assms by simp 
       hence "\<mu> E - \<mu> A = \<mu> (E - A)"
         by (metis abs_ereal_uminus assms(1) calculation ereal_diff_add_inverse 
             ereal_infty_less(2)  ereal_minus(5) ereal_minus_less_iff 
             ereal_minus_less_minus ereal_uminus_uminus less_ereal.simps(2) 
             minus_ereal_def  plus_ereal.simps(3))
       thus ?thesis using assms(1) ereal_add_uminus_conv_diff ereal_eq_minus 
         by auto 
     qed
     also have "... \<le> \<mu> (E - A) + \<bar>\<mu> E\<bar>"
       by (metis \<open>- \<mu> A = \<mu> (E - A) - \<mu> E\<close> abs_ereal_less0 abs_ereal_pos 
           ereal_diff_le_self ereal_le_add_mono1 less_eq_ereal_def 
           minus_ereal_def not_le_imp_less)
     also have "... < \<infinity>" using assms \<open>\<infinity> \<notin> range \<mu>\<close>
       by (metis UNIV_I ereal_less_PInfty ereal_plus_eq_PInfty image_eqI) 
     finally show ?thesis .
   qed
 next
   case True
   hence "-\<infinity> \<notin> range \<mu>" using inf_range by simp
   hence "-\<infinity> < \<mu> A" by (metis ereal_infty_less(2) rangeI) 
   show ?thesis
   proof (cases "\<mu> A < 0")
     case True
     hence "\<bar>\<mu> A\<bar> = -\<mu> A" using not_less_iff_gr_or_eq by fastforce 
     also have "... < \<infinity>" using \<open>-\<infinity> < \<mu> A\<close> using ereal_uminus_less_reorder 
       by blast 
     finally show ?thesis .
   next
     case False
     hence "\<bar>\<mu> A\<bar> = \<mu> A" by simp
     also have "... = \<mu> E - \<mu> (E - A)"
     proof -
       have "\<mu> E = \<mu> A + \<mu> (E - A)" using assms by simp  
       thus "\<mu> A = \<mu> E - \<mu> (E - A)" by (metis add.right_neutral  assms(1)
             add_diff_eq_ereal calculation ereal_diff_add_eq_diff_diff_swap 
             ereal_diff_add_inverse ereal_infty_less(1) ereal_plus_eq_PInfty 
             ereal_x_minus_x)
     qed
     also have "... \<le> \<bar>\<mu> E\<bar> - \<mu> (E - A)" 
       by (metis \<open>\<bar>\<mu> A\<bar> = \<mu> A\<close> \<open>\<mu> A = \<mu> E - \<mu> (E - A)\<close> abs_ereal_ge0 
           abs_ereal_pos abs_ereal_uminus antisym_conv ereal_0_le_uminus_iff 
           ereal_abs_diff ereal_diff_le_mono_left ereal_diff_le_self le_cases 
           less_eq_ereal_def minus_ereal_def) 
     also have "... < \<infinity>" 
     proof -
       have "-\<infinity> < \<mu> (E - A)" using \<open>-\<infinity> \<notin> range \<mu>\<close> 
         by (metis ereal_infty_less(2) rangeI) 
       hence "- \<mu> (E - A) < \<infinity>" using ereal_uminus_less_reorder by blast
       thus ?thesis using assms by (simp add: ereal_minus_eq_PInfty_iff 
             ereal_uminus_eq_reorder)
     qed
     finally show ?thesis .
   qed
 qed
 
 locale signed_measure_space=
   fixes M::"'a measure" and \<mu>
   assumes sgn_meas: "signed_measure M \<mu>"
 
 sublocale signed_measure_space \<subseteq> near_finite_function
 proof (unfold_locales)
   show "- \<infinity> \<notin> range \<mu> \<or> \<infinity> \<notin> range \<mu>" using sgn_meas 
     unfolding signed_measure_def by simp
 qed
 
 context signed_measure_space
 begin
 lemma signed_measure_finite_subset:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "A\<in> sets M"
     and "A\<subseteq> E"
   shows "\<bar>\<mu> A\<bar> < \<infinity>"
 proof (rule finite_subset)
   show "\<bar>\<mu> E\<bar> < \<infinity>" "A\<subseteq> E" using assms by auto
   show "\<mu> E = \<mu> A + \<mu> (E - A)" using assms 
       sgn_meas signed_measure_add[of M \<mu> A "E - A"]
     by (metis Diff_disjoint Diff_partition sets.Diff)
 qed
 
 lemma measure_space_e2ennreal :
   assumes "measure_space (space M) (sets M) m \<and> (\<forall>E \<in> sets M. m E < \<infinity>) \<and> 
     (\<forall>E \<in> sets M. m E \<ge> 0)"
   shows "\<forall>E \<in> sets M. e2ennreal (m E) < \<infinity>"
 proof 
   fix E
   assume "E \<in> sets M"
   show "e2ennreal (m E) < \<infinity>"
   proof -
     have "m E < \<infinity>" using assms \<open>E \<in> sets M\<close>
       by blast
     then have "e2ennreal (m E) < \<infinity>" using e2ennreal_less_top
       using \<open>m E < \<infinity>\<close> by auto 
     thus ?thesis by simp
   qed
 qed
 
 subsection \<open>Positive and negative subsets\<close>
 
 text \<open>The Hahn decomposition theorem is based on the notions of positive and negative measurable
 sets. A measurable set is positive (resp. negative) if all its measurable subsets have a positive
 (resp. negative) measure by $\mu$. The decomposition theorem states that any measure space for
 a signed measure can be decomposed into a positive and a negative measurable set.\<close>
 
 definition pos_meas_set  where
   "pos_meas_set E \<longleftrightarrow> E \<in> sets M \<and> (\<forall>A \<in> sets M. A \<subseteq> E \<longrightarrow> 0 \<le> \<mu> A)"
 
 definition neg_meas_set  where
   "neg_meas_set E \<longleftrightarrow> E \<in> sets M \<and> (\<forall>A \<in> sets M. A \<subseteq> E \<longrightarrow> \<mu> A \<le> 0)"
 
 lemma pos_meas_setI:
   assumes "E \<in> sets M"
     and "\<And>A. A \<in> sets M \<Longrightarrow> A \<subseteq> E \<Longrightarrow> 0 \<le> \<mu> A"
   shows "pos_meas_set E" unfolding pos_meas_set_def using assms by simp
 
 lemma pos_meas_setD1 :
   assumes "pos_meas_set E"
   shows "E \<in> sets M"
   using assms unfolding pos_meas_set_def
   by simp
 
 lemma neg_meas_setD1 :
   assumes "neg_meas_set E"
   shows "E \<in> sets M" using assms unfolding neg_meas_set_def by simp
 
 lemma neg_meas_setI:
   assumes "E \<in> sets M"
     and "\<And>A. A \<in> sets M \<Longrightarrow> A \<subseteq> E \<Longrightarrow> \<mu> A \<le> 0"
   shows "neg_meas_set E" unfolding neg_meas_set_def using assms by simp
 
 lemma pos_meas_self:
   assumes "pos_meas_set E"
   shows "0 \<le> \<mu> E" using assms unfolding pos_meas_set_def by simp
 
 lemma empty_pos_meas_set:
   shows "pos_meas_set {}"
   by (metis bot.extremum_uniqueI eq_iff pos_meas_set_def sets.empty_sets 
       sgn_meas signed_measure_empty)
 
 lemma empty_neg_meas_set:
   shows "neg_meas_set {}"
   by (metis neg_meas_set_def order_refl sets.empty_sets sgn_meas 
       signed_measure_empty subset_empty)
 
 lemma pos_measure_meas:
   assumes "pos_meas_set E"
     and "A\<subseteq> E"
     and "A\<in> sets M"
   shows "0 \<le> \<mu> A" using assms unfolding pos_meas_set_def by simp
 
 lemma pos_meas_subset:
   assumes "pos_meas_set A"
     and "B\<subseteq> A"
     and "B\<in> sets M"
   shows "pos_meas_set B" using  assms pos_meas_set_def by auto 
 
 lemma neg_meas_subset:
   assumes "neg_meas_set A"
     and "B\<subseteq> A"
     and "B\<in> sets M"
   shows "neg_meas_set B" using  assms neg_meas_set_def by auto 
 
 lemma pos_meas_set_Union:
   assumes "\<And>(i::nat). pos_meas_set (A i)"
     and "\<And>i. A i \<in> sets M"
     and "\<bar>\<mu> (\<Union> i. A i)\<bar> < \<infinity>"
   shows "pos_meas_set (\<Union> i. A i)"
 proof (rule pos_meas_setI)
   show "\<Union> (range A) \<in> sets M" using sigma_algebra.countable_UN assms by simp
   obtain B where "disjoint_family B" and "(\<Union>(i::nat). B i) = (\<Union>(i::nat). A i)"
     and "\<And>i. B i \<in> sets M" and "\<And>i. B i \<subseteq> A i" using disj_Union2 assms by auto 
   fix C
   assume "C \<in> sets M" and "C\<subseteq> (\<Union> i. A i)"
   hence "C = C \<inter> (\<Union> i. A i)" by auto
   also have "... = C \<inter> (\<Union> i. B i)" using \<open>(\<Union>i. B i) = (\<Union>i. A i)\<close> by simp
   also have "... = (\<Union> i. C \<inter> B i)" by auto
   finally have "C = (\<Union> i. C \<inter> B i)" .
   hence "\<mu> C = \<mu> (\<Union> i. C \<inter> B i)" by simp
   also have "... = (\<Sum>i. \<mu> (C \<inter> (B i)))"
   proof (rule signed_measure_inf_sum[symmetric])
     show "signed_measure M \<mu>" using sgn_meas by simp
     show "disjoint_family (\<lambda>i. C \<inter> B i)" using \<open>disjoint_family B\<close>
       by (meson Int_iff disjoint_family_subset subset_iff)
     show "range (\<lambda>i. C \<inter> B i) \<subseteq> sets M" using \<open>C\<in> sets M\<close> \<open>\<And>i. B i \<in> sets M\<close> 
       by auto
     show "(\<Union>i. C \<inter> B i) \<in> sets M" using \<open>C = (\<Union> i. C \<inter> B i)\<close> \<open>C\<in> sets M\<close> 
       by simp
   qed
   also have "... \<ge> 0" 
   proof (rule suminf_nonneg)
     show "\<And>n. 0 \<le> \<mu> (C \<inter> B n)"
     proof -
       fix n
       have "C\<inter> B n \<subseteq> A n" using \<open>\<And>i. B i \<subseteq> A i\<close> by auto
       moreover have "C \<inter> B n \<in> sets M" using \<open>C\<in> sets M\<close> \<open>\<And>i. B i \<in> sets M\<close> 
         by simp
       ultimately show "0 \<le> \<mu> (C \<inter> B n)" using assms pos_measure_meas[of "A n"] 
         by simp
     qed
     have "summable (\<lambda>i. real_of_ereal (\<mu> (C \<inter> B i)))"
     proof (rule summable_norm_cancel)
       have "\<And>n. norm (real_of_ereal (\<mu> (C \<inter> B n))) = 
         real_of_ereal \<bar>\<mu> (C \<inter> B n)\<bar>" by simp
       moreover have "summable (\<lambda>i. real_of_ereal \<bar>\<mu> (C \<inter> B i)\<bar>)"
       proof (rule signed_measure_abs_convergent)
         show "signed_measure M \<mu>" using sgn_meas by simp
         show "range (\<lambda>i. C \<inter> B i) \<subseteq> sets M" using \<open>C\<in> sets M\<close> 
             \<open>\<And>i. B i \<in> sets M\<close> by auto
         show "disjoint_family (\<lambda>i. C \<inter> B i)" using \<open>disjoint_family B\<close>
           by (meson Int_iff disjoint_family_subset subset_iff)
         show "(\<Union>i. C \<inter> B i) \<in> sets M" using \<open>C = (\<Union> i. C \<inter> B i)\<close> \<open>C\<in> sets M\<close> 
           by simp
         have "\<bar>\<mu> C\<bar> < \<infinity>"
         proof (rule signed_measure_finite_subset)
           show "(\<Union> i. A i) \<in> sets M" using assms by simp
           show "\<bar>\<mu> (\<Union> (range A))\<bar> < \<infinity>" using assms by simp
           show "C \<in> sets M" using \<open>C \<in> sets M\<close> .
           show "C \<subseteq> \<Union> (range A)" using \<open>C \<subseteq> \<Union> (range A) \<close> .
         qed
         thus "\<bar>\<mu> (\<Union>i. C \<inter> B i)\<bar> < \<infinity>" using \<open>C = (\<Union> i. C \<inter> B i)\<close> by simp
       qed
       ultimately show "summable (\<lambda>n. norm (real_of_ereal (\<mu> (C \<inter> B n))))" 
         by auto
     qed
     thus "summable (\<lambda>i. \<mu> (C \<inter> B i))" by (simp add: \<open>\<And>n. 0 \<le> \<mu> (C \<inter> B n)\<close> 
           summable_ereal_pos)
   qed
   finally show "0 \<le> \<mu> C" .
 qed
 
 lemma pos_meas_set_pos_lim:
   assumes "\<And>(i::nat). pos_meas_set (A i)"
     and "\<And>i. A i \<in> sets M"
   shows "0 \<le> \<mu> (\<Union> i. A i)" 
 proof -
   obtain B where "disjoint_family B" and "(\<Union>(i::nat). B i) = (\<Union>(i::nat). A i)"
     and "\<And>i. B i \<in> sets M" and "\<And>i. B i \<subseteq> A i" using disj_Union2 assms by auto 
   note Bprops = this
   have sums: "(\<lambda>n. \<mu> (B n)) sums \<mu> (\<Union>i. B i)" 
   proof (rule signed_measure_sums)
     show "signed_measure M \<mu>" using sgn_meas .
     show "range B \<subseteq> sets M" using Bprops by auto
     show "disjoint_family B" using Bprops by simp
     show "\<Union> (range B) \<in> sets M" using Bprops by blast
   qed
   hence "summable (\<lambda>n. \<mu> (B n))" using sums_summable[of "\<lambda>n. \<mu> (B n)"] by simp
   hence "suminf (\<lambda>n. \<mu> (B n)) = \<mu> (\<Union>i. B i)" using sums sums_iff by auto
   thus ?thesis using suminf_nonneg
     by (metis Bprops(2) Bprops(3) Bprops(4) \<open>summable (\<lambda>n. \<mu> (B n))\<close> assms(1) 
         pos_measure_meas)
 qed
 
 lemma pos_meas_disj_union:
   assumes "pos_meas_set A"
     and "pos_meas_set B"
     and "A\<inter> B = {}"
   shows "pos_meas_set (A \<union> B)" unfolding pos_meas_set_def
 proof (intro conjI ballI impI)
   show "A\<union> B \<in> sets M"
     by (metis assms(1) assms(2) pos_meas_set_def sets.Un)
 next
   fix C
   assume "C\<in> sets M" and "C\<subseteq> A\<union> B"
   define DA where "DA = C\<inter> A"
   define DB where "DB = C\<inter> B"
   have "DA\<in> sets M" using DA_def \<open>C \<in> sets M\<close> assms(1) pos_meas_set_def 
     by blast
   have "DB\<in> sets M" using DB_def \<open>C \<in> sets M\<close> assms(2) pos_meas_set_def 
     by blast 
   have "DA \<inter> DB = {}" unfolding DA_def DB_def using assms by auto
   have "C = DA \<union> DB" unfolding DA_def DB_def using \<open>C\<subseteq> A\<union> B\<close> by auto
   have "0 \<le> \<mu> DB" using assms unfolding DB_def pos_meas_set_def
     by (metis  DB_def Int_lower2\<open>DB \<in> sets M\<close>)
   also have "... \<le> \<mu> DA + \<mu> DB" using assms unfolding  pos_meas_set_def
     by (metis DA_def Diff_Diff_Int Diff_subset Int_commute \<open>DA \<in> sets M\<close> 
         ereal_le_add_self2)
   also have "... = \<mu> C" using signed_measure_add sgn_meas \<open>DA \<in> sets M\<close> 
       \<open>DB \<in> sets M\<close> \<open>DA \<inter> DB = {}\<close> \<open>C = DA \<union> DB\<close> by metis
   finally show "0 \<le> \<mu> C" .
 qed
 
 lemma pos_meas_set_union:
   assumes "pos_meas_set A"
     and "pos_meas_set B"
   shows "pos_meas_set (A \<union> B)" 
 proof -
   define C where "C = B - A"
   have "A\<union> C = A\<union> B" unfolding C_def by auto
   moreover have "pos_meas_set (A\<union> C)" 
   proof (rule pos_meas_disj_union)
     show "pos_meas_set C" unfolding C_def
       by (meson Diff_subset assms(1) assms(2) sets.Diff 
           signed_measure_space.pos_meas_set_def 
           signed_measure_space.pos_meas_subset signed_measure_space_axioms)
     show "pos_meas_set A" using assms by simp
     show "A \<inter> C = {}" unfolding C_def by auto
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma neg_meas_disj_union:
   assumes "neg_meas_set A"
     and "neg_meas_set B"
     and "A\<inter> B = {}"
   shows "neg_meas_set (A \<union> B)" unfolding neg_meas_set_def
 proof (intro conjI ballI impI)
   show "A\<union> B \<in> sets M"
     by (metis assms(1) assms(2) neg_meas_set_def sets.Un)
 next
   fix C
   assume "C\<in> sets M" and "C\<subseteq> A\<union> B"
   define DA where "DA = C\<inter> A"
   define DB where "DB = C\<inter> B"
   have "DA\<in> sets M" using DA_def \<open>C \<in> sets M\<close> assms(1) neg_meas_set_def 
     by blast
   have "DB\<in> sets M" using DB_def \<open>C \<in> sets M\<close> assms(2) neg_meas_set_def 
     by blast 
   have "DA \<inter> DB = {}" unfolding DA_def DB_def using assms by auto
   have "C = DA \<union> DB" unfolding DA_def DB_def using \<open>C\<subseteq> A\<union> B\<close> by auto
   have "\<mu> C = \<mu> DA + \<mu> DB" using signed_measure_add sgn_meas \<open>DA \<in> sets M\<close> 
       \<open>DB \<in> sets M\<close> \<open>DA \<inter> DB = {}\<close> \<open>C = DA \<union> DB\<close> by metis
   also have "... \<le> \<mu> DB" using assms unfolding  neg_meas_set_def
     by (metis DA_def Int_lower2 \<open>DA \<in> sets M\<close> add_decreasing dual_order.refl)
   also have "... \<le> 0" using assms unfolding DB_def neg_meas_set_def
     by (metis  DB_def Int_lower2\<open>DB \<in> sets M\<close>) 
   finally show "\<mu> C \<le> 0" .
 qed
 
 lemma neg_meas_set_union:
   assumes "neg_meas_set A"
     and "neg_meas_set B"
   shows "neg_meas_set (A \<union> B)" 
 proof -
   define C where "C = B - A"
   have "A\<union> C = A\<union> B" unfolding C_def by auto
   moreover have "neg_meas_set (A\<union> C)" 
   proof (rule neg_meas_disj_union)
     show "neg_meas_set C" unfolding C_def
       by (meson Diff_subset assms(1) assms(2) sets.Diff neg_meas_set_def 
           neg_meas_subset signed_measure_space_axioms)
     show "neg_meas_set A" using assms by simp
     show "A \<inter> C = {}" unfolding C_def by auto
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma neg_meas_self :
   assumes "neg_meas_set E"
   shows "\<mu> E \<le> 0" using assms unfolding neg_meas_set_def by simp
 
 lemma pos_meas_set_opp:
   assumes "signed_measure_space.pos_meas_set  M (\<lambda> A. - \<mu> A) A"
   shows "neg_meas_set A"
 proof - 
   have m_meas_pos : "signed_measure M  (\<lambda> A. - \<mu> A)"
     using assms signed_measure_space_def 
     by (simp add: sgn_meas signed_measure_minus)
   thus ?thesis
     by (metis assms ereal_0_le_uminus_iff neg_meas_setI 
         signed_measure_space.intro signed_measure_space.pos_meas_set_def) 
 qed
 
 lemma neg_meas_set_opp:
   assumes "signed_measure_space.neg_meas_set M (\<lambda> A. - \<mu> A) A"
   shows "pos_meas_set A"
 proof -
   have m_meas_neg : "signed_measure M  (\<lambda> A. - \<mu> A)"
     using assms signed_measure_space_def 
     by (simp add: sgn_meas signed_measure_minus)
   thus ?thesis
     by (metis assms ereal_uminus_le_0_iff m_meas_neg pos_meas_setI 
         signed_measure_space.intro signed_measure_space.neg_meas_set_def)
 qed
 end
 
 lemma signed_measure_inter:
   assumes "signed_measure M \<mu>"
     and "A \<in> sets M"
   shows "signed_measure M (\<lambda>E. \<mu> (E \<inter> A))" unfolding signed_measure_def
 proof (intro conjI)
   show "\<mu> ({} \<inter> A) = 0" using assms(1) signed_measure_empty by auto 
   show "- \<infinity> \<notin> range (\<lambda>E. \<mu> (E \<inter> A)) \<or> \<infinity> \<notin> range (\<lambda>E. \<mu> (E \<inter> A))"
   proof (rule ccontr)
     assume "\<not> (- \<infinity> \<notin> range (\<lambda>E. \<mu> (E \<inter> A)) \<or> \<infinity> \<notin> range (\<lambda>E. \<mu> (E \<inter> A)))"
     hence "- \<infinity> \<in> range (\<lambda>E. \<mu> (E \<inter> A)) \<and> \<infinity> \<in> range (\<lambda>E. \<mu> (E \<inter> A))" by simp
     hence "- \<infinity> \<in> range \<mu> \<and> \<infinity> \<in> range \<mu>" by auto
     thus False using assms unfolding signed_measure_def by simp
   qed
   show "\<forall>E. range E \<subseteq> sets M \<longrightarrow> disjoint_family E \<longrightarrow> \<Union> (range E) \<in> sets M \<longrightarrow> 
     (\<lambda>i. \<mu> (E i \<inter> A)) sums \<mu> (\<Union> (range E) \<inter> A)"
   proof (intro allI impI)
     fix E::"nat \<Rightarrow> 'a set"
     assume "range E \<subseteq> sets M" and "disjoint_family E" and "\<Union> (range E) \<in> sets M" 
     note Eprops = this
     define F where "F = (\<lambda>i. E i \<inter> A)"
     have "(\<lambda>i. \<mu> (F i)) sums \<mu> (\<Union> (range F))" 
     proof (rule signed_measure_sums)
       show "signed_measure M \<mu>" using assms by simp
       show "range F \<subseteq> sets M" using Eprops F_def assms by blast
       show "disjoint_family F" using Eprops F_def assms
         by (metis disjoint_family_subset inf.absorb_iff2 inf_commute 
             inf_right_idem)
       show "\<Union> (range F) \<in> sets M" using Eprops assms unfolding F_def
         by (simp add: Eprops assms countable_Un_Int(1) sets.Int)
     qed
     moreover have "\<Union> (range F) = A \<inter> \<Union> (range E)" unfolding F_def by auto   
     ultimately show "(\<lambda>i. \<mu> (E i \<inter> A)) sums \<mu> (\<Union> (range E) \<inter> A)" 
       unfolding F_def by simp
   qed
   show "\<forall>E. range E \<subseteq> sets M \<longrightarrow>
          disjoint_family E \<longrightarrow>
          \<Union> (range E) \<in> sets M \<longrightarrow> \<bar>\<mu> (\<Union> (range E) \<inter> A)\<bar> < \<infinity> \<longrightarrow> 
          summable (\<lambda>i. real_of_ereal \<bar>\<mu> (E i \<inter> A)\<bar>)"
   proof (intro allI impI)
     fix E::"nat \<Rightarrow> 'a set"
     assume "range E \<subseteq> sets M" and "disjoint_family E" and 
       "\<Union> (range E) \<in> sets M" and "\<bar>\<mu> (\<Union> (range E) \<inter> A)\<bar> < \<infinity>" note Eprops = this
     show "summable (\<lambda>i. real_of_ereal \<bar>\<mu> (E i \<inter> A)\<bar>)"
     proof (rule signed_measure_summable)
       show "signed_measure M \<mu>" using assms by simp
       show "range (\<lambda>i. E i \<inter> A) \<subseteq> sets M" using Eprops assms by blast
       show "disjoint_family (\<lambda>i. E i \<inter> A)" using Eprops assms 
           disjoint_family_subset inf.absorb_iff2 inf_commute inf_right_idem 
         by fastforce
       show "(\<Union>i. E i \<inter> A) \<in> sets M" using Eprops assms 
         by (simp add: Eprops assms countable_Un_Int(1) sets.Int)
       show "\<bar>\<mu> (\<Union>i. E i \<inter> A)\<bar> < \<infinity>" using Eprops by auto
     qed
   qed
 qed
 
 context signed_measure_space
 begin
 lemma pos_signed_to_meas_space :
   assumes "pos_meas_set M1"
     and "m1 = (\<lambda>A. \<mu> (A \<inter> M1))"
   shows "measure_space (space M) (sets M) m1" unfolding measure_space_def
 proof (intro conjI)
   show "sigma_algebra (space M) (sets M)"
     by (simp add: sets.sigma_algebra_axioms)
   show "positive (sets M) m1" using assms unfolding pos_meas_set_def
     by (metis Sigma_Algebra.positive_def Un_Int_eq(4) 
         e2ennreal_neg neg_meas_self sup_bot_right empty_neg_meas_set)
   show "countably_additive (sets M) m1" 
   proof (rule pos_signed_measure_count_additive)
     show "\<forall>E\<in>sets M. 0 \<le> m1 E" by (metis assms inf.cobounded2 
           pos_meas_set_def sets.Int) 
     show "signed_measure M m1" using assms pos_meas_set_def 
         signed_measure_inter[of M \<mu> M1] sgn_meas by blast
   qed
 qed
 
 lemma neg_signed_to_meas_space :
   assumes "neg_meas_set M2" 
     and "m2 = (\<lambda>A. -\<mu> (A \<inter> M2))"
   shows "measure_space (space M) (sets M) m2" unfolding measure_space_def
 proof (intro conjI)
   show "sigma_algebra (space M) (sets M)"
     by (simp add: sets.sigma_algebra_axioms)
   show "positive (sets M) m2" using assms unfolding neg_meas_set_def
     by (metis Sigma_Algebra.positive_def e2ennreal_neg ereal_uminus_zero 
         inf.absorb_iff2 inf.orderE inf_bot_right neg_meas_self pos_meas_self 
         empty_neg_meas_set empty_pos_meas_set)
   show "countably_additive (sets M) m2" 
   proof (rule pos_signed_measure_count_additive)
     show "\<forall>E\<in>sets M. 0 \<le> m2 E"
       by (metis assms ereal_uminus_eq_reorder ereal_uminus_le_0_iff 
           inf.cobounded2 neg_meas_set_def sets.Int) 
     have "signed_measure M (\<lambda>A. \<mu> (A \<inter> M2))" using assms neg_meas_set_def
         signed_measure_inter[of M \<mu> M2] sgn_meas by blast
     thus "signed_measure M m2" using signed_measure_minus assms by simp 
   qed
 qed
 
 lemma pos_part_meas_nul_neg_set :
   assumes "pos_meas_set M1" 
     and "neg_meas_set M2" 
     and "m1 = (\<lambda>A. \<mu> (A \<inter> M1))"
     and "E \<in> sets M"
     and "E \<subseteq> M2"
   shows "m1 E = 0"
 proof -
   have "m1 E \<ge> 0" using assms unfolding pos_meas_set_def
     by (simp add: \<open>E \<in> sets M\<close> sets.Int) 
   have "\<mu> E \<le> 0" using \<open>E \<subseteq> M2\<close> assms unfolding neg_meas_set_def
     using \<open>E \<in> sets M\<close> by blast 
   then have "m1 E \<le> 0" using \<open>\<mu> E \<le> 0\<close> assms
     by (metis Int_Un_eq(1) Un_subset_iff \<open>E \<in> sets M\<close> \<open>E \<subseteq> M2\<close> pos_meas_setD1 
         sets.Int signed_measure_space.neg_meas_set_def 
         signed_measure_space_axioms)
   thus "m1 E = 0" using \<open>m1 E \<ge> 0\<close> \<open>m1 E \<le> 0\<close> by auto
 qed
 
 lemma neg_part_meas_nul_pos_set :
   assumes "pos_meas_set M1" 
     and "neg_meas_set M2" 
     and "m2 = (\<lambda>A. -\<mu> (A \<inter> M2))"
     and "E \<in> sets M"
     and "E \<subseteq> M1"
   shows "m2 E = 0"
 proof -
   have "m2 E \<ge> 0" using assms unfolding neg_meas_set_def
     by (simp add: \<open>E \<in> sets M\<close> sets.Int) 
   have "\<mu> E \<ge> 0" using  assms unfolding pos_meas_set_def by blast 
   then have "m2 E \<le> 0" using \<open>\<mu> E \<ge> 0\<close> assms
     by (metis \<open>E \<in> sets M\<close> \<open>E \<subseteq> M1\<close> ereal_0_le_uminus_iff ereal_uminus_uminus 
         inf_sup_ord(1) neg_meas_setD1 pos_meas_set_def pos_meas_subset 
         sets.Int)
   thus "m2 E = 0" using \<open>m2 E \<ge> 0\<close> \<open>m2 E \<le> 0\<close> by auto
 qed
 
 definition pos_sets where 
   "pos_sets = {A. A \<in> sets M   \<and> pos_meas_set A}"
 
 definition pos_img where 
   "pos_img = {\<mu> A|A. A\<in> pos_sets}"
 
 subsection \<open>Essential uniqueness\<close>
 
 text \<open>In this part, under the assumption that a measure space for a signed measure admits a
 decomposition into a positive and a negative set, we prove that this decomposition is
 essentially unique; in other words, that if two such decompositions $(P,N)$ and $(X,Y)$ exist, 
 then any measurable subset of $(P\triangle X) \cup (N \triangle Y)$ has a null measure.\<close>
 
 definition hahn_space_decomp where
   "hahn_space_decomp M1 M2 \<equiv> (pos_meas_set M1) \<and> (neg_meas_set M2) \<and> 
 (space M = M1 \<union> M2) \<and> (M1 \<inter> M2 = {})"
 
 lemma pos_neg_null_set:
   assumes "pos_meas_set A"
     and "neg_meas_set A"
   shows "\<mu> A = 0" using assms pos_meas_self[of A] neg_meas_self[of A] by simp
 
 lemma pos_diff_neg_meas_set:
   assumes "(pos_meas_set M1)" 
     and "(neg_meas_set N2)" 
     and "(space M = N1 \<union> N2)" 
     and "N1 \<in> sets M"
   shows "neg_meas_set ((M1 - N1) \<inter> space M)" using assms neg_meas_subset
   by (metis Diff_subset_conv Int_lower2 pos_meas_setD1 sets.Diff 
       sets.Int_space_eq2)
 
 lemma neg_diff_pos_meas_set:
   assumes "(neg_meas_set M2)" 
     and "(pos_meas_set N1)" 
     and "(space M = N1 \<union> N2)" 
     and "N2 \<in> sets M"
   shows "pos_meas_set ((M2 - N2) \<inter> space M)" 
 proof -
   have "(M2 - N2) \<inter> space M \<subseteq> N1" using assms by auto
   thus ?thesis using assms pos_meas_subset neg_meas_setD1 by blast
 qed
 
 lemma pos_sym_diff_neg_meas_set:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp N1 N2"
   shows "neg_meas_set ((sym_diff M1 N1) \<inter> space M)" using assms 
   unfolding hahn_space_decomp_def
   by (metis Int_Un_distrib2 neg_meas_set_union pos_meas_setD1 
       pos_diff_neg_meas_set) 
 
 lemma neg_sym_diff_pos_meas_set:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp N1 N2"
   shows "pos_meas_set ((sym_diff M2 N2) \<inter> space M)" using assms 
     neg_diff_pos_meas_set unfolding hahn_space_decomp_def
   by (metis (no_types, lifting) Int_Un_distrib2 neg_meas_setD1 
       pos_meas_set_union)
 
 lemma pos_meas_set_diff:
   assumes "pos_meas_set A"
     and "B\<in> sets M"
   shows "pos_meas_set ((A - B) \<inter> (space M))" using pos_meas_subset
   by (metis Diff_subset assms(1) assms(2) pos_meas_setD1 sets.Diff 
       sets.Int_space_eq2)
 
 lemma pos_meas_set_sym_diff:
   assumes "pos_meas_set A"
     and "pos_meas_set B"
   shows "pos_meas_set ((sym_diff A B) \<inter> space M)" using pos_meas_set_diff
   by (metis Int_Un_distrib2 assms(1) assms(2) pos_meas_setD1 
       pos_meas_set_union)
 
 lemma neg_meas_set_diff:
   assumes "neg_meas_set A"
     and "B\<in> sets M"
   shows "neg_meas_set ((A - B) \<inter> (space M))" using neg_meas_subset
   by (metis Diff_subset assms(1) assms(2) neg_meas_setD1 sets.Diff 
       sets.Int_space_eq2)
 
 lemma neg_meas_set_sym_diff:
   assumes "neg_meas_set A"
     and "neg_meas_set B"
   shows "neg_meas_set ((sym_diff A B) \<inter> space M)" using neg_meas_set_diff
   by (metis Int_Un_distrib2 assms(1) assms(2) neg_meas_setD1 
       neg_meas_set_union)
 
 lemma hahn_decomp_space_diff:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp N1 N2"
   shows "pos_meas_set ((sym_diff M1 N1 \<union> sym_diff M2 N2) \<inter> space M)"
     "neg_meas_set ((sym_diff M1 N1 \<union> sym_diff M2 N2) \<inter> space M)"
 proof -
   show "pos_meas_set ((sym_diff M1 N1 \<union> sym_diff M2 N2) \<inter> space M)"
     by (metis Int_Un_distrib2 assms(1) assms(2) hahn_space_decomp_def 
         neg_sym_diff_pos_meas_set pos_meas_set_sym_diff pos_meas_set_union)
   show "neg_meas_set ((sym_diff M1 N1 \<union> sym_diff M2 N2) \<inter> space M)"
     by (metis Int_Un_distrib2 assms(1) assms(2) hahn_space_decomp_def 
         neg_meas_set_sym_diff neg_meas_set_union pos_sym_diff_neg_meas_set)
 qed
 
 lemma hahn_decomp_ess_unique:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp N1 N2"
     and "C \<subseteq> sym_diff M1 N1 \<union> sym_diff M2 N2"
     and "C\<in> sets M"
   shows "\<mu> C = 0"
 proof -
   have "C\<subseteq> (sym_diff M1 N1 \<union> sym_diff M2 N2) \<inter> space M" using assms
     by (simp add: sets.sets_into_space)     
   thus ?thesis using assms hahn_decomp_space_diff pos_neg_null_set
     by (meson neg_meas_subset pos_meas_subset)
 qed
 
 section \<open>Existence of a positive subset\<close>
 
 text \<open>The goal of this part is to prove that any measurable set of finite and positive measure must 
 contain a positive subset with a strictly positive measure.\<close>
 
 subsection \<open>A sequence of negative subsets\<close>
 
 definition inf_neg where
   "inf_neg A = (if (A \<notin> sets M \<or> pos_meas_set A) then (0::nat) 
   else Inf {n|n. (1::nat) \<le> n \<and> (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B < ereal(-1/n))})"
 
 lemma inf_neg_ne:
   assumes "A \<in> sets M"
     and "\<not> pos_meas_set A"
   shows "{n::nat|n. (1::nat) \<le> n \<and> 
   (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B < ereal (-1/n))} \<noteq> {}"  
 proof -
   define N where "N = {n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B < ereal (-1/n))}"
   have "\<exists>B \<in> sets M. B\<subseteq> A \<and> \<mu> B < 0" using assms unfolding pos_meas_set_def 
     by auto
   from this obtain B where "B\<in> sets M" and "B\<subseteq> A" and "\<mu> B < 0" by auto
   hence "\<exists>n::nat. (1::nat) \<le> n \<and> \<mu> B < ereal (-1/n)" 
   proof (cases "\<mu> B = -\<infinity>")
     case True
     hence "\<mu> B < -1/(2::nat)" by simp
     thus ?thesis using numeral_le_real_of_nat_iff one_le_numeral by blast 
   next
     case False
     hence "real_of_ereal (\<mu> B) < 0" using \<open>\<mu> B < 0\<close>
       by (metis Infty_neq_0(3) ereal_mult_eq_MInfty ereal_zero_mult 
           less_eq_ereal_def less_eq_real_def less_ereal.simps(2) 
           real_of_ereal_eq_0 real_of_ereal_le_0)
     hence "\<exists>n::nat. Suc 0 \<le> n \<and> real_of_ereal (\<mu> B) < -1/n"
     proof -
       define nw where "nw =  Suc (nat (floor (-1/ (real_of_ereal (\<mu> B)))))"
       have "Suc 0 \<le> nw" unfolding nw_def by simp
       have "0 < -1/ (real_of_ereal (\<mu> B))" using \<open>real_of_ereal (\<mu> B) < 0\<close> 
         by simp
       have "-1/ (real_of_ereal (\<mu> B)) < nw" unfolding nw_def by linarith
       hence "1/nw < 1/(-1/ (real_of_ereal (\<mu> B)))" 
         using \<open>0 < -1/ (real_of_ereal (\<mu> B))\<close> by (metis frac_less2 
             le_eq_less_or_eq of_nat_1 of_nat_le_iff zero_less_one)
       also have "... = - (real_of_ereal (\<mu> B))" by simp
       finally have "1/nw < - (real_of_ereal (\<mu> B))" .
       hence "real_of_ereal (\<mu> B) < -1/nw" by simp
       thus ?thesis using \<open>Suc 0 \<le> nw\<close> by auto
     qed
     from this obtain n1::nat where "Suc 0 \<le> n1" 
       and "real_of_ereal (\<mu> B) < -1/n1" by auto
     hence "ereal (real_of_ereal (\<mu> B)) < -1/n1" using real_ereal_leq[of "\<mu> B"] 
         \<open>\<mu> B < 0\<close> by simp
     moreover have "\<mu> B = real_of_ereal (\<mu> B)" using \<open>\<mu> B < 0\<close> False
       by (metis less_ereal.simps(2) real_of_ereal.elims zero_ereal_def)
     ultimately show ?thesis  using \<open>Suc 0 \<le> n1\<close> by auto 
   qed
   from this obtain n0::nat where "(1::nat) \<le> n0" and "\<mu> B < -1/n0" by auto
   hence "n0 \<in> {n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B <  ereal(-1/n))}" 
     using \<open>B\<in> sets M\<close> \<open>B\<subseteq> A\<close> by auto
   thus ?thesis by auto
 qed
 
 lemma inf_neg_ge_1:
   assumes "A \<in> sets M"
     and "\<not> pos_meas_set A"
   shows "(1::nat) \<le> inf_neg A"
 proof -
   define N where "N = {n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B < ereal (-1/n))}"  
   have "N \<noteq> {}" unfolding N_def using assms inf_neg_ne by auto
   moreover have "\<And>n. n\<in> N \<Longrightarrow> (1::nat) \<le> n" unfolding N_def by simp
   ultimately show "1 \<le> inf_neg A" unfolding inf_neg_def N_def
     using Inf_nat_def1 assms(1) assms(2) by presburger
 qed
 
 lemma inf_neg_pos:
   assumes "A \<in> sets M"
     and "\<not> pos_meas_set A"
   shows "\<exists> B \<in> sets M. B\<subseteq> A \<and> \<mu> B < -1/(inf_neg A)"  
 proof -
   define N where "N = {n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> A \<and> \<mu> B < ereal (-1/n))}"  
   have "N \<noteq> {}" unfolding N_def using assms inf_neg_ne by auto
   hence "Inf N \<in> N" using Inf_nat_def1[of N] by simp
   hence "inf_neg A \<in> N" unfolding N_def inf_neg_def using assms by auto
   thus ?thesis unfolding N_def by auto
 qed
 
 definition rep_neg where
   "rep_neg A  = (if (A \<notin> sets M \<or> pos_meas_set A) then {} else 
   SOME B. B \<in> sets M \<and> B \<subseteq> A \<and> \<mu> B \<le> ereal (-1 / (inf_neg A)))"
 
 lemma g_rep_neg:
   assumes "A\<in> sets M"
     and "\<not> pos_meas_set A"
   shows "rep_neg A \<in> sets M" "rep_neg A \<subseteq> A"  
     "\<mu> (rep_neg A) \<le> ereal (-1 / (inf_neg A))" 
 proof -
   have "\<exists> B. B \<in> sets M \<and> B\<subseteq> A \<and> \<mu> B \<le> -1 / (inf_neg A)" using assms 
       inf_neg_pos[of A] by auto
   from someI_ex[OF this] show "rep_neg A \<in> sets M" "rep_neg A \<subseteq> A"  
     "\<mu> (rep_neg A) \<le> -1 / (inf_neg A)" 
     unfolding rep_neg_def using assms by auto
 qed
 
 lemma rep_neg_sets:
   shows "rep_neg A \<in> sets M"
 proof (cases "A \<notin> sets M \<or> pos_meas_set A")
   case True
   then show ?thesis unfolding rep_neg_def by simp
 next
   case False
   then show ?thesis using g_rep_neg(1) by blast
 qed
 
 lemma rep_neg_subset:
   shows "rep_neg A \<subseteq> A"
 proof (cases "A \<notin> sets M \<or> pos_meas_set A")
   case True
   then show ?thesis unfolding rep_neg_def by simp
 next
   case False
   then show ?thesis using g_rep_neg(2) by blast
 qed
 
 lemma rep_neg_less:
   assumes "A\<in> sets M"
     and "\<not> pos_meas_set A"
   shows "\<mu> (rep_neg A) \<le> ereal (-1 / (inf_neg A))" using assms g_rep_neg(3) 
   by simp
 
 lemma rep_neg_leq:
   shows "\<mu> (rep_neg A) \<le> 0"
 proof (cases "A \<notin> sets M \<or> pos_meas_set A")
   case True
   hence "rep_neg A = {}" unfolding rep_neg_def by simp
   then show ?thesis using sgn_meas signed_measure_empty by force 
 next
   case False
   then show ?thesis using rep_neg_less by (metis le_ereal_le minus_divide_left 
         neg_le_0_iff_le of_nat_0 of_nat_le_iff zero_ereal_def zero_le 
         zero_le_divide_1_iff) 
 qed
 
 subsection \<open>Construction of the positive subset\<close>
 
 fun pos_wtn
   where
     pos_wtn_base: "pos_wtn E 0 = E"|
     pos_wtn_step: "pos_wtn E (Suc n) = pos_wtn E n - rep_neg (pos_wtn E n)"
 
 lemma pos_wtn_subset:
   shows "pos_wtn E n \<subseteq> E"
 proof (induct n)
   case 0
   then show ?case using pos_wtn_base by simp
 next
   case (Suc n)
   hence "rep_neg (pos_wtn E n) \<subseteq> pos_wtn E n" using rep_neg_subset by simp
   then show ?case using Suc by auto
 qed
 
 lemma pos_wtn_sets:
   assumes "E\<in> sets M"
   shows "pos_wtn E n \<in> sets M"
 proof (induct n)
   case 0
   then show ?case using assms by simp
 next
   case (Suc n)
   then show ?case using pos_wtn_step rep_neg_sets by auto
 qed
 
 definition neg_wtn where
   "neg_wtn E (n::nat) = rep_neg (pos_wtn E n)"
 
 lemma neg_wtn_neg_meas:
   shows "\<mu> (neg_wtn E n) \<le> 0" unfolding neg_wtn_def using rep_neg_leq by simp
 
 lemma neg_wtn_sets:
   shows "neg_wtn E n \<in> sets M" unfolding neg_wtn_def using rep_neg_sets by simp
 
 lemma neg_wtn_subset:
   shows "neg_wtn E n \<subseteq> E" unfolding neg_wtn_def  
   using pos_wtn_subset[of E n] rep_neg_subset[of "pos_wtn E n"] by simp
 
 lemma neg_wtn_union_subset:
   shows "(\<Union> i \<le> n. neg_wtn E i) \<subseteq> E" using neg_wtn_subset by auto
 
 lemma pos_wtn_Suc:
   shows "pos_wtn E (Suc n) = E - (\<Union> i \<le> n. neg_wtn E i)" unfolding neg_wtn_def
 proof (induct n)
   case 0
   then show ?case using pos_wtn_base pos_wtn_step by simp
 next
   case (Suc n)
   have "pos_wtn E (Suc (Suc n)) = pos_wtn E (Suc n) - 
     rep_neg (pos_wtn E (Suc n))" 
     using pos_wtn_step by simp
   also have "... = (E - (\<Union> i \<le> n. rep_neg (pos_wtn E i))) - 
     rep_neg (pos_wtn E (Suc n))"
     using Suc by simp
   also have "... = E - (\<Union> i \<le> (Suc n). rep_neg (pos_wtn E i))" 
     using diff_union[of E "\<lambda>i. rep_neg (pos_wtn E i)" n] by auto
   finally show "pos_wtn E (Suc (Suc n)) = 
     E - (\<Union> i \<le> (Suc n). rep_neg (pos_wtn E i))" .
 qed
 
 definition pos_sub where
   "pos_sub E = (\<Inter> n. pos_wtn E n)"
 
 lemma pos_sub_sets:
   assumes "E\<in> sets M"
   shows "pos_sub E \<in> sets M" unfolding pos_sub_def using pos_wtn_sets assms 
   by auto
 
 lemma pos_sub_subset:
   shows "pos_sub E \<subseteq> E" unfolding pos_sub_def using pos_wtn_subset by blast
 
 lemma pos_sub_infty:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "\<bar>\<mu> (pos_sub E)\<bar> < \<infinity>" using signed_measure_finite_subset assms 
     pos_sub_sets pos_sub_subset by simp
 
 lemma neg_wtn_djn:
   shows "disjoint_family (\<lambda>n. neg_wtn E n)" unfolding disjoint_family_on_def
 proof -
   {
     fix n 
     fix m::nat
     assume "n < m"
     hence "\<exists>p. m = Suc p" using old.nat.exhaust by auto
     from this obtain p where "m = Suc p" by auto
     have "neg_wtn E m \<subseteq> pos_wtn E m" unfolding neg_wtn_def 
       by (simp add: rep_neg_subset)
     also have "... = E - (\<Union> i \<le> p. neg_wtn E i)" using pos_wtn_Suc \<open>m = Suc p\<close>
       by simp
     finally have "neg_wtn E m \<subseteq> E - (\<Union> i \<le> p. neg_wtn E i)" .
     moreover have "neg_wtn E n \<subseteq> (\<Union> i \<le> p. neg_wtn E i)" using \<open>n < m\<close> 
         \<open>m = Suc p\<close> by (simp add: UN_upper) 
     ultimately have "neg_wtn E n \<inter> neg_wtn E m = {}" by auto
   }
   thus "\<forall>m\<in>UNIV. \<forall>n\<in>UNIV. m \<noteq> n \<longrightarrow> neg_wtn E m \<inter> neg_wtn E n = {}"  
     by (metis inf_commute linorder_neqE_nat) 
 qed
 end
 
 lemma disjoint_family_imp_on:
   assumes "disjoint_family A"
   shows "disjoint_family_on A S" 
   using assms disjoint_family_on_mono subset_UNIV by blast 
 
 context signed_measure_space
 begin
 lemma neg_wtn_union_neg_meas:
   shows "\<mu> (\<Union> i \<le> n. neg_wtn E i) \<le> 0" 
 proof -
   have "\<mu> (\<Union> i \<le> n. neg_wtn E i) = (\<Sum>i\<in>{.. n}. \<mu> (neg_wtn E i))" 
   proof (rule signed_measure_disj_sum, simp+)
     show "signed_measure M \<mu>" using sgn_meas .
     show "disjoint_family_on (neg_wtn E) {..n}" using neg_wtn_djn 
         disjoint_family_imp_on[of "neg_wtn E"] by simp
     show "\<And>i. i \<in> {..n} \<Longrightarrow> neg_wtn E i \<in> sets M" using neg_wtn_sets by simp
   qed
   also have "... \<le> 0" using neg_wtn_neg_meas by (simp add: sum_nonpos) 
   finally show ?thesis .
 qed
 
 lemma pos_wtn_meas_gt:
   assumes "0 < \<mu> E"
     and "E\<in> sets M"
   shows "0 < \<mu> (pos_wtn E n)"
 proof (cases "n = 0")
   case True
   then show ?thesis using assms by simp
 next
   case False
   hence "\<exists>m. n = Suc m" by (simp add: not0_implies_Suc) 
   from this obtain m where "n = Suc m" by auto
   hence eq: "pos_wtn E n = E - (\<Union> i \<le> m. neg_wtn E i)" using pos_wtn_Suc 
     by simp
   hence "pos_wtn E n \<inter> (\<Union> i \<le> m. neg_wtn E i) = {}" by auto
   moreover have "E = pos_wtn E n \<union> (\<Union> i \<le> m. neg_wtn E i)" 
     using eq neg_wtn_union_subset[of E m] by auto 
   ultimately have "\<mu> E = \<mu> (pos_wtn E n) + \<mu> (\<Union> i \<le> m. neg_wtn E i)" 
     using signed_measure_add[of M \<mu> "pos_wtn E n" "\<Union> i \<le> m. neg_wtn E i"] 
       pos_wtn_sets neg_wtn_sets assms sgn_meas by auto
   hence "0 < \<mu> (pos_wtn E n) + \<mu> (\<Union> i \<le> m. neg_wtn E i)" using assms by simp
   thus ?thesis using neg_wtn_union_neg_meas 
     by (metis add.right_neutral add_mono not_le) 
 qed
 
 definition union_wit where
   "union_wit E = (\<Union> n. neg_wtn E n)"
 
 lemma union_wit_sets:
   shows "union_wit E \<in> sets M" unfolding union_wit_def
 proof (intro sigma_algebra.countable_nat_UN)
   show "sigma_algebra (space M) (sets M)" 
     by (simp add: sets.sigma_algebra_axioms) 
   show "range (neg_wtn E) \<subseteq> sets M"
   proof -
     {
       fix n
       have "neg_wtn E n \<in> sets M" unfolding neg_wtn_def 
         by (simp add: rep_neg_sets)
     }
     thus ?thesis by auto
   qed
 qed
 
 lemma union_wit_subset:
   shows "union_wit E \<subseteq> E"
 proof -
   {
     fix n
     have "neg_wtn E n \<subseteq> E" unfolding neg_wtn_def using pos_wtn_subset
         rep_neg_subset[of "pos_wtn E n"] by auto
   }
   thus ?thesis unfolding union_wit_def by auto
 qed
 
 lemma pos_sub_diff:
   shows "pos_sub E = E - union_wit E"
 proof
   show "pos_sub E \<subseteq> E - union_wit E"
   proof -
     have "pos_sub E \<subseteq> E" using pos_sub_subset by simp
     moreover have "pos_sub E \<inter> union_wit E = {}" 
     proof (rule ccontr)
       assume "pos_sub E \<inter> union_wit E \<noteq> {}"
       hence "\<exists> a. a\<in> pos_sub E \<inter> union_wit E" by auto
       from this obtain a where "a\<in> pos_sub E \<inter> union_wit E" by auto
       hence "a\<in> union_wit E" by simp
       hence "\<exists>n. a \<in> rep_neg (pos_wtn E n)" unfolding union_wit_def neg_wtn_def
         by auto
       from this obtain n where "a \<in> rep_neg (pos_wtn E n)" by auto
       have "a \<in> pos_wtn E (Suc n)" using \<open>a\<in> pos_sub E \<inter> union_wit E\<close> 
         unfolding pos_sub_def by blast
       hence "a\<notin> rep_neg (pos_wtn E n)" using pos_wtn_step by simp
       thus False using \<open>a \<in> rep_neg (pos_wtn E n)\<close> by simp
     qed
     ultimately show ?thesis by auto
   qed
 next
   show "E - union_wit E \<subseteq> pos_sub E"
   proof
     fix a
     assume "a \<in> E - union_wit E"
     show "a \<in> pos_sub E" unfolding pos_sub_def
     proof
       fix n
       show "a \<in> pos_wtn E n"
       proof (cases "n = 0")
         case True
         thus ?thesis using pos_wtn_base \<open>a\<in> E - union_wit E\<close> by simp
       next
         case False
         hence "\<exists>m. n = Suc m" by (simp add: not0_implies_Suc) 
         from this obtain m where "n = Suc m" by auto
         have "(\<Union> i \<le> m. rep_neg (pos_wtn E i)) \<subseteq> 
           (\<Union> n. (rep_neg (pos_wtn E n)))" by auto
         hence "a \<in> E - (\<Union> i \<le> m. rep_neg (pos_wtn E i))" 
           using \<open>a \<in> E - union_wit E\<close> unfolding union_wit_def neg_wtn_def 
           by auto
         thus "a\<in> pos_wtn E n" using pos_wtn_Suc \<open>n = Suc m\<close> 
           unfolding neg_wtn_def by simp
       qed
     qed
   qed
 qed
 
 definition num_wtn where
   "num_wtn E n = inf_neg (pos_wtn E n)"
 
 lemma num_wtn_geq:
   shows "\<mu> (neg_wtn E n) \<le> ereal (-1/(num_wtn E n))" 
 proof (cases "(pos_wtn E n) \<notin> sets M \<or> pos_meas_set (pos_wtn E n)")
   case True
   hence "neg_wtn E n = {}" unfolding neg_wtn_def rep_neg_def by simp
   moreover have "num_wtn E n = 0" using True unfolding num_wtn_def inf_neg_def 
     by simp
   ultimately show ?thesis using sgn_meas signed_measure_empty by force 
 next
   case False
   then show ?thesis using g_rep_neg(3)[of "pos_wtn E n"] unfolding neg_wtn_def 
       num_wtn_def by simp
 qed
 
 lemma neg_wtn_infty:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "\<bar>\<mu> (neg_wtn E i)\<bar> < \<infinity>"
 proof (rule signed_measure_finite_subset)
   show "E \<in> sets M" "\<bar>\<mu> E\<bar> < \<infinity>" using assms by auto
   show "neg_wtn E i \<in> sets M" 
   proof (cases "pos_wtn E i \<notin> sets M \<or> pos_meas_set (pos_wtn E i)")
     case True
     then show ?thesis unfolding neg_wtn_def rep_neg_def by simp
   next
     case False
     then show ?thesis unfolding neg_wtn_def 
       using g_rep_neg(1)[of "pos_wtn E i"] by simp
   qed
   show "neg_wtn E i \<subseteq> E" unfolding neg_wtn_def using pos_wtn_subset[of E] 
       rep_neg_subset[of "pos_wtn E i"] by auto
 qed
 
 lemma union_wit_infty:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "\<bar>\<mu> (union_wit E)\<bar> < \<infinity>" using union_wit_subset union_wit_sets 
     signed_measure_finite_subset assms unfolding union_wit_def by simp
 
 lemma neg_wtn_summable:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "summable (\<lambda>i. - real_of_ereal (\<mu> (neg_wtn E i)))"
 proof -
   have "signed_measure M \<mu>" using sgn_meas .
   moreover have "range (neg_wtn E) \<subseteq> sets M" unfolding neg_wtn_def 
     using rep_neg_sets by auto
   moreover have "disjoint_family (neg_wtn E)" using neg_wtn_djn by simp
   moreover have "\<Union> (range (neg_wtn E)) \<in> sets M" using union_wit_sets 
     unfolding union_wit_def by simp
   moreover have "\<bar>\<mu> (\<Union> (range (neg_wtn E)))\<bar> < \<infinity>" 
     using union_wit_subset signed_measure_finite_subset union_wit_sets assms
     unfolding union_wit_def by simp
   ultimately have "summable (\<lambda>i. real_of_ereal \<bar>\<mu> (neg_wtn E i)\<bar>)" 
     using signed_measure_abs_convergent[of M ] by simp
   moreover have "\<And>i. \<bar>\<mu> (neg_wtn E i)\<bar> = -(\<mu> (neg_wtn E i))"
   proof -
     fix i
     have "\<mu> (neg_wtn E i) \<le> 0" using rep_neg_leq[of "pos_wtn E i"] 
       unfolding neg_wtn_def .
     thus "\<bar>\<mu> (neg_wtn E i)\<bar> = -\<mu> (neg_wtn E i)" using less_eq_ereal_def by auto 
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma inv_num_wtn_summable:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "summable (\<lambda>n. 1/(num_wtn E n))"
 proof (rule summable_bounded)
   show "\<And>i. 0 \<le> 1 / real (num_wtn E i)" by simp
   show "\<And>i. 1 / real (num_wtn E i) \<le> (\<lambda>n. -real_of_ereal (\<mu> (neg_wtn E n))) i"
   proof -
     fix i
     have "\<bar>\<mu> (neg_wtn E i)\<bar> < \<infinity>" using assms neg_wtn_infty by simp
     have "ereal (1/(num_wtn E i)) \<le> -\<mu> (neg_wtn E i)" using num_wtn_geq[of E i] 
         ereal_minus_le_minus by fastforce 
     also have "... = ereal(- real_of_ereal (\<mu> (neg_wtn E i)))" 
       using \<open>\<bar>\<mu> (neg_wtn E i)\<bar> < \<infinity>\<close> ereal_real' by auto
     finally have "ereal (1/(num_wtn E i)) \<le> 
       ereal(- real_of_ereal (\<mu> (neg_wtn E i)))" .
     thus "1 / real (num_wtn E i) \<le> -real_of_ereal (\<mu> (neg_wtn E i))" by simp
   qed
   show "summable (\<lambda>i. - real_of_ereal (\<mu> (neg_wtn E i)))" 
     using assms neg_wtn_summable by simp
 qed
 
 lemma inv_num_wtn_shift_summable:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "summable (\<lambda>n. 1/(num_wtn E n - 1))"
 proof (rule sum_shift_denum)
   show "summable (\<lambda>n. 1 / real (num_wtn E n))" using assms inv_num_wtn_summable
     by simp
 qed
 
 lemma neg_wtn_meas_sums:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "(\<lambda>i. - (\<mu> (neg_wtn E i))) sums 
   suminf (\<lambda>i. - real_of_ereal (\<mu> (neg_wtn E i)))"
 proof -
   have "(\<lambda>i. ereal (- real_of_ereal (\<mu> (neg_wtn E i)))) sums 
     suminf (\<lambda>i. - real_of_ereal (\<mu> (neg_wtn E i)))"
   proof (rule sums_ereal[THEN iffD2])
     have "summable (\<lambda>i. - real_of_ereal (\<mu> (neg_wtn E i)))" 
       using neg_wtn_summable assms by simp
     thus "(\<lambda>x. - real_of_ereal (\<mu> (neg_wtn E x))) 
       sums (\<Sum>i. - real_of_ereal (\<mu> (neg_wtn E i)))" 
       by auto
   qed
   moreover have "\<And>i. \<mu> (neg_wtn E i) = ereal (real_of_ereal (\<mu> (neg_wtn E i)))"
   proof -
     fix i
     show "\<mu> (neg_wtn E i) = ereal (real_of_ereal (\<mu> (neg_wtn E i)))"
       using assms(1) assms(2) ereal_real' neg_wtn_infty by auto
   qed
   ultimately show ?thesis 
     by (metis (no_types, lifting) sums_cong uminus_ereal.simps(1)) 
 qed
 
 lemma neg_wtn_meas_suminf_le:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "suminf (\<lambda>i. \<mu> (neg_wtn E i)) \<le> - suminf (\<lambda>n. 1/(num_wtn E n))"
 proof -
   have "suminf (\<lambda>n. 1/(num_wtn E n)) \<le> 
     suminf (\<lambda>i. -real_of_ereal (\<mu> (neg_wtn E i)))"
   proof (rule suminf_le)
     show "summable (\<lambda>n.  1 / real (num_wtn E n))" using assms 
         inv_num_wtn_summable[of E] 
         summable_minus[of "\<lambda>n. 1 / real (num_wtn E n)"]  by simp 
     show "summable (\<lambda>i. -real_of_ereal (\<mu> (neg_wtn E i)))" 
       using neg_wtn_summable assms
         summable_minus[of "\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i))"] 
       by (simp add: summable_minus_iff) 
     show "\<And>n. 1 / real (num_wtn E n) \<le> -real_of_ereal (\<mu> (neg_wtn E n))"
     proof -
       fix n
       have "\<mu> (neg_wtn E n) \<le> ereal (- 1 / real (num_wtn E n))" 
         using num_wtn_geq by simp
       hence "ereal (1/ real (num_wtn E n)) \<le> - \<mu> (neg_wtn E n)"
         by (metis add.inverse_inverse eq_iff ereal_uminus_le_reorder linear 
             minus_divide_left uminus_ereal.simps(1))
       have "real_of_ereal (ereal (1 / real (num_wtn E n))) \<le> 
         real_of_ereal (- \<mu> (neg_wtn E n))"
       proof (rule real_of_ereal_positive_mono)
         show "0 \<le> ereal (1 / real (num_wtn E n))" by simp
         show "ereal (1 / real (num_wtn E n)) \<le> - \<mu> (neg_wtn E n)" 
           using \<open>ereal (1 / real (num_wtn E n)) \<le> - \<mu> (neg_wtn E n)\<close> .
         show "- \<mu> (neg_wtn E n) \<noteq> \<infinity>" using neg_wtn_infty[of E n] assms by auto
       qed
       thus "(1 / real (num_wtn E n)) \<le> -real_of_ereal ( \<mu> (neg_wtn E n))" 
         by simp
     qed
   qed
   also have "... = - suminf (\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i)))" 
   proof (rule suminf_minus)
     show "summable (\<lambda>n. real_of_ereal (\<mu> (neg_wtn E n)))" 
       using neg_wtn_summable assms
         summable_minus[of "\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i))"] 
       by (simp add: summable_minus_iff) 
   qed
   finally have "suminf (\<lambda>n. 1/(num_wtn E n)) \<le> 
     - suminf (\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i)))" .
   hence a:  "suminf (\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i))) \<le> 
     - suminf (\<lambda>n. 1/(num_wtn E n))" by simp
   show "suminf (\<lambda>i. (\<mu> (neg_wtn E i))) \<le> ereal (-suminf (\<lambda>n. 1/(num_wtn E n)))" 
   proof -
     have sumeq: "suminf (\<lambda>i. ereal (real_of_ereal (\<mu> (neg_wtn E i)))) = 
       suminf (\<lambda>i. (real_of_ereal (\<mu> (neg_wtn E i))))"
     proof (rule sums_suminf_ereal)
       have "summable (\<lambda>i. -real_of_ereal (\<mu> (neg_wtn E i)))" 
         using neg_wtn_summable assms
           summable_minus[of "\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i))"] 
         by (simp add: summable_minus_iff)
       thus "(\<lambda>i. real_of_ereal (\<mu> (neg_wtn E i))) sums 
         (\<Sum>i. real_of_ereal (\<mu> (neg_wtn E i)))" 
         using neg_wtn_summable[of E] assms summable_minus_iff by blast
     qed
     hence "suminf (\<lambda>i. \<mu> (neg_wtn E i)) = 
       suminf (\<lambda>i. (real_of_ereal (\<mu> (neg_wtn E i))))" 
     proof -
       have "\<And>i. ereal (real_of_ereal (\<mu> (neg_wtn E i))) = \<mu> (neg_wtn E i)"
       proof -
         fix i
         show "ereal (real_of_ereal (\<mu> (neg_wtn E i))) = \<mu> (neg_wtn E i)"
           using neg_wtn_infty[of E] assms by (simp add: ereal_real')
       qed
       thus ?thesis using sumeq by auto 
     qed
     thus ?thesis using a by simp
   qed
 qed
 
 lemma union_wit_meas_le:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "\<mu> (union_wit E) \<le> - suminf (\<lambda>n. 1 / real (num_wtn E n))" 
 proof -
   have "\<mu> (union_wit E) = \<mu> (\<Union> (range (neg_wtn E)))" unfolding union_wit_def 
     by simp
   also have "... = (\<Sum>i. \<mu> (neg_wtn E i))" 
   proof (rule signed_measure_inf_sum[symmetric])
     show "signed_measure M \<mu>" using sgn_meas .
     show "range (neg_wtn E) \<subseteq> sets M" 
       by (simp add: image_subset_iff neg_wtn_def rep_neg_sets)
     show "disjoint_family (neg_wtn E)" using neg_wtn_djn by simp
     show "\<Union> (range (neg_wtn E)) \<in> sets M" using union_wit_sets 
       unfolding union_wit_def by simp
   qed
   also have "... \<le> - suminf (\<lambda>n. 1 / real (num_wtn E n))" 
     using assms neg_wtn_meas_suminf_le by simp
   finally show ?thesis .
 qed
 
 lemma pos_sub_pos_meas:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "0 < \<mu> E"
     and "\<not> pos_meas_set E"
   shows "0 < \<mu> (pos_sub E)"
 proof -
   have "0 < \<mu> E" using assms by simp
   also have "... = \<mu> (pos_sub E) + \<mu> (union_wit E)"
   proof -
     have "E = pos_sub E \<union> (union_wit E)" 
       using pos_sub_diff[of E] union_wit_subset by force 
     moreover have "pos_sub E \<inter> union_wit E = {}" 
       using pos_sub_diff by auto
     ultimately show ?thesis 
       using signed_measure_add[of M \<mu> "pos_sub E" "union_wit E"] 
         pos_sub_sets union_wit_sets assms sgn_meas by simp
   qed
   also have "... \<le> \<mu> (pos_sub E) + (- suminf (\<lambda>n. 1 / real (num_wtn E n)))"
   proof -
     have "\<mu> (union_wit E) \<le> - suminf (\<lambda>n. 1 / real (num_wtn E n))" 
       using union_wit_meas_le[of E] assms by simp
     thus ?thesis using union_wit_infty assms using add_left_mono by blast
   qed
   also have "... = \<mu> (pos_sub E) - suminf (\<lambda>n. 1 / real (num_wtn E n))"
     by (simp add: minus_ereal_def) 
   finally have "0 < \<mu> (pos_sub E) - suminf (\<lambda>n. 1 / real (num_wtn E n))" .
   moreover have "0 < suminf (\<lambda>n. 1 / real (num_wtn E n))" 
   proof (rule suminf_pos2)
     show "0 < 1 / real (num_wtn E 0)" 
       using inf_neg_ge_1[of E] assms pos_wtn_base unfolding num_wtn_def by simp
     show "\<And>n. 0 \<le> 1 / real (num_wtn E n)" by simp
     show "summable (\<lambda>n. 1 / real (num_wtn E n))" 
       using assms inv_num_wtn_summable by simp
   qed
   ultimately show ?thesis  using pos_sub_infty assms by fastforce
 qed
 
 lemma num_wtn_conv:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "(\<lambda>n. 1/(num_wtn E n)) \<longlonglongrightarrow> 0"
 proof (rule summable_LIMSEQ_zero)
   show "summable (\<lambda>n. 1 / real (num_wtn E n))" 
     using assms inv_num_wtn_summable by simp
 qed
 
 lemma num_wtn_shift_conv:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
   shows "(\<lambda>n. 1/(num_wtn E n - 1)) \<longlonglongrightarrow> 0"
 proof (rule summable_LIMSEQ_zero)
   show "summable (\<lambda>n. 1 / real (num_wtn E n - 1))" 
     using assms inv_num_wtn_shift_summable by simp
 qed
 
 lemma inf_neg_E_set:
   assumes "0 < inf_neg E"
   shows "E \<in> sets M" using assms unfolding inf_neg_def by presburger
 
 lemma inf_neg_pos_meas:
   assumes "0 < inf_neg E"
   shows "\<not> pos_meas_set E" using assms unfolding inf_neg_def by presburger
 
 lemma inf_neg_mem:
   assumes "0 < inf_neg E"
   shows "inf_neg E \<in> {n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> E \<and> \<mu> B < ereal (-1/n))}"
 proof -
   have "E \<in> sets M" using assms unfolding inf_neg_def by presburger
   moreover have "\<not> pos_meas_set E" using assms unfolding inf_neg_def 
     by presburger
   ultimately have "{n::nat|n. (1::nat) \<le> n \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> E \<and> \<mu> B < ereal (-1/n))} \<noteq> {}" 
     using inf_neg_ne[of E] by simp
   thus ?thesis unfolding inf_neg_def 
     by (meson Inf_nat_def1 \<open>E \<in> sets M\<close> \<open>\<not> pos_meas_set E\<close>)
 qed
 
 lemma prec_inf_neg_pos:
   assumes "0 < inf_neg E - 1"
     and "B \<in> sets M"
     and "B\<subseteq> E"
   shows "-1/(inf_neg E - 1) \<le> \<mu> B"
 proof (rule ccontr)
   define S where "S = {p::nat|p. (1::nat) \<le> p \<and> 
     (\<exists>B \<in> sets M. B  \<subseteq> E \<and> \<mu> B < ereal (-1/p))}"
   assume "\<not> ereal (- 1 / real (inf_neg E - 1)) \<le> \<mu> B"
   hence "\<mu> B < -1/(inf_neg E - 1)" by auto
   hence "inf_neg E - 1\<in> S" unfolding S_def using assms by auto
   have "Suc 0 < inf_neg E" using assms by simp
   hence "inf_neg E \<in> S" unfolding  S_def using inf_neg_mem[of E] by simp
   hence "S \<noteq> {}" by auto
   have "inf_neg E = Inf S" unfolding S_def inf_neg_def 
     using assms inf_neg_E_set inf_neg_pos_meas by auto
   have  "inf_neg E - 1 < inf_neg E" using assms by simp
   hence "inf_neg E -1 \<notin> S" 
     using cInf_less_iff[of S] \<open>S \<noteq> {}\<close> \<open>inf_neg E = Inf S\<close> by auto
   thus False using \<open>inf_neg E - 1 \<in> S\<close> by simp
 qed
 
 lemma pos_wtn_meas_ge:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "C\<in> sets M"
     and "\<And>n. C\<subseteq> pos_wtn E n"
     and "\<And>n. 0 < num_wtn E n"
   shows "\<exists>N. \<forall>n\<ge> N. - 1/ (num_wtn E n - 1) \<le> \<mu> C" 
 proof -
   have "\<exists>N. \<forall>n\<ge> N. 1/(num_wtn E n) < 1/2" using num_wtn_conv[of E] 
       conv_0_half[of "\<lambda>n. 1 / real (num_wtn E n)"] assms by simp
   from this obtain N where "\<forall>n\<ge> N. 1/(num_wtn E n) < 1/2" by auto
   {
     fix n
     assume "N \<le> n"
     hence "1/(num_wtn E n) < 1/2" using \<open>\<forall>n\<ge> N. 1/(num_wtn E n) < 1/2\<close> by simp
     have "1/(1/2) < 1/(1/(num_wtn E n))" 
     proof (rule frac_less2, auto)
       show "2 / real (num_wtn E n) < 1" using \<open>1/(num_wtn E n) < 1/2\<close> 
         by linarith
       show "0 < num_wtn E n" unfolding num_wtn_def using inf_neg_ge_1 assms
         by (simp add: num_wtn_def)
     qed
     hence "2 < (num_wtn E n)" by simp
     hence "Suc 0 < num_wtn E n - 1" unfolding num_wtn_def by simp
     hence "- 1/ (num_wtn E n - 1) \<le> \<mu> C" using assms prec_inf_neg_pos 
       unfolding num_wtn_def by simp
   }
   thus ?thesis by auto
 qed
 
 lemma pos_sub_pos_meas_subset:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "C\<in> sets M"
     and "C\<subseteq> (pos_sub E)"
     and "\<And>n. 0 < num_wtn E n"
   shows "0 \<le> \<mu> C"
 proof -
   have "\<And>n. C \<subseteq> pos_wtn E n" using assms unfolding pos_sub_def by auto
   hence "\<exists>N. \<forall>n\<ge> N. - 1/ (num_wtn E n - 1) \<le> \<mu> C" using  assms  
       pos_wtn_meas_ge[of E C] by simp
   from this obtain N where Nprop: "\<forall>n\<ge> N. - 1/ (num_wtn E n - 1) \<le> \<mu> C" by auto
   show "0 \<le> \<mu> C"
   proof (rule lim_mono)
     show "\<And>n. N \<le> n \<Longrightarrow> - 1/ (num_wtn E n - 1) \<le> (\<lambda>n. \<mu> C) n" 
       using Nprop by simp
     have "(\<lambda>n.  ( 1 / real (num_wtn E n - 1))) \<longlonglongrightarrow> 0" 
       using assms num_wtn_shift_conv[of E] by simp
     hence "(\<lambda>n.  (- 1 / real (num_wtn E n - 1))) \<longlonglongrightarrow> 0" 
       using tendsto_minus[of "\<lambda>n. 1 / real (num_wtn E n - 1)" 0] by simp
     thus "(\<lambda>n. ereal (- 1 / real (num_wtn E n - 1))) \<longlonglongrightarrow> 0" 
       by (simp add: zero_ereal_def) 
     show "(\<lambda>n. \<mu> C) \<longlonglongrightarrow> \<mu> C" by simp
   qed
 qed
 
 lemma pos_sub_pos_meas':
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "0 < \<mu> E"
     and "\<forall>n. 0 < num_wtn E n"
   shows "0 < \<mu> (pos_sub E)"
 proof -
   have "0 < \<mu> E" using assms by simp
   also have "... = \<mu> (pos_sub E) + \<mu> (union_wit E)"
   proof -
     have "E = pos_sub E \<union> (union_wit E)" 
       using pos_sub_diff[of E] union_wit_subset by force 
     moreover have "pos_sub E \<inter> union_wit E = {}" 
       using pos_sub_diff by auto
     ultimately show ?thesis 
       using signed_measure_add[of M \<mu> "pos_sub E" "union_wit E"] 
         pos_sub_sets union_wit_sets assms sgn_meas by simp
   qed
   also have "... \<le> \<mu> (pos_sub E) + (- suminf (\<lambda>n. 1 / real (num_wtn E n)))"
   proof -
     have "\<mu> (union_wit E) \<le> - suminf (\<lambda>n. 1 / real (num_wtn E n))" 
       using union_wit_meas_le[of E] assms by simp
     thus ?thesis using union_wit_infty assms using add_left_mono by blast
   qed
   also have "... = \<mu> (pos_sub E) - suminf (\<lambda>n. 1 / real (num_wtn E n))"
     by (simp add: minus_ereal_def) 
   finally have "0 < \<mu> (pos_sub E) - suminf (\<lambda>n. 1 / real (num_wtn E n))" .
   moreover have "0 < suminf (\<lambda>n. 1 / real (num_wtn E n))" 
   proof (rule suminf_pos2)
     show "0 < 1 / real (num_wtn E 0)" using assms by simp
     show "\<And>n. 0 \<le> 1 / real (num_wtn E n)" by simp
     show "summable (\<lambda>n. 1 / real (num_wtn E n))" 
       using assms inv_num_wtn_summable by simp
   qed
   ultimately show ?thesis  using pos_sub_infty assms by fastforce
 qed
 
 text \<open>We obtain the main result of this part on the existence of a positive subset.\<close>
 
 lemma exists_pos_meas_subset:
   assumes "E \<in> sets M"
     and "\<bar>\<mu> E\<bar> < \<infinity>"
     and "0 < \<mu> E"
   shows "\<exists>A. A \<subseteq> E \<and> pos_meas_set A \<and> 0 < \<mu> A"
 proof (cases "\<forall>n. 0 < num_wtn E n")
   case True
   have "pos_meas_set (pos_sub E)" 
   proof (rule pos_meas_setI)
     show "pos_sub E \<in> sets M" by (simp add: assms(1) pos_sub_sets) 
     fix A
     assume "A \<in> sets M" and "A\<subseteq> pos_sub E"
     thus "0 \<le> \<mu> A" using assms True pos_sub_pos_meas_subset[of E] by simp
   qed
   moreover have "0 < \<mu> (pos_sub E)" 
     using pos_sub_pos_meas'[of E] True assms by simp
   ultimately show ?thesis using pos_meas_set_def by (metis pos_sub_subset)
 next
   case False
   hence "\<exists>n. num_wtn E n = 0" by simp
   from this obtain n where "num_wtn E n = 0" by auto
   hence "pos_wtn E n \<notin> sets M \<or> pos_meas_set (pos_wtn E n)" 
     using inf_neg_ge_1 unfolding num_wtn_def by fastforce
   hence "pos_meas_set (pos_wtn E n)" using assms 
     by (simp add: \<open>E \<in> sets M\<close> pos_wtn_sets) 
   moreover have "0 < \<mu> (pos_wtn E n)" using pos_wtn_meas_gt assms by simp
   ultimately show ?thesis using pos_meas_set_def by (meson pos_wtn_subset)   
 qed
 
 section \<open>The Hahn decomposition theorem\<close>
 
 definition seq_meas where
   "seq_meas = (SOME f. incseq f \<and> range f \<subseteq> pos_img  \<and> \<Squnion> pos_img = \<Squnion> range f)"
 
 lemma seq_meas_props:
   shows "incseq seq_meas \<and> range seq_meas \<subseteq> pos_img \<and> 
     \<Squnion> pos_img = \<Squnion> range seq_meas"
 proof -
   have ex: "\<exists>f. incseq f \<and> range f \<subseteq> pos_img  \<and> \<Squnion> pos_img = \<Squnion> range f"
   proof (rule Extended_Real.Sup_countable_SUP)
     show "pos_img \<noteq> {}"
     proof -
       have "{} \<in> pos_sets" using empty_pos_meas_set unfolding pos_sets_def 
         by simp
       hence "\<mu> {} \<in> pos_img" unfolding pos_img_def by auto
       thus ?thesis by auto
     qed 
   qed
   let ?V = "SOME f. incseq f \<and> range f \<subseteq> pos_img  \<and> \<Squnion> pos_img = \<Squnion> range f"
   have vprop: "incseq ?V \<and> range ?V \<subseteq> pos_img \<and> \<Squnion> pos_img = \<Squnion> range ?V" 
     using someI_ex[of "\<lambda>f. incseq f \<and> range f \<subseteq> pos_img  \<and> 
       \<Squnion> pos_img = \<Squnion> range f"] ex by blast
   show ?thesis using seq_meas_def vprop by presburger
 qed
 
 definition seq_meas_rep where
   "seq_meas_rep n = (SOME A. A\<in> pos_sets \<and> seq_meas n = \<mu> A)"
 
 lemma seq_meas_rep_ex:
   shows "seq_meas_rep n \<in> pos_sets \<and> \<mu> (seq_meas_rep n) = seq_meas n"
 proof -
   have ex: "\<exists>A. A \<in> pos_sets \<and> seq_meas n = \<mu> A" using seq_meas_props
-    by (smt (z3) UNIV_I image_subset_iff mem_Collect_eq pos_img_def) 
+    by (smt (verit) UNIV_I image_subset_iff mem_Collect_eq pos_img_def) 
   let ?V = "SOME A. A\<in> pos_sets \<and> seq_meas n = \<mu> A"
   have vprop: "?V\<in> pos_sets \<and> seq_meas n = \<mu> ?V" using 
       someI_ex[of "\<lambda>A. A\<in> pos_sets \<and> seq_meas n = \<mu> A"] using ex by blast
   show ?thesis using seq_meas_rep_def vprop by fastforce 
 qed
 
 lemma seq_meas_rep_pos:
   assumes "\<forall>E \<in> sets M. \<mu> E < \<infinity>" 
   shows "pos_meas_set (\<Union> i. seq_meas_rep i)" 
 proof (rule pos_meas_set_Union)
   show " \<And>i. pos_meas_set (seq_meas_rep i)" 
     using seq_meas_rep_ex signed_measure_space.pos_sets_def 
       signed_measure_space_axioms by auto
   then show "\<And>i. seq_meas_rep i \<in> sets M"
     by (simp add: pos_meas_setD1)
   show "\<bar>\<mu> (\<Union> (range seq_meas_rep))\<bar> < \<infinity>"
   proof -
     have "(\<Union> (range seq_meas_rep)) \<in> sets M"
     proof (rule sigma_algebra.countable_Union)
       show "sigma_algebra (space M) (sets M)" 
         by (simp add: sets.sigma_algebra_axioms) 
       show "countable (range seq_meas_rep)" by simp
       show "range seq_meas_rep \<subseteq> sets M" 
         by (simp add: \<open>\<And>i. seq_meas_rep i \<in> sets M\<close> image_subset_iff)
     qed
     hence "\<mu> (\<Union> (range seq_meas_rep)) \<ge> 0 " 
       using \<open>\<And>i. pos_meas_set (seq_meas_rep i)\<close> \<open>\<And>i. seq_meas_rep i \<in> sets M\<close> 
         signed_measure_space.pos_meas_set_pos_lim signed_measure_space_axioms 
       by blast
     thus ?thesis using assms \<open>\<Union> (range seq_meas_rep) \<in> sets M\<close> abs_ereal_ge0  
       by simp
   qed   
 qed
 
 lemma sup_seq_meas_rep:
   assumes "\<forall>E \<in> sets M. \<mu> E < \<infinity>" 
     and "S = (\<Squnion> pos_img)"
     and "A = (\<Union> i. seq_meas_rep i)"
   shows "\<mu> A = S"
 proof -
   have pms: "pos_meas_set (\<Union> i. seq_meas_rep i)" 
     using assms seq_meas_rep_pos by simp
   hence "\<mu> A \<le> S" 
     by (metis (mono_tags, lifting) Sup_upper \<open>S = \<Squnion> pos_img\<close> mem_Collect_eq 
         pos_img_def pos_meas_setD1 pos_sets_def assms(2) assms(3))  
   have "\<forall>n. (\<mu> A = \<mu> (A - seq_meas_rep n) + \<mu> (seq_meas_rep n))"
   proof
     fix n
     have "A = (A - seq_meas_rep n) \<union> seq_meas_rep n " 
       using \<open>A = \<Union> (range seq_meas_rep)\<close> by blast
     hence "\<mu> A = \<mu> ((A - seq_meas_rep n) \<union> seq_meas_rep n)"  by simp
     also have "... = \<mu> (A - seq_meas_rep n) + \<mu> (seq_meas_rep n)" 
     proof (rule signed_measure_add)
       show "signed_measure M \<mu>" using sgn_meas by simp
       show "seq_meas_rep n \<in> sets M"
         using pos_sets_def seq_meas_rep_ex by auto
       then show "A - seq_meas_rep n \<in> sets M"
         by (simp add: assms pms pos_meas_setD1 sets.Diff)
       show "(A - seq_meas_rep n) \<inter> seq_meas_rep n = {}" by auto
     qed
     finally show "\<mu> A = \<mu> (A - seq_meas_rep n) + \<mu> (seq_meas_rep n)".
   qed
   have "\<forall>n. \<mu> A \<ge> \<mu> (seq_meas_rep n)" 
   proof 
     fix n
     have "\<mu> A \<ge> 0" using pms assms unfolding pos_meas_set_def by auto
     have "(A - seq_meas_rep n) \<subseteq> A" by simp
     hence "pos_meas_set (A - seq_meas_rep n)" 
     proof -
       have "(A - seq_meas_rep n) \<in> sets M"
         using pms assms pos_meas_setD1 pos_sets_def seq_meas_rep_ex by auto
       thus ?thesis using pms assms unfolding pos_meas_set_def by auto
     qed
     hence "\<mu> (A - seq_meas_rep n) \<ge> 0" unfolding pos_meas_set_def by auto
     thus "\<mu> (seq_meas_rep n) \<le> \<mu> A" 
       using \<open>\<forall>n. (\<mu> A = \<mu> (A - seq_meas_rep n) + \<mu> (seq_meas_rep n))\<close>
       by (metis ereal_le_add_self2) 
   qed
   hence "\<mu> A \<ge> (\<Squnion> range seq_meas)" by (simp add: Sup_le_iff seq_meas_rep_ex)
   moreover have "S = (\<Squnion> range seq_meas)" 
     using seq_meas_props \<open>S = (\<Squnion> pos_img)\<close> by simp
   ultimately have "\<mu> A \<ge> S" by simp
   thus "\<mu> A = S" using \<open>\<mu> A \<le> S\<close> by simp
 qed
 
 lemma seq_meas_rep_compl:
   assumes "\<forall>E \<in> sets M. \<mu> E < \<infinity>"
     and "A = (\<Union> i. seq_meas_rep i)"
   shows "neg_meas_set ((space M) - A)" unfolding neg_meas_set_def
 proof (rule ccontr)
   assume asm: "\<not> (space M - A \<in> sets M \<and> 
     (\<forall>Aa\<in>sets M. Aa \<subseteq> space M - A \<longrightarrow> \<mu> Aa \<le> 0))" 
   define S where "S = (\<Squnion> pos_img)"
   have "pos_meas_set A"  using assms seq_meas_rep_pos by simp
   have "\<mu> A = S" using sup_seq_meas_rep assms  S_def by simp
   hence "S < \<infinity>" using assms \<open>pos_meas_set A\<close> pos_meas_setD1 by blast 
   have "(space M - A \<in> sets M)"
     by (simp add: \<open>pos_meas_set A\<close> pos_meas_setD1 sets.compl_sets)
   hence " \<not>(\<forall>Aa\<in>sets M. Aa \<subseteq> space M - A \<longrightarrow> \<mu> Aa \<le> 0)" using asm by blast
   hence "\<exists> E \<in> sets M. E \<subseteq> ((space M) - A) \<and> \<mu> E > 0" 
     by (metis less_eq_ereal_def linear)
   from this obtain E where "E \<in> sets M" and "E \<subseteq> ((space M) - A)" and 
     "\<mu> E > 0" by auto
   have "\<exists> A0 \<subseteq> E. pos_meas_set A0 \<and> \<mu> A0 > 0" 
   proof (rule exists_pos_meas_subset) 
     show "E \<in> sets M" using \<open>E \<in> sets M\<close> by simp
     show "0 < \<mu> E" using \<open>\<mu> E > 0\<close> by simp
     show "\<bar>\<mu> E\<bar> < \<infinity>" 
     proof -
       have "\<mu> E < \<infinity>" using assms \<open>E \<in> sets M\<close> by simp
       moreover have "- \<infinity> < \<mu> E" using \<open>0 < \<mu> E\<close> by simp 
       ultimately show ?thesis
         by (meson ereal_infty_less(1) not_inftyI)
     qed
   qed
   from this obtain A0 where "A0 \<subseteq> E" and "pos_meas_set A0" and " \<mu> A0 > 0" 
     by auto
   have "pos_meas_set (A \<union> A0)" 
     using pos_meas_set_union \<open>pos_meas_set A0\<close> \<open>pos_meas_set A\<close> by simp
   have "\<mu> (A \<union> A0) = \<mu> A + \<mu> A0" 
   proof (rule signed_measure_add)
     show "signed_measure M \<mu>" using sgn_meas by simp
     show "A \<in> sets M" using \<open>pos_meas_set A\<close> 
       unfolding pos_meas_set_def by simp
     show "A0 \<in> sets M" using \<open>pos_meas_set A0\<close> 
       unfolding pos_meas_set_def by simp
     show "(A \<inter> A0) = {}" using \<open>A0 \<subseteq> E\<close> \<open>E \<subseteq> ((space M) - A)\<close> by auto
   qed
   then have "\<mu> (A \<union> A0) > S" 
     using \<open>\<mu> A = S\<close> \<open>\<mu> A0 > 0\<close>
     by (metis \<open>S < \<infinity>\<close> \<open>pos_meas_set (A \<union> A0)\<close> abs_ereal_ge0 ereal_between(2) 
         not_inftyI not_less_iff_gr_or_eq pos_meas_self)
   have "(A \<union> A0) \<in> pos_sets"
   proof -
     have " (A \<union> A0) \<in> sets M" using sigma_algebra.countable_Union
       by (simp add: \<open>pos_meas_set (A \<union> A0)\<close> pos_meas_setD1) 
     moreover have "pos_meas_set (A \<union> A0)" using \<open>pos_meas_set (A \<union> A0)\<close> by simp
     ultimately show ?thesis unfolding pos_sets_def by simp
   qed
   then have "\<mu> (A \<union> A0) \<in> pos_img" unfolding pos_img_def by auto
   show False using \<open>\<mu> (A \<union> A0) > S\<close> \<open>\<mu> (A \<union> A0) \<in> pos_img\<close> \<open>S = (\<Squnion> pos_img)\<close>
     by (metis Sup_upper sup.absorb_iff2 sup.strict_order_iff)
 qed
 
 lemma hahn_decomp_finite:
   assumes "\<forall>E \<in> sets M. \<mu> E < \<infinity>"
   shows "\<exists> M1 M2. hahn_space_decomp M1 M2" unfolding hahn_space_decomp_def
 proof -
   define S where "S = (\<Squnion> pos_img)"
   define A where "A = (\<Union> i. seq_meas_rep i)" 
   have "pos_meas_set A" unfolding A_def using assms seq_meas_rep_pos by simp
   have "neg_meas_set ((space M) - A)" 
     using seq_meas_rep_compl assms unfolding A_def by simp
   show "\<exists>M1 M2. pos_meas_set M1 \<and> neg_meas_set M2 \<and> space M = M1 \<union> M2 \<and> 
     M1 \<inter> M2 = {}"
   proof (intro exI conjI)
     show "pos_meas_set A" using \<open>pos_meas_set A\<close> .
     show "neg_meas_set (space M - A)" using \<open>neg_meas_set (space M - A)\<close> .
     show "space M = A \<union> (space M - A)"
       by (metis Diff_partition \<open>pos_meas_set A\<close> inf.absorb_iff2 pos_meas_setD1 
           sets.Int_space_eq1) 
     show "A \<inter> (space M - A) = {}" by auto
   qed
 qed
 
 theorem hahn_decomposition:
   shows "\<exists> M1 M2. hahn_space_decomp M1 M2"
 proof (cases "\<forall>E \<in> sets M. \<mu> E < \<infinity>")
   case True
   thus ?thesis using hahn_decomp_finite by simp
 next
   case False
   define m where "m = (\<lambda>A . - \<mu> A)"
   have "\<exists> M1 M2. signed_measure_space.hahn_space_decomp M m M1 M2"
   proof (rule signed_measure_space.hahn_decomp_finite)
     show "signed_measure_space M m" 
       using signed_measure_minus sgn_meas \<open>m = (\<lambda>A . - \<mu> A)\<close>  
       by (unfold_locales, simp)
     show "\<forall>E\<in>sets M. m E < \<infinity>"
     proof
       fix E
       assume "E \<in> sets M"
       show "m E < \<infinity>"
       proof
         show "m E \<noteq> \<infinity>"
         proof (rule ccontr)
           assume "\<not> m E \<noteq> \<infinity>"
           have "m E = \<infinity>"
             using \<open>\<not> m E \<noteq> \<infinity>\<close> by auto 
           have "signed_measure M m"
             using \<open>signed_measure_space M m\<close> signed_measure_space_def by auto
           moreover have "m E = - \<mu> E" using \<open>m = (\<lambda>A . - \<mu> A)\<close> by auto
           then have "\<infinity> \<notin> range m" using \<open>signed_measure M m\<close>
             by (metis (no_types, lifting) False ereal_less_PInfty 
                 ereal_uminus_eq_reorder image_iff inf_range m_def rangeI)
           show False using \<open>m E = \<infinity>\<close> \<open>\<infinity> \<notin> range m\<close>
             by (metis rangeI)
         qed
       qed
     qed
   qed
   hence "\<exists> M1 M2. (neg_meas_set M1) \<and> (pos_meas_set M2) \<and> (space M = M1 \<union> M2) \<and>
     (M1 \<inter> M2 = {})" 
     using pos_meas_set_opp neg_meas_set_opp unfolding m_def 
     by (metis sgn_meas signed_measure_minus signed_measure_space_def 
         signed_measure_space.hahn_space_decomp_def)
   thus ?thesis using hahn_space_decomp_def by (metis inf_commute sup_commute)
 qed
 
 section \<open>The Jordan decomposition theorem\<close>
 
 definition jordan_decomp where
   "jordan_decomp m1 m2 \<longleftrightarrow> ((measure_space (space M) (sets M) m1) \<and> 
     (measure_space (space M) (sets M) m2) \<and> 
     (\<forall>A\<in> sets M. 0 \<le> m1 A) \<and>
     (\<forall> A\<in> sets M. 0 \<le> m2 A) \<and>
     (\<forall>A \<in> sets M. \<mu> A = (m1 A) - (m2 A)) \<and>
     (\<forall> P N A. hahn_space_decomp P N \<longrightarrow> 
       (A \<in> sets M \<longrightarrow> A \<subseteq> P \<longrightarrow> (m2 A) = 0) \<and> 
       (A \<in> sets M \<longrightarrow> A \<subseteq> N \<longrightarrow> (m1 A) = 0)) \<and>
     ((\<forall>A \<in> sets M. m1 A < \<infinity>) \<or> (\<forall>A \<in> sets M. m2 A < \<infinity>)))"
 
 lemma jordan_decomp_pos_meas:
   assumes "jordan_decomp m1 m2"
     and "hahn_space_decomp P N"
     and "A \<in> sets M"
   shows "m1 A = \<mu> (A \<inter> P)" 
 proof -
   have "A\<inter>P \<in> sets M" using assms unfolding hahn_space_decomp_def
     by (simp add: pos_meas_setD1 sets.Int)
   have "A\<inter> N \<in> sets M" using assms unfolding hahn_space_decomp_def
     by (simp add: neg_meas_setD1 sets.Int)
   have "(A \<inter> P) \<inter> (A\<inter> N) = {}" using assms unfolding hahn_space_decomp_def 
     by auto
   have "A = (A \<inter> P) \<union> (A\<inter> N)" using assms unfolding hahn_space_decomp_def
     by (metis Int_Un_distrib sets.Int_space_eq2)
   hence "m1 A = m1 ((A \<inter> P) \<union> (A\<inter> N))" by simp
   also have "... = m1 (A \<inter> P) + m1 (A \<inter> N)" 
     using assms pos_e2ennreal_additive[of M m1] \<open>A\<inter>P \<in> sets M\<close> \<open>A\<inter>N \<in> sets M\<close> 
       \<open>A \<inter> P \<inter> (A \<inter> N) = {}\<close> 
     unfolding jordan_decomp_def additive_def by simp
   also have "... = m1 (A \<inter> P)" using assms unfolding jordan_decomp_def
     by (metis Int_lower2 \<open>A \<inter> N \<in> sets M\<close> add.right_neutral)
   also have "... = m1 (A \<inter> P) - m2 (A \<inter> P)" 
     using assms unfolding jordan_decomp_def
     by (metis Int_subset_iff \<open>A \<inter> P \<in> sets M\<close> ereal_minus(7) 
         local.pos_wtn_base pos_wtn_subset)
   also have "... = \<mu> (A \<inter> P)" using assms \<open>A \<inter> P \<in> sets M\<close> 
     unfolding jordan_decomp_def by simp
   finally show ?thesis .
 qed
 
 lemma jordan_decomp_neg_meas:
   assumes "jordan_decomp m1 m2"
     and "hahn_space_decomp P N"
     and "A \<in> sets M"
   shows "m2 A = -\<mu> (A \<inter> N)" 
 proof -
   have "A\<inter>P \<in> sets M" using assms unfolding hahn_space_decomp_def
     by (simp add: pos_meas_setD1 sets.Int)
   have "A\<inter> N \<in> sets M" using assms unfolding hahn_space_decomp_def
     by (simp add: neg_meas_setD1 sets.Int)
   have "(A \<inter> P) \<inter> (A\<inter> N) = {}" 
     using assms unfolding hahn_space_decomp_def by auto
   have "A = (A \<inter> P) \<union> (A\<inter> N)" 
     using assms unfolding hahn_space_decomp_def
     by (metis Int_Un_distrib sets.Int_space_eq2)
   hence "m2 A = m2 ((A \<inter> P) \<union> (A\<inter> N))" by simp
   also have "... = m2 (A \<inter> P) + m2 (A \<inter> N)" 
     using pos_e2ennreal_additive[of M m2] assms
       \<open>A\<inter>P \<in> sets M\<close> \<open>A\<inter>N \<in> sets M\<close> \<open>A \<inter> P \<inter> (A \<inter> N) = {}\<close> 
     unfolding jordan_decomp_def additive_def by simp
   also have "... = m2 (A \<inter> N)" using assms unfolding jordan_decomp_def
     by (metis Int_lower2 \<open>A \<inter> P \<in> sets M\<close> add.commute add.right_neutral)
   also have "... = m2 (A \<inter> N) - m1 (A \<inter> N)" 
     using assms unfolding jordan_decomp_def
     by (metis Int_lower2 \<open>A \<inter> N \<in> sets M\<close> ereal_minus(7))
   also have "... = -\<mu> (A \<inter> N)" using assms \<open>A \<inter> P \<in> sets M\<close> 
     unfolding jordan_decomp_def
     by (metis Diff_cancel Diff_eq_empty_iff Int_Un_eq(2) \<open>A \<inter> N \<in> sets M\<close> 
         \<open>m2 (A \<inter> N) = m2 (A \<inter> N) - m1 (A \<inter> N)\<close> ereal_minus(8) 
         ereal_uminus_eq_reorder sup.bounded_iff)
   finally show ?thesis .
 qed
 
 lemma pos_inter_neg_0:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp P N"
     and "A \<in> sets M"
     and "A \<subseteq> N"
   shows "\<mu> (A \<inter> M1) = 0"
 proof -
   have "\<mu> (A \<inter> M1) = \<mu> (A \<inter> ((M1 \<inter> P) \<union> (M1 \<inter> (sym_diff M1 P))))"
     by (metis Diff_subset_conv Int_Un_distrib Un_upper1 inf.orderE)
   also have "... = \<mu> ((A \<inter> (M1 \<inter> P)) \<union> (A \<inter> (M1 \<inter> (sym_diff M1 P))))" 
     by (simp add: Int_Un_distrib) 
   also have "... = \<mu> (A \<inter> (M1 \<inter> P)) + \<mu> (A \<inter> (M1 \<inter> (sym_diff M1 P)))" 
   proof (rule signed_measure_add)
     show "signed_measure M \<mu>" using sgn_meas .
     show "A \<inter> (M1 \<inter> P) \<in> sets M"
       by (meson assms(1) assms(2) assms(3) hahn_space_decomp_def sets.Int 
           signed_measure_space.pos_meas_setD1 signed_measure_space_axioms) 
     show "A \<inter> (M1 \<inter> sym_diff M1 P) \<in> sets M"
       by (meson Diff_subset assms(1) assms(2) assms(3) hahn_space_decomp_def 
           pos_meas_setD1 pos_meas_set_union pos_meas_subset sets.Diff sets.Int)
     show "A \<inter> (M1 \<inter> P) \<inter> (A \<inter> (M1 \<inter> sym_diff M1 P)) = {}" by auto
   qed
   also have "... = \<mu> (A \<inter> (M1 \<inter> (sym_diff M1 P)))"
   proof -
     have "A \<inter> (M1 \<inter> P) = {}" using assms hahn_space_decomp_def by auto
     thus ?thesis using signed_measure_empty[OF sgn_meas] by simp
   qed
   also have "... = 0" 
   proof (rule hahn_decomp_ess_unique[OF assms(1) assms(2)]) 
     show "A \<inter> (M1 \<inter> sym_diff M1 P) \<subseteq> sym_diff M1 P \<union> sym_diff M2 N" by auto
     show "A \<inter> (M1 \<inter> sym_diff M1 P) \<in> sets M" 
     proof -
       have "sym_diff M1 P \<in> sets M" using assms
         by (meson hahn_space_decomp_def sets.Diff sets.Un 
             signed_measure_space.pos_meas_setD1 signed_measure_space_axioms)
       hence "M1 \<inter> sym_diff M1 P \<in> sets M"
         by (meson assms(1) hahn_space_decomp_def pos_meas_setD1 sets.Int)
       thus ?thesis by (simp add: assms sets.Int)
     qed
   qed
   finally show ?thesis .
 qed
 
 lemma neg_inter_pos_0:
   assumes "hahn_space_decomp M1 M2"
     and "hahn_space_decomp P N"
     and "A \<in> sets M"
     and "A \<subseteq> P"
   shows "\<mu> (A \<inter> M2) = 0"
 proof -
   have "\<mu> (A \<inter> M2) = \<mu> (A \<inter> ((M2 \<inter> N) \<union> (M2 \<inter> (sym_diff M2 N))))"
     by (metis Diff_subset_conv Int_Un_distrib Un_upper1 inf.orderE)
   also have "... = \<mu> ((A \<inter> (M2 \<inter> N)) \<union> (A \<inter> (M2 \<inter> (sym_diff M2 N))))" 
     by (simp add: Int_Un_distrib) 
   also have "... = \<mu> (A \<inter> (M2 \<inter> N)) + \<mu> (A \<inter> (M2 \<inter> (sym_diff M2 N)))" 
   proof (rule signed_measure_add)
     show "signed_measure M \<mu>" using sgn_meas .
     show "A \<inter> (M2 \<inter> N) \<in> sets M"
       by (meson assms(1) assms(2) assms(3) hahn_space_decomp_def sets.Int 
           signed_measure_space.neg_meas_setD1 signed_measure_space_axioms) 
     show "A \<inter> (M2 \<inter> sym_diff M2 N) \<in> sets M"
       by (meson Diff_subset assms(1) assms(2) assms(3) hahn_space_decomp_def 
           neg_meas_setD1 neg_meas_set_union neg_meas_subset sets.Diff sets.Int)
     show "A \<inter> (M2 \<inter> N) \<inter> (A \<inter> (M2 \<inter> sym_diff M2 N)) = {}" by auto
   qed
   also have "... = \<mu> (A \<inter> (M2 \<inter> (sym_diff M2 N)))"
   proof -
     have "A \<inter> (M2 \<inter> N) = {}" using assms hahn_space_decomp_def by auto
     thus ?thesis using signed_measure_empty[OF sgn_meas] by simp
   qed
   also have "... = 0" 
   proof (rule hahn_decomp_ess_unique[OF assms(1) assms(2)]) 
     show "A \<inter> (M2 \<inter> sym_diff M2 N) \<subseteq> sym_diff M1 P \<union> sym_diff M2 N" by auto
     show "A \<inter> (M2 \<inter> sym_diff M2 N) \<in> sets M" 
     proof -
       have "sym_diff M2 N \<in> sets M" using assms
         by (meson hahn_space_decomp_def sets.Diff sets.Un 
             signed_measure_space.neg_meas_setD1 signed_measure_space_axioms)
       hence "M2 \<inter> sym_diff M2 N \<in> sets M"
         by (meson assms(1) hahn_space_decomp_def neg_meas_setD1 sets.Int)
       thus ?thesis by (simp add: assms sets.Int)
     qed
   qed
   finally show ?thesis .
 qed
 
 lemma jordan_decomposition :
   shows "\<exists> m1 m2. jordan_decomp m1 m2" 
 proof -
   have "\<exists> M1 M2. hahn_space_decomp M1 M2" using hahn_decomposition 
     unfolding hahn_space_decomp_def by simp
   from this obtain M1 M2 where "hahn_space_decomp M1 M2" by auto 
   note Mprops = this
   define m1 where "m1 = (\<lambda>A. \<mu> (A \<inter> M1))"
   define m2 where "m2 = (\<lambda>A. -\<mu> (A \<inter> M2))"  
   show ?thesis unfolding jordan_decomp_def
   proof (intro exI allI impI conjI ballI)
     show "measure_space (space M) (sets M) (\<lambda>x. e2ennreal (m1 x))" 
       using pos_signed_to_meas_space Mprops m1_def 
       unfolding hahn_space_decomp_def by auto
   next
     show "measure_space (space M) (sets M) (\<lambda>x. e2ennreal (m2 x))" 
       using neg_signed_to_meas_space Mprops m2_def 
       unfolding hahn_space_decomp_def by auto
   next
     fix A
     assume "A\<in> sets M"
     thus "0 \<le> m1 A" unfolding m1_def using Mprops 
       unfolding hahn_space_decomp_def 
       by (meson inf_sup_ord(2) pos_meas_setD1 sets.Int 
           signed_measure_space.pos_measure_meas signed_measure_space_axioms)
   next
     fix A 
     assume "A\<in> sets M"
     thus "0 \<le> m2 A" unfolding m2_def using Mprops 
       unfolding hahn_space_decomp_def
       by (metis ereal_0_le_uminus_iff inf_sup_ord(2) neg_meas_self 
           neg_meas_setD1 neg_meas_subset sets.Int)
   next
     fix A
     assume "A \<in> sets M"
     have "\<mu> A = \<mu> ((A \<inter> M1) \<union> (A \<inter> M2))" using Mprops 
       unfolding hahn_space_decomp_def
       by (metis Int_Un_distrib \<open>A \<in> sets M\<close> sets.Int_space_eq2)
     also have "... = \<mu> (A \<inter> M1) + \<mu> (A \<inter> M2)" 
     proof (rule signed_measure_add)
       show "signed_measure M \<mu>" using sgn_meas .
       show "A \<inter> M1 \<in> sets M" using Mprops  \<open>A \<in> sets M\<close> 
         unfolding hahn_space_decomp_def 
         by (simp add: pos_meas_setD1 sets.Int) 
       show "A \<inter> M2 \<in> sets M" using Mprops \<open>A \<in> sets M\<close> 
         unfolding hahn_space_decomp_def
         by (simp add: neg_meas_setD1 sets.Int) 
       show "A \<inter> M1 \<inter> (A \<inter> M2) = {}" using Mprops 
         unfolding hahn_space_decomp_def by auto
     qed
     also have "... = m1 A - m2 A" using m1_def m2_def by simp
     finally show "\<mu> A = m1 A - m2 A" .    
   next
     fix P N A
     assume "hahn_space_decomp P N" and "A \<in> sets M" and "A \<subseteq> N" 
     note hn = this
     have "\<mu> (A \<inter> M1) = 0"
     proof (rule pos_inter_neg_0[OF _ hn])
       show "hahn_space_decomp M1 M2" using Mprops 
         unfolding hahn_space_decomp_def by simp
     qed
     thus "m1 A = 0" unfolding m1_def by simp
   next
     fix P N A
     assume "hahn_space_decomp P N" and "A \<in> sets M" and "A \<subseteq> P" 
     note hp = this
     have "\<mu> (A \<inter> M2) = 0"
     proof (rule neg_inter_pos_0[OF _ hp])
       show "hahn_space_decomp M1 M2" using Mprops 
         unfolding hahn_space_decomp_def by simp
     qed
     thus "m2 A = 0" unfolding m2_def by simp
   next
     show "(\<forall>E\<in>sets M. m1 E < \<infinity>) \<or> (\<forall>E\<in>sets M. m2 E < \<infinity>)"
     proof (cases "\<forall> E \<in> sets M. m1 E < \<infinity>")
       case True
       thus ?thesis by simp
     next
       case False
       have "\<forall> E \<in> sets M. m2 E < \<infinity>"
       proof
         fix E
         assume "E \<in> sets M"
         show "m2 E < \<infinity>"
         proof -
           have "(m2 E) = -\<mu> (E \<inter> M2)" using m2_def by simp        
           also have "... \<noteq> \<infinity>" using False sgn_meas inf_range
             by (metis ereal_less_PInfty ereal_uminus_uminus m1_def rangeI)
           finally have "m2 E \<noteq> \<infinity>" .
           thus ?thesis by (simp add: top.not_eq_extremum)
         qed
       qed
       thus ?thesis by simp
     qed
   qed
 qed
 
 lemma jordan_decomposition_unique :
   assumes "jordan_decomp m1 m2" 
     and "jordan_decomp n1 n2"
     and "A \<in> sets M"
   shows "m1 A = n1 A" "m2 A = n2 A"
 proof -
   have "\<exists> M1 M2. hahn_space_decomp M1 M2" using hahn_decomposition by simp
   from this obtain M1 M2 where "hahn_space_decomp M1 M2" by auto 
   note mprop = this
   have "m1 A = \<mu> (A \<inter> M1)" using assms jordan_decomp_pos_meas mprop by simp
   also have "... = n1 A" using assms jordan_decomp_pos_meas[of n1] mprop 
     by simp
   finally show "m1 A = n1 A" .
   have "m2 A = -\<mu> (A \<inter> M2)" using assms jordan_decomp_neg_meas mprop by simp
   also have "... = n2 A" using assms jordan_decomp_neg_meas[of n1] mprop 
     by simp
   finally show "m2 A = n2 A" .
 qed
 end
 end
 
diff --git a/thys/Lambda_Free_EPO/Chop.thy b/thys/Lambda_Free_EPO/Chop.thy
--- a/thys/Lambda_Free_EPO/Chop.thy
+++ b/thys/Lambda_Free_EPO/Chop.thy
@@ -1,342 +1,343 @@
 (*  Title:       The Chop Operation on Lambda-Free Higher-Order Terms
     Author:      Alexander Bentkamp <a.bentkamp at vu.nl>, 2018
     Maintainer:  Alexander Bentkamp <a.bentkamp at vu.nl>
 *)
 
 section \<open>The Chop Operation on Lambda-Free Higher-Order Terms\<close>
 
 theory Chop
 imports Embeddings
 begin
 
 definition chop :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm" where
   "chop t = apps (hd (args t)) (tl (args t))"
 
 subsection \<open>Basic properties\<close>
 
 lemma chop_App_Hd: "is_Hd s \<Longrightarrow> chop (App s t) = t" 
   unfolding chop_def args.simps 
   using args_Nil_iff_is_Hd by force
 
 lemma chop_apps: "is_App t \<Longrightarrow> chop (apps t ts) = apps (chop t) ts" 
   unfolding chop_def by (simp add: args_Nil_iff_is_Hd)
 
 lemma vars_chop: "is_App t \<Longrightarrow> vars (chop t) \<union> vars_hd (head t) = vars t" 
   by (induct rule:tm_induct_apps; metis (no_types, lifting) chop_def UN_insert Un_commute list.exhaust_sel list.simps(15)
       args_Nil_iff_is_Hd tm.simps(17) tm_exhaust_apps_sel vars_apps)
 
 lemma ground_chop: "is_App t \<Longrightarrow> ground t \<Longrightarrow> ground (chop t)" 
   using vars_chop by auto
 
 lemma hsize_chop: "is_App t \<Longrightarrow> (Suc (hsize (chop t))) = hsize t"
   unfolding hsize_args[of t, symmetric] chop_def hsize_apps
   by (metis Nil_is_map_conv args_Nil_iff_is_Hd list.exhaust_sel list.map_sel(1) map_tl plus_1_eq_Suc sum_list.Cons)
 
 lemma hsize_chop_lt: "is_App t \<Longrightarrow> hsize (chop t) < hsize t"
   by (simp add: Suc_le_lessD less_or_eq_imp_le hsize_chop)
 
 lemma chop_fun:
   assumes "is_App t" "is_App (fun t)" 
   shows "App (chop (fun t)) (arg t) = chop t"  
 proof -
   have "args (fun t) \<noteq> []"
     using assms(2) args_Nil_iff_is_Hd by blast
   then show ?thesis 
     unfolding chop_def
     using assms(1) by (metis (no_types) App_apps args.simps(2) hd_append2 tl_append2 tm.collapse(2))
 qed
 
 subsection \<open>Chop and the Embedding Relation\<close>
 
 lemma emb_step_chop: "is_App t \<Longrightarrow> t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b chop t" 
 proof (induct "num_args t - 1" arbitrary:t)
   case 0
   have nil: "num_args t = 0 \<Longrightarrow> t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b chop t" unfolding chop_def using 0 args_Nil_iff_is_Hd by force
   have single: "\<And>a. args t = [a] \<Longrightarrow> t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b chop t" unfolding chop_def 
     by (metis "0.prems" apps.simps(1) args.elims args_Nil_iff_is_Hd emb_step_arg last.simps last_snoc list.sel(1) list.sel(3) tm.sel(6))
   then show ?case using nil single
     by (metis "0.hyps" length_0_conv length_tl list.exhaust_sel)
 next
   case (Suc x)
   have 1:"apps (Hd (head t)) (butlast (args t)) \<rightarrow>\<^sub>e\<^sub>m\<^sub>b chop (apps (Hd (head t)) (butlast (args t)))"
     using Suc(1)[of "apps (Hd (head t)) (butlast (args t))"]
     by (metis Suc.hyps(2) Suc_eq_plus1 add_diff_cancel_right' args_Nil_iff_is_Hd length_butlast list.size(3) nat.distinct(1) tm_exhaust_apps_sel tm_inject_apps)
   have 2:"App (apps (Hd (head t)) (butlast (args t))) (last (args t)) = t"
     by (simp add: App_apps Suc.prems args_Nil_iff_is_Hd)
   have 3:"App (chop (apps (Hd (head t)) (butlast (args t)))) (last (args t)) = chop t"
   proof -
     have f1: "hd (args t) = hd (butlast (args t))"
       by (metis Suc.hyps(2) Suc.prems append_butlast_last_id args_Nil_iff_is_Hd hd_append2 length_0_conv length_butlast nat.simps(3))
     have "tl (args t) = tl (butlast (args t)) @ [last (args t)]"
       by (metis (no_types) Suc.hyps(2) Suc.prems append_butlast_last_id args_Nil_iff_is_Hd length_0_conv length_butlast nat.simps(3) tl_append2)
     then show ?thesis
       using f1 chop_def 
       by (metis App_apps append_Nil args.simps(1) args_apps)
   qed
   then show ?case using 1 2 3 by (metis context_left)
 qed 
 
 lemma chop_emb_step_at:
   assumes "is_App t"
   shows "chop t = emb_step_at (replicate (num_args (fun t)) Left) Right t"
 using assms proof (induct "num_args (fun t)" arbitrary: t)
   case 0
   then have rep_Nil:"replicate (num_args (fun t)) dir.Left = []" 
     by simp 
   then show ?case unfolding rep_Nil 
     by (metis "0.hyps" "0.prems" emb_step_at_right append_Nil apps.simps(1) args.simps(2) chop_def length_0_conv list.sel(1) list.sel(3) tm.collapse(2)) 
 next
   case (Suc n)
   then show ?case using Suc.hyps(1)[of "fun t"]
     using emb_step_at_left_context args.elims args_Nil_iff_is_Hd chop_fun butlast_snoc diff_Suc_1 length_0_conv length_butlast nat.distinct(1) replicate_Suc tm.collapse(2) tm.sel(4)
     by metis
 qed
 
 lemma emb_step_at_chop:
   assumes emb_step_at: "emb_step_at p Right t = s"
     and pos:"position_of t (p @ [Right])"
     and all_Left: "list_all (\<lambda>x. x = Left) p"
   shows "chop t = s \<or> chop t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b s"
 proof -
   have "is_App t" 
     by (metis emb_step_at_if_position emb_step_at_is_App emb_step_equiv pos)
   have p_replicate: "replicate (length p) Left = p" using replicate_length_same[of p Left]
     by (simp add: Ball_set all_Left)
   show ?thesis
   proof (cases "Suc (length p) = num_args t")
     case True
     then have "p = replicate (num_args (fun t)) Left" using p_replicate 
       by (metis Suc_inject \<open>is_App t\<close> args.elims args_Nil_iff_is_Hd length_append_singleton tm.sel(4))
     then have "chop t = s" unfolding chop_emb_step_at[OF \<open>is_App t\<close>] 
       using pos emb_step_at by blast
     then show ?thesis by blast
   next
     case False
     then have "Suc (length p) < num_args t"
       using pos emb_step_at \<open>is_App t\<close> \<open>list_all (\<lambda>x. x = dir.Left) p\<close>
     proof (induct p arbitrary:t s)
       case Nil
       then show ?case 
         by (metis Suc_lessI args_Nil_iff_is_Hd length_greater_0_conv list.size(3))
     next
       case (Cons a p)
       have "a = Left" 
         using Cons.prems(5) by auto
       have 1:"Suc (length p) \<noteq> num_args (fun t)"  
         by (metis (no_types, lifting) Cons.prems(1) Cons.prems(4) args.elims args_Nil_iff_is_Hd length_Cons length_append_singleton tm.sel(4))
       have 2:"position_of (fun t) (p @ [Right])"   using \<open>position_of t ((a # p) @ [Right])\<close> \<open>is_App t\<close> 
         by (metis (full_types) Cons.prems(5) position_of_left append_Cons list_all_simps(1) tm.collapse(2))
       have 3: "emb_step_at p dir.Right (fun t) = emb_step_at p dir.Right (fun t)" 
         using emb_step_at_left_context[of p Right "fun t" "arg t"] by blast
       have "Suc (length p) < num_args (fun t)" using Cons.hyps[OF 1 2 3] 
         by (metis "2" Cons.prems(5) Nil_is_append_conv list_all_simps(1) not_Cons_self2 position_of.elims(2) tm.discI(2))
       then show ?case 
         by (metis Cons.prems(4) Suc_less_eq2 args.simps(2) length_Cons length_append_singleton tm.collapse(2))
     qed      
     define q where "q = replicate (num_args (fun t) - Suc (length p)) dir.Left"
     have "chop t = emb_step_at (p @ [Left] @ q) dir.Right t"
     proof -
       have "length p + (num_args (fun t) - length p) = num_args (fun t)" 
         using \<open>Suc (length p) < num_args t\<close>
         by (metis Suc_less_eq2 \<open>is_App t\<close> args.simps(2) diff_Suc_1 leD length_butlast nat_le_linear 
             ordered_cancel_comm_monoid_diff_class.add_diff_inverse snoc_eq_iff_butlast tm.collapse(2))
       then have 1:"replicate (num_args (fun t)) dir.Left = p @ replicate (num_args (fun t) - length p) dir.Left" 
         by (metis p_replicate replicate_add)
       have "0 < num_args (fun t) - length p"
         by (metis (no_types) False \<open>is_App t\<close> \<open>length p + (num_args (fun t) - length p) = num_args (fun t)\<close> args.simps(2) length_append_singleton less_Suc_eq less_add_Suc1 tm.collapse(2) zero_less_diff)
       then have "replicate (num_args (fun t) - length p) dir.Left = [Left] @ q" unfolding q_def
         by (metis (no_types) Cons_replicate_eq Nat.diff_cancel Suc_eq_plus1 \<open>length p + (num_args (fun t) - length p) = num_args (fun t)\<close> append_Cons self_append_conv2)
       then show ?thesis using chop_emb_step_at
         using \<open>is_App t\<close> 1
         by (simp add: chop_emb_step_at)
     qed
     then have "chop t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b s"
       using pos merge_emb_step_at[of p Right q Right t] 
       by (metis emb_step_at_if_position opp_simps(1) emb_step_at pos_emb_step_at_opp)
     then show ?thesis by blast
   qed
 qed
 
 lemma emb_step_at_remove_arg:
   assumes emb_step_at: "emb_step_at p Left t = s"
     and pos:"position_of t (p @ [Left])"
     and all_Left: "list_all (\<lambda>x. x = Left) p"
   shows "let i = num_args t - Suc (length p) in 
   head t = head s \<and> i < num_args t \<and> args s = take i (args t) @ drop (Suc i) (args t)"
 proof -
   have "is_App t" 
     by (metis emb_step_at_if_position emb_step_at_is_App emb_step_equiv pos)
   have C1: "head t = head s" 
     using all_Left emb_step_at pos proof (induct p arbitrary:s t)
     case Nil
     then have "s = emb_step_at [] dir.Left (App (fun t) (arg t))"
       by (metis position_of.elims(2) snoc_eq_iff_butlast tm.collapse(2) tm.discI(2))
     then have "s = fun t" by simp
     then show ?case by simp
   next
     case (Cons a p)
     then have "a = Left" by simp
     then have "head (emb_step_at p Left (fun t)) = head t" 
       by (metis Cons.hyps Cons.prems(1) head_fun list.pred_inject(2) position_if_emb_step_at)
     then show ?case using emb_step_at_left_context[of p a "fun t" "arg t"]
       by (metis Cons.prems(2) \<open>a = Left\<close> emb_step_at_is_App head_App tm.collapse(2)) 
   qed
 
   let ?i = "num_args t - Suc (length p)"
 
   have C2:"?i < num_args t" 
     by (simp add: \<open>is_App t\<close> args_Nil_iff_is_Hd)
 
   have C3:"args s = take ?i (args t) @ drop (Suc ?i) (args t)"
     using all_Left pos emb_step_at \<open>is_App t\<close> proof (induct p arbitrary:s t)
     case Nil
     then show ?case using emb_step_at_left[of "fun t" "arg t"]
       by (simp, metis One_nat_def args.simps(2) butlast_conv_take butlast_snoc tm.collapse(2))
   next
     case (Cons a p)
     have "position_of (fun t) (p @ [Left])"
       by (metis (full_types) Cons.prems(1) Cons.prems(2) Cons.prems(4) position_of_left 
           append_Cons list.pred_inject(2) tm.collapse(2))
     then have 0:"args (emb_step_at p Left (fun t))
                    = take (num_args (fun t) - Suc (length p)) (args (fun t)) 
                    @ drop (Suc (num_args (fun t) - Suc (length p))) (args (fun t))"
       using Cons.hyps[of "fun t"] by (metis Cons.prems(1) append_Nil args_Nil_iff_is_Hd drop_Nil 
           emb_step_at_is_App list.size(3) list_all_simps(1) take_0 zero_diff)
     have 1:"s = App (emb_step_at p Left (fun t)) (arg t)" using emb_step_at_left_context[of p Left "fun t" "arg t"] 
       using Cons.prems by auto
     define k where k_def:"k = (num_args (fun t) - Suc (length p))"
     have 2:"take k (args (fun t)) = take (num_args t - Suc (length (a # p))) (args t)"
-      by (smt k_def Cons.prems(4) args.elims args_Nil_iff_is_Hd butlast_snoc diff_Suc_eq_diff_pred 
-          diff_Suc_less length_Cons length_butlast length_greater_0_conv take_butlast tm.sel(4))
+      by (metis (no_types, lifting) Cons.prems(4) args.elims args_Nil_iff_is_Hd butlast_snoc
+          diff_Suc_eq_diff_pred diff_less k_def length_Cons length_butlast length_greater_0_conv
+          take_butlast tm.sel(4) zero_less_Suc)
     have k_def': "k = num_args t - Suc (Suc (length p))" using k_def
       by (metis args.simps(2) diff_Suc_Suc length_append_singleton local.Cons(5) tm.collapse(2))
     have 3:"args (fun t) @ [arg t] = args t"
       by (metis Cons.prems(4) args.simps(2) tm.collapse(2))
     have "num_args t > 1" using \<open>position_of t ((a # p) @ [Left])\<close> 
       by (metis "3" \<open>position_of (fun t) (p @ [dir.Left])\<close> args_Nil_iff_is_Hd butlast_snoc emb_step.simps emb_step_at_if_position length_butlast length_greater_0_conv tm.discI(2) zero_less_diff)
     then have "Suc k<num_args t" unfolding k_def'
       using \<open>1 < num_args t\<close> by linarith
     have "\<forall>k< num_args t. drop k (args (fun t)) @ [arg t] = drop k (args t)"
       by (metis (no_types, lifting) \<open>args (fun t) @ [arg t] = args t\<close> drop_butlast drop_eq_Nil last_drop leD snoc_eq_iff_butlast)
     then show ?case using 0 1 2 3 k_def'
       using \<open>Suc k < num_args t\<close> k_def by auto
   qed
   show ?thesis using C1 C2 C3 by simp
 qed
 
 lemma emb_step_cases [consumes 1, case_names chop extended_chop remove_arg under_arg]:
   assumes emb:"t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b s"
     and chop:"chop t = s \<Longrightarrow> P"
     and extended_chop:"chop t \<rightarrow>\<^sub>e\<^sub>m\<^sub>b s \<Longrightarrow> P"
     and remove_arg:"\<And>i. head t = head s \<Longrightarrow> i<num_args t \<Longrightarrow> args s = take i (args t) @ drop (Suc i) (args t) \<Longrightarrow> P"
     and under_arg:"\<And>i. head t = head s \<Longrightarrow> num_args t = num_args s \<Longrightarrow> args t ! i \<rightarrow>\<^sub>e\<^sub>m\<^sub>b args s ! i \<Longrightarrow>
          (\<And>j. j<num_args t \<Longrightarrow> i \<noteq> j \<Longrightarrow> args t ! j = args s ! j) \<Longrightarrow> P"
   shows P
 proof -
   obtain p d where pd_def:"emb_step_at p d t = s" "position_of t (p @ [d])"
     using emb emb_step_equiv' position_if_emb_step_at by metis
   have "is_App t"
     by (metis emb emb_step_at_is_App emb_step_equiv)
   show ?thesis 
   proof (cases "list_all (\<lambda>x. x = Left) p")
     case True
     show ?thesis 
     proof (cases d)
       case Left
       then show P using emb_step_at_remove_arg 
         by (metis True pd_def(1) pd_def(2) remove_arg)
     next
       case Right
       then show P 
         using True chop emb_step_at_chop extended_chop pd_def(1) pd_def(2) by blast
     qed
   next
     case False
     have 1:"num_args t = num_args s" using emb_step_under_args_num_args
       by (metis False pd_def(1))
     have 2:"head t = head s" using emb_step_under_args_head
       by (metis False pd_def(1))
     show ?thesis using 1 2 under_arg emb_step_under_args_emb_step
       by (metis False pd_def(1) pd_def(2))
   qed
 qed
 
 lemma chop_position_of:
   assumes "is_App s"
   shows "position_of s (replicate (num_args (fun s)) dir.Left @ [Right])"
   by (metis Suc_n_not_le_n assms chop_emb_step_at lessI less_imp_le_nat position_if_emb_step_at hsize_chop)
 
 subsection \<open>Chop and Substitutions\<close>
 
 (* TODO: move *)
 lemma Suc_num_args: "is_App t \<Longrightarrow> Suc (num_args (fun t)) = num_args t" 
   by (metis args.simps(2) length_append_singleton tm.collapse(2))
 
 (* TODO: move *)
 lemma fun_subst: "is_App s \<Longrightarrow> subst \<rho> (fun s) = fun (subst \<rho> s)"
   by (metis subst.simps(2) tm.collapse(2) tm.sel(4))
 
 (* TODO: move *)
 lemma args_subst_Hd:
   assumes "is_Hd (subst \<rho> (Hd (head s)))"
   shows  "args (subst \<rho> s) = map (subst \<rho>) (args s)"
   using assms 
   by (metis append_Nil args_Nil_iff_is_Hd args_apps subst_apps tm_exhaust_apps_sel)
 
 lemma chop_subst_emb0:
   assumes "is_App s"
   assumes "chop (subst \<rho> s) \<noteq> subst \<rho> (chop s)"
   shows "emb_step_at (replicate (num_args (fun s)) Left) Right (chop (subst \<rho> s)) = subst \<rho> (chop s)"
 proof -
   have "is_App (subst \<rho> s)"
     by (metis assms(1) subst.simps(2) tm.collapse(2) tm.disc(2))
   have 1:"subst \<rho> (chop s) = emb_step_at (replicate (num_args (fun s)) dir.Left) dir.Right (subst \<rho>  s)"
     using chop_emb_step_at[OF assms(1)] using emb_step_at_subst chop_position_of[OF \<open>is_App s\<close>] 
     by (metis)
   have "num_args (fun s) \<le> num_args (fun (subst \<rho> s))" 
     using fun_subst[OF \<open>is_App s\<close>] 
     by (metis args_subst leI length_append length_map not_add_less2)
   then have "num_args (fun s) < num_args (fun (subst \<rho> s))" 
     using assms(2) "1" \<open>is_App (subst \<rho> s)\<close> chop_emb_step_at le_imp_less_or_eq 
     by fastforce
   then have "num_args s \<le> num_args (fun (subst \<rho> s))" 
     using Suc_num_args[OF \<open>is_App s\<close>] by linarith
   then have  "replicate (num_args (fun s)) dir.Left @
         [opp dir.Right] @ replicate (num_args (fun (subst \<rho> s)) - num_args s) dir.Left =
         replicate (num_args (fun (subst \<rho> s))) dir.Left" 
     unfolding append.simps opp_simps replicate_Suc[symmetric] replicate_add[symmetric]
     using Suc_num_args[OF \<open>is_App s\<close>]
     by (metis add_Suc_shift ordered_cancel_comm_monoid_diff_class.add_diff_inverse)
   then show ?thesis unfolding 1
     unfolding  chop_emb_step_at[OF \<open>is_App (subst \<rho> s)\<close>]
     by (metis merge_emb_step_at)
 qed
 
 lemma chop_subst_emb:
   assumes "is_App s"
   shows "chop (subst \<rho> s) \<unrhd>\<^sub>e\<^sub>m\<^sub>b subst \<rho> (chop s)"
   using chop_subst_emb0
   by (metis assms emb.refl emb_step_equiv emb_step_is_emb)
 
 lemma chop_subst_Hd:
   assumes "is_App s"
   assumes "is_Hd (subst \<rho> (Hd (head s)))"
   shows "chop (subst \<rho> s) = subst \<rho> (chop s)" 
 proof -
   have "is_App (subst \<rho> s)"
     by (metis assms(1) subst.simps(2) tm.collapse(2) tm.disc(2))
   have "num_args (fun s) = num_args (fun (subst \<rho> s))" unfolding fun_subst[OF \<open>is_App s\<close>,symmetric]
     using args_subst_Hd using assms(2) by auto
   then show ?thesis
     unfolding chop_emb_step_at[OF assms(1)] chop_emb_step_at[OF \<open>is_App (subst \<rho> s)\<close>]
     using emb_step_at_subst[OF chop_position_of[OF \<open>is_App s\<close>]]
     by simp
 qed
 
 lemma chop_subst_Sym:
   assumes "is_App s"
   assumes "is_Sym (head s)"
   shows "chop (subst \<rho> s) = subst \<rho> (chop s)" 
   by (metis assms(1) assms(2) chop_subst_Hd ground_imp_subst_iden hd.collapse(2) hd.simps(18) tm.disc(1) tm.simps(17))
 
 end
\ No newline at end of file
diff --git a/thys/Lifting_the_Exponent/LTE.thy b/thys/Lifting_the_Exponent/LTE.thy
--- a/thys/Lifting_the_Exponent/LTE.thy
+++ b/thys/Lifting_the_Exponent/LTE.thy
@@ -1,418 +1,418 @@
 theory LTE
   imports
     "HOL-Number_Theory.Number_Theory"
 begin
 
 section "Library additions"
 
 lemma cong_sum_mono_neutral_right:
   assumes "finite T"
   assumes "S \<subseteq> T"
   assumes zeros: "\<forall>i \<in> T - S. [g i = 0] (mod n)"
   shows "[sum g T = sum g S] (mod n)"
 proof -
   have "[sum g T = (\<Sum>x\<in>T. if x \<in> S then g x else 0)] (mod n)"
     using zeros by (auto intro: cong_sum)
   also have "(\<Sum>x\<in>T. if x \<in> S then g x else 0) = (\<Sum>x\<in>S. if x \<in> S then g x else 0)"
     by (intro sum.mono_neutral_right; fact?; auto)
   also have "... = sum g S"
     by (auto intro: sum.cong)
   finally show ?thesis.
 qed
 
 lemma power_odd_inj:
   fixes a b :: "'a::linordered_idom"
   assumes "odd k" and "a^k = b^k"
   shows "a = b"
 proof (cases "a \<ge> 0")
   case True
   then have "b \<ge> 0"
     using assms zero_le_odd_power by metis
   moreover from \<open>odd k\<close> have "k > 0" by presburger
   show ?thesis
     by (rule power_eq_imp_eq_base; fact)
 next
   case False
   then have "b < 0"
     using assms power_less_zero_eq not_less by metis 
   from \<open>a^k = b^k\<close> have "(-a)^k = (-b)^k"
     using \<open>odd k\<close> power_minus_odd by simp
   moreover have "-a \<ge> 0" and "-b \<ge> 0"
     using \<open>\<not> a \<ge> 0\<close> and \<open>b < 0\<close> by auto
   moreover from \<open>odd k\<close> have "k > 0" by presburger
   ultimately have "-a = -b" by (rule power_eq_imp_eq_base)
   then show ?thesis by simp
 qed
 
 lemma power_eq_abs:
   fixes a b :: "'a::linordered_idom"
   assumes "a^k = b^k" and "k > 0"
   shows "\<bar>a\<bar> = \<bar>b\<bar>"
 proof -
   from \<open>a^k = b^k\<close> have "\<bar>a\<bar>^k = \<bar>b\<bar>^k"
     using power_abs by metis
   show "\<bar>a\<bar> = \<bar>b\<bar>"
     by (rule power_eq_imp_eq_base; fact?; auto)
 qed
 
 lemma cong_scale:
   "k \<noteq> 0 \<Longrightarrow> [a = b] (mod c) \<longleftrightarrow> [k*a = k*b] (mod k*c)"
   unfolding cong_def by auto
 
 lemma odd_square_mod_4:
   fixes x :: int
   assumes "odd x"
   shows "[x^2 = 1] (mod 4)"
 proof -
   have "x^2 - 1 = (x - 1) * (x + 1)" 
     by (simp add: ring_distribs power2_eq_square)
   moreover from \<open>odd x\<close> have "2 dvd x - 1" and "2 dvd x + 1"
     by auto
   ultimately have "4 dvd x^2 - 1"
     by fastforce
   thus ?thesis
     by (simp add: cong_iff_dvd_diff)
 qed
 
 section \<open>The \<open>p > 2\<close> case\<close>
 
 context
   fixes x y :: int and p :: nat
   assumes "prime p"
   assumes "p dvd x - y"
   assumes "\<not>p dvd x"   "\<not>p dvd y"
 begin
 
 lemma decompose_mod_p:
   "[(\<Sum>i<n. y^(n - Suc i) * x^i) = n*x^(n-1)] (mod p)"
 proof -
   {
     fix i
     assume "i < n"
     from \<open>p dvd x - y\<close> have "[x = y] (mod p)"
       by (simp add: cong_iff_dvd_diff)
     hence "[y^(n - Suc i) * x^i = x^(n - Suc i) * x^i] (mod p)"
       by (intro cong_scalar_right cong_pow; rule cong_sym)
     also have "x^(n - Suc i) * x^i = x^(n - 1)"
       using \<open>i < n\<close> by (simp flip: power_add)
     finally have "[y^(n - Suc i) * x^i = x^(n - 1)] (mod p)"
       by auto
   }
   hence "[(\<Sum>i<n. y^(n - Suc i) * x^i) = (\<Sum>i<n. x^(n-1))] (mod p)"
     by (intro cong_sum; auto)
   thus "[(\<Sum>i<n. y^(n - Suc i) * x^i) = n * x^(n-1)] (mod p)"
     by simp
 qed
 
 text \<open>Lemma 1:\<close>
 
 lemma multiplicity_diff_pow_coprime:
   assumes "coprime p n"
   shows "multiplicity p (x^n - y^n) = multiplicity p (x - y)"
 proof -
   have factor: "x^n - y^n = (\<Sum>i<n. y^(n - Suc i) * x^i) * (x - y)"
     by (simp add: power_diff_sumr2)
   moreover have "\<not> p dvd (\<Sum>i<n. y^(n - Suc i) * x^i)"
   proof
     assume "p dvd (\<Sum>i<n. y^(n - Suc i) * x^i)"
     with decompose_mod_p have "p dvd n * x^(n-1)"
       using cong_dvd_iff by blast
     with \<open>prime p\<close> have "p dvd n \<or> p dvd x^(n-1)"
       by (simp add: prime_dvd_mult_eq_int)
     moreover from \<open>coprime p n\<close> and \<open>prime p\<close> have "\<not>p dvd n"
       using coprime_absorb_right not_prime_unit by auto
     ultimately have "p dvd x^(n-1)"
       by simp
     hence "p dvd x"
       using \<open>prime p\<close> prime_dvd_power_int prime_nat_int_transfer by blast 
     with \<open>\<not>p dvd x\<close> show False by simp
   qed
   ultimately show "multiplicity p (x^n - y^n) = multiplicity p (x - y)"
     using \<open>prime p\<close>
     by (auto intro: multiplicity_prime_elem_times_other)
 qed  
 
 text \<open>The inductive step:\<close>
 
 lemma multiplicity_diff_self_pow:
   assumes "p > 2" and "x \<noteq> y"
   shows "multiplicity p (x^p - y^p) = Suc (multiplicity p (x - y))"
 proof -
   have *: "multiplicity p (\<Sum>i<p. y^(p - Suc i) * x^i) = 1"
   proof (rule multiplicity_eqI)
     have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p * x^(p-1)] (mod p)"
       by (rule decompose_mod_p)
     also have "[p * x^(p-1) = 0] (mod p)"
       by (simp add: cong_mult_self_left)
     finally show "(int p)^1 dvd (\<Sum>i<p. y^(p - Suc i) * x^i)"
       by (simp add: cong_0_iff)
 
     from \<open>p dvd x - y\<close> obtain k::int where kp: "x = y + k * p"
       by (metis add.commute diff_add_cancel dvd_def mult.commute)
 
     have "[y^(p - Suc t) * x^t = y^(p-1) + t*k*p*y^(p-2)] (mod p^2)" if "t < p" for t
     proof (cases "t = 0")
       case False
       have "y^(p - Suc t) * x^t = y^(p - Suc t) * (y + k*p)^t"
         unfolding kp..
       also have "... = y^(p - Suc t) * (\<Sum>i\<le>t. (t choose i) * (k*p)^i * y^(t-i))"
         by (simp flip: binomial_ring add: add.commute)
       also have "[... = y^(p - Suc t) * (\<Sum>i\<le>1. (t choose i) * (k*p)^i * y^(t-i))] (mod p^2)"
         \<comment> \<open>discard \<open>i > 1\<close>\<close>
       proof (intro cong_scalar_left cong_sum_mono_neutral_right; rule)
         fix i
         assume "i \<in> {..t} - {..1}"
         then have "i \<ge> 2" by simp
         then obtain i' where "i = i' + 2"
           using add.commute le_Suc_ex by blast
         hence "(k*p)^i = (k*p)^i' * k^2 * p^2"
           by (simp add: ac_simps power2_eq_square)
         hence "[(k*p)^i = 0] (mod p^2)"
           by (simp add: cong_mult_self_right)
         thus "[(t choose i) * (k*p)^i * y^(t-i) = 0] (mod p^2)"
           by (simp add: cong_0_iff)
       qed (use \<open>t \<noteq> 0\<close> in auto)
       also have "(\<Sum>i\<le>1. (t choose i) * (k*p)^i * y^(t-i)) = y^t + t*k*p*y^(t-1)"
         by simp
       also have "y^(p - Suc t) * ... = y^(p-1) + t*k*p*y^(p-2)"
         using \<open>t < p\<close> \<open>t \<noteq> 0\<close> by (auto simp add: algebra_simps numeral_eq_Suc simp flip: power_add)
       finally show ?thesis.
     qed simp
 
     hence "[(\<Sum>t<p. y^(p - Suc t) * x^t) = (\<Sum>t<p. y^(p-1) + t*k*p*y^(p-2))] (mod p^2)"
       by (auto intro: cong_sum)
     also have "(\<Sum>t<p. y^(p-1) + t*k*p*y^(p-2)) = p*y^(p-1) + (\<Sum>t<p. t) * k*p*y^(p-2)"
       by (simp add: sum.distrib sum_distrib_right)
     also have "(\<Sum>t<p. t) = p*(p - 1) div 2"
       by (simp add: Sum_Ico_nat lessThan_atLeast0)
     finally have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p*y^(p-1) + (p*(p - 1) div 2) * k*p*y^(p-2)] (mod p^2)".
     moreover have "[(p*(p - 1) div 2) * k*p*y^(p-2) = 0] (mod p^2)"
     proof -
       have "[(p * (p - 1) div 2) * p = 0] (mod p^2)"
       proof -
         from \<open>p > 2\<close> and \<open>prime p\<close> have "odd p"
           using prime_odd_nat by blast
         thus ?thesis
           by (metis (no_types, lifting) cong_0_iff div_mult_swap dvd_times_left_cancel_iff
               dvd_triv_left le_0_eq linorder_not_less mult.commute odd_pos odd_two_times_div_two_nat
               one_add_one power_add power_one_right)
       qed
       hence "[int ((p*(p - 1) div 2) * p)*k*y^(p-2) = 0] (mod p^2)"
         unfolding cong_0_iff using int_dvd_int_iff by fastforce
       thus ?thesis
         by (simp add: ac_simps)
     qed
     ultimately have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p*y^(p-1)] (mod p^2)"
-      by (smt cong_add cong_iff_dvd_diff)
+      using cong_add_lcancel_0 cong_trans by blast
     moreover have "\<not> p^2 dvd p*y^(p-1)"
       using \<open>p > 2\<close> \<open>prime p\<close> \<open>\<not> p dvd y\<close> by (simp add: power2_eq_square prime_dvd_power_int_iff)
     ultimately show "\<not> int p^(Suc 1) dvd (\<Sum>t<p. y^(p - Suc t) * x^t)"
       by (metis (no_types, lifting) Suc_1 of_nat_power cong_dvd_iff)
   qed
   moreover have "multiplicity p (x^p - y^p) = multiplicity p (x - y) + multiplicity p (\<Sum>i<p. y^(p - Suc i) * x^i)"
     apply (unfold power_diff_sumr2, intro prime_elem_multiplicity_mult_distrib)
     using \<open>prime p\<close> \<open>x \<noteq> y\<close> multiplicity_zero * by auto
   ultimately show ?thesis by simp
 qed
 
 text \<open>Theorem 1:\<close>
 
 theorem multiplicity_diff_pow:
   assumes "p > 2" and "x \<noteq> y" and "n > 0"
   shows "multiplicity p (x^n - y^n) = multiplicity p (x - y) + multiplicity p n"
 proof -
   obtain k where n: "n = p^multiplicity p n * k" and "\<not> p dvd k"
     using \<open>n > 0\<close> \<open>prime p\<close>
     by (metis neq0_conv not_prime_unit multiplicity_decompose')
   have "multiplicity p (x^(p^a * k) - y^(p^a * k)) = multiplicity p (x - y) + a" for a
   proof (induction a)
     case 0
     from \<open>\<not> p dvd k\<close> have "coprime p k"
       using \<open>prime p\<close> by (intro prime_imp_coprime)
     thus ?case
       by (simp add: multiplicity_diff_pow_coprime)
   next
     case (Suc a)
     let ?x' = "x^(p^a*k)" and ?y' = "y^(p^a*k)"
     have "\<not> p dvd ?x'" and "\<not> p dvd ?y'"
       using \<open>\<not> p dvd x\<close>  \<open>\<not> p dvd y\<close> and \<open>prime p\<close>
       by (meson prime_dvd_power prime_nat_int_transfer)+
     moreover have "p dvd ?x' - ?y'"
       using \<open>p dvd x - y\<close> by (simp add: power_diff_sumr2)
     moreover have "?x' \<noteq> ?y'"
     proof
       assume "?x' = ?y'"
       moreover have "0 < p^a * k"
         using \<open>prime p\<close> \<open>n > 0\<close> n
         by (metis gr0I mult_is_0 power_not_zero prime_gt_0_nat)
       ultimately have "\<bar>x\<bar> = \<bar>y\<bar>"
         by (intro power_eq_abs)
       with \<open>x \<noteq> y\<close> have "x = -y"
         using abs_eq_iff by simp
       with \<open>p dvd x - y\<close> have "p dvd 2*x"
         by simp
       with \<open>prime p\<close> have "p dvd 2 \<or> p dvd x"
         by (metis int_dvd_int_iff of_nat_numeral prime_dvd_mult_iff prime_nat_int_transfer)
       with \<open>p > 2\<close> have "p dvd x"
         by auto
       with \<open>\<not> p dvd x\<close> show False..
     qed
     moreover have "p^Suc a * k = p^a * k * p"
       by (simp add: ac_simps)
     ultimately show ?case
       using LTE.multiplicity_diff_self_pow[where x="?x'" and y="?y'", OF \<open>prime p\<close>] \<open>p > 2\<close>
         and Suc.IH
       by (metis add_Suc_right power_mult)
   qed
   with n show ?thesis by metis
 qed
 
 end
 
 text \<open>Theorem 2:\<close>
 
 corollary multiplicity_add_pow:
   fixes x y :: int and p n :: nat
   assumes "odd n"
     and "prime p" and "p > 2"
     and "p dvd x + y" and "\<not> p dvd x"  "\<not> p dvd y"
     and "x \<noteq> -y"
   shows "multiplicity p (x^n + y^n) = multiplicity p (x + y) + multiplicity p n"
 proof -
   have [simp]: "(-y)^n = -(y^n)"
     using \<open>odd n\<close> by (rule power_minus_odd)
   moreover have "n > 0"
     using \<open>odd n\<close> by presburger
   with assms show ?thesis
     using multiplicity_diff_pow[where x=x and y="-y" and n=n]
     by simp
 qed
 
 section \<open>The \<open>p = 2\<close> case\<close>
 
 text \<open>Theorem 3:\<close>
 
 theorem multiplicity_2_diff_pow_4div:
   fixes x y :: int
   assumes "odd x"  "odd y" and "4 dvd x - y" and "n > 0"  "x \<noteq> y"
   shows "multiplicity 2 (x^n - y^n) = multiplicity 2 (x - y) + multiplicity 2 n"
 proof -
   have "prime (2::nat)" by simp
   then obtain k where n: "n = 2^multiplicity 2 n * k" and "\<not> 2 dvd k"
     using \<open>n > 0\<close>
     by (metis neq0_conv not_prime_unit multiplicity_decompose')
 
   have pow2: "multiplicity 2 (x^(2^k) - y^(2^k)) = multiplicity 2 (x - y) + k" for k
   proof (induction k)
     case (Suc k)
     have "x^(2^Suc k) - y^(2^Suc k) = (x^2^k)^2 - (y^2^k)^2"
       by (simp flip: power_mult algebra_simps)
     also have "... = (x^2^k - y^2^k)*(x^2^k + y^2^k)"
       by (simp add: power2_eq_square algebra_simps)
     finally have factor: "x^(2^Suc k) - y^(2^Suc k) = (x^2^k - y^2^k)*(x^2^k + y^2^k)".
     moreover have m_plus: "multiplicity 2 (x^2^k + y^2^k) = 1"
     proof (rule multiplicity_eqI)
       show "2^1 dvd x^2^k + y^2^k"
         using \<open>odd x\<close> and \<open>odd y\<close> by simp
 
       have "[x^2^k + y^2^k = 2] (mod 4)"
       proof (cases k)
         case 0
         from \<open>odd y\<close> have "[y = 1] (mod 2)"
           using cong_def by fastforce
         hence "[2*y = 2] (mod 4)"
           using cong_scale[where k=2 and b=1 and c=2, simplified] by force
         moreover from \<open>4 dvd x - y\<close> have "[x - y = 0] (mod 4)"
           by (simp add: cong_0_iff)
         ultimately have "[x + y = 2] (mod 4)"
-          by (smt cong_add)
+          by (metis add.commute assms(3) cong_add_lcancel cong_iff_dvd_diff cong_trans mult_2)
         with \<open>k = 0\<close> show ?thesis by simp
       next
         case (Suc k')
         then have "[x^2^k = 1] (mod 4)" and "[y^2^k = 1] (mod 4)"
           using \<open>odd x\<close> \<open>odd y\<close>
           by (auto simp add: power_mult power_Suc2 simp del: power_Suc intro: odd_square_mod_4)
         thus "[x^2^k + y^2^k = 2] (mod 4)"
-          by (smt cong_add)
+          using cong_add by fastforce
       qed
       thus "\<not> 2^Suc 1 dvd x^2^k + y^2^k"
         by (simp add: cong_dvd_iff)
     qed
     moreover have "x^2^k + y^2^k \<noteq> 0"
       using m_plus multiplicity_zero by auto
     moreover have "x^2^k - y^2^k \<noteq> 0"
     proof
       assume "x^2^k - y^2^k = 0"
       then have "\<bar>x\<bar> = \<bar>y\<bar>"
         by (intro power_eq_abs, simp, simp)
       hence "x = y \<or> x = -y"
         using abs_eq_iff by auto
       with \<open>x \<noteq> y\<close> have "x = -y"
         by simp
       with \<open>4 dvd x - y\<close> have "4 dvd 2*x"
         by simp
       hence "2 dvd x"
         by auto
       with \<open>odd x\<close> show False..
     qed
     ultimately have "multiplicity 2 (x^2^Suc k - y^2^Suc k) =
             multiplicity 2 (x^2^k - y^2^k) + multiplicity 2 (x^2^k + y^2^k)"
       by (unfold factor; intro prime_elem_multiplicity_mult_distrib; auto)
     then show ?case
       using m_plus Suc.IH by simp
   qed simp
 
   moreover have even_diff: "int 2 dvd x^2^multiplicity 2 n - y^2^multiplicity 2 n"
     using \<open>odd x\<close> and \<open>odd y\<close> by simp
   moreover have odd_parts: "\<not> int 2 dvd x^2^multiplicity 2 n"   "\<not> int 2 dvd y^2^multiplicity 2 n"
     using \<open>odd x\<close> and \<open>odd y\<close> by simp+
   moreover have coprime: "coprime 2 k"
     using \<open>\<not> 2 dvd k\<close> by simp
 
   show ?thesis
     apply (subst (1) n)
     apply (subst (2) n)
     apply (simp only: power_mult)
     apply (simp only: multiplicity_diff_pow_coprime[OF \<open>prime 2\<close> even_diff odd_parts coprime, simplified])
     by (rule pow2)
 qed
 
 text \<open>Theorem 4:\<close>
 
 theorem multiplicity_2_diff_even_pow:
   fixes x y :: int
   assumes "odd x"  "odd y" and "even n" and "n > 0" and "\<bar>x\<bar> \<noteq> \<bar>y\<bar>"
   shows "multiplicity 2 (x^n - y^n) = multiplicity 2 (x - y) + multiplicity 2 (x + y) + multiplicity 2 n - 1"
 proof -
   obtain n' where "n = 2*n'"
     using \<open>even n\<close> by auto
   with \<open>n > 0\<close> have "n' > 0" by simp
 
   moreover have "4 dvd x^2 - y^2"
   proof -
     have "x^2 - y^2 = (x + y) * (x - y)"
       by (simp add: algebra_simps power2_eq_square)
     moreover have "2 dvd x + y" and "2 dvd x - y"
       using \<open>odd x\<close> and \<open>odd y\<close> by auto
     ultimately show "4 dvd x^2 - y^2" by fastforce
   qed
 
   moreover have "odd (x^2)" and "odd (y^2)"
     using \<open>odd x\<close> \<open>odd y\<close> by auto
   moreover from \<open>\<bar>x\<bar> \<noteq> \<bar>y\<bar>\<close> have "x^2 \<noteq> y^2"
     using diff_0 diff_0_right power2_eq_iff by fastforce
 
   ultimately have "multiplicity 2 ((x^2)^n' - (y^2)^n') = multiplicity 2 (x^2 - y^2) + multiplicity 2 n'"
     by (intro multiplicity_2_diff_pow_4div)
   also have "multiplicity 2 ((x^2)^n' - (y^2)^n') = multiplicity 2 (x^n - y^n)"
     unfolding \<open>n = 2*n'\<close> by (simp add: power_mult)
   also have "multiplicity 2 (x^2 - y^2) = multiplicity 2 ((x - y) * (x + y))"
     by (simp add: algebra_simps power2_eq_square)
   also have "... = multiplicity 2 (x - y) + multiplicity 2 (x + y)"
     using \<open>\<bar>x\<bar> \<noteq> \<bar>y\<bar>\<close> by (auto intro: prime_elem_multiplicity_mult_distrib)
   also have "multiplicity 2 n = Suc (multiplicity 2 n')"
     unfolding \<open>n = 2*n'\<close> using \<open>n' > 0\<close> by (simp add: multiplicity_times_same)
   ultimately show ?thesis by simp
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Stellar_Quorums/Stellar_Quorums.thy b/thys/Stellar_Quorums/Stellar_Quorums.thy
--- a/thys/Stellar_Quorums/Stellar_Quorums.thy
+++ b/thys/Stellar_Quorums/Stellar_Quorums.thy
@@ -1,613 +1,612 @@
 text 
 \<open>This theory formalizes some of the results appearing in the paper "Stellar Consensus By Reduction"\<^cite>\<open>"disc_paper"\<close>.
 We prove static properties of personal Byzantine quorum systems and Stellar quorum systems.\<close>
 
 theory Stellar_Quorums
   imports Main 
 begin
 
 section "Personal Byzantine quorum systems"
 
 locale personal_quorums =
   fixes quorum_of :: "'node \<Rightarrow> 'node set \<Rightarrow> bool" 
   assumes quorum_assm:"\<And> p p' . \<lbrakk>quorum_of p Q; p' \<in> Q\<rbrakk> \<Longrightarrow> quorum_of p' Q"
     \<comment> \<open>In other words, a quorum (of some participant) is a quorum of all its members.\<close>
 begin
 
 definition blocks where
   \<comment> \<open>Set @{term R} blocks participant @{term p}.\<close>
   "blocks R p \<equiv> \<forall> Q . quorum_of p Q \<longrightarrow> Q \<inter> R \<noteq> {}"
 
 abbreviation blocked_by where "blocked_by R \<equiv> {p . blocks R p}"
 
 lemma blocked_blocked_subset_blocked:
   "blocked_by (blocked_by R) \<subseteq> blocked_by R"
 proof -
   have False if "p \<in> blocked_by (blocked_by R)" and "p \<notin> blocked_by R" for p
   proof -
     have "Q \<inter> blocked_by R \<noteq> {}" if "quorum_of p Q" for Q
       using \<open>p \<in> blocked_by (blocked_by R)\<close> that unfolding blocks_def by auto
     have "Q \<inter> R \<noteq> {}" if " quorum_of p Q" for Q
     proof -
       obtain p' where "p' \<in> blocked_by R" and "p' \<in> Q"
         by (meson Int_emptyI \<open>\<And>Q. quorum_of p Q \<Longrightarrow> Q \<inter> blocked_by R \<noteq> {}\<close> \<open>quorum_of p Q\<close>)
       hence "quorum_of p' Q"
         using quorum_assm that by blast
       with \<open>p' \<in> blocked_by R\<close> show "Q \<inter> R \<noteq> {}"
         using blocks_def by auto
     qed
     hence "p \<in> blocked_by R" by (simp add: blocks_def)
     thus False using that(2) by auto
   qed
   thus "blocked_by (blocked_by R) \<subseteq> blocked_by R"
     by blast
 qed
 
 end
 
 text \<open>We now add the set of correct participants to the model.\<close>
 
 locale with_w = personal_quorums quorum_of for quorum_of  :: "'node \<Rightarrow> 'node set \<Rightarrow> bool" +
   fixes W::"'node set" \<comment> \<open>@{term W} is the set of correct participants\<close>
 begin
 
 abbreviation B where "B \<equiv> -W"
   \<comment> \<open>@{term B} is the set of malicious participants.\<close>
 
 definition quorum_of_set where "quorum_of_set S Q \<equiv> \<exists> p \<in> S . quorum_of p Q"
 
 subsection "The set of participants not blocked by malicious participants"
 
 definition L where "L \<equiv> W - (blocked_by B)"
 
 lemma l2: "p \<in> L \<Longrightarrow> \<exists> Q  \<subseteq> W. quorum_of p Q" 
   unfolding L_def blocks_def using DiffD2 by auto
  
 lemma l3: \<comment>  \<open>If a participant is not blocked by the malicious participants, then it has a quorum consisting exclusively of correct 
 participants which are not blocked by the malicious participants.\<close>
   assumes "p \<in> L" shows "\<exists> Q \<subseteq> L . quorum_of p Q"
 proof -
   have False if "\<And> Q . quorum_of p Q \<Longrightarrow> Q \<inter> (-L) \<noteq> {}"
   proof -
     obtain Q where "quorum_of p Q" and "Q \<subseteq> W" 
       using l2 \<open>p \<in> L\<close> by auto 
     have "Q \<inter> (-L) \<noteq> {}"  using that \<open>quorum_of p Q\<close> by simp
     obtain p' where "p' \<in> Q \<inter> (-L)" and "quorum_of p' Q"
       using \<open>Q \<inter> - L \<noteq> {}\<close> \<open>quorum_of p Q\<close> inf.left_idem quorum_assm by fastforce 
     hence "Q \<inter> B \<noteq> {}" unfolding L_def
       using CollectD Compl_Diff_eq Int_iff inf_le1 personal_quorums.blocks_def personal_quorums_axioms subset_empty by fastforce
     thus False using \<open>Q \<subseteq> W\<close> by auto  
   qed 
   thus ?thesis by (metis disjoint_eq_subset_Compl double_complement)
 qed
 
 subsection "Consensus clusters and intact sets"
 
 definition is_intertwined where
   \<comment> \<open>This definition is not used in this theory,
     but we include it to formalize the notion of intertwined set appearing in the DISC paper.\<close>
   "is_intertwined S \<equiv> S \<subseteq> W 
     \<and> (\<forall> Q Q' . quorum_of_set S Q \<and> quorum_of_set S Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"
 
 definition is_cons_cluster where
   \<comment> \<open>Consensus clusters\<close>
   "is_cons_cluster C \<equiv> C \<subseteq> W \<and> (\<forall> p \<in> C . \<exists> Q \<subseteq> C . quorum_of p Q)
       \<and> (\<forall> Q Q' . quorum_of_set C Q \<and> quorum_of_set C Q' \<longrightarrow> W \<inter> Q \<inter> Q' \<noteq> {})"
 
 definition strong_consensus_cluster where
   "strong_consensus_cluster I \<equiv> I \<subseteq> W \<and> (\<forall> p \<in> I . \<exists> Q \<subseteq> I . quorum_of p Q)
       \<and> (\<forall> Q Q' . quorum_of_set I Q \<and> quorum_of_set I Q' \<longrightarrow> I \<inter> Q \<inter> Q' \<noteq> {})"
 
 lemma strong_consensus_cluster_imp_cons_cluster:
 \<comment> \<open>Every intact set is a consensus cluster\<close>
   shows "strong_consensus_cluster I \<Longrightarrow> is_cons_cluster I" 
   unfolding strong_consensus_cluster_def is_cons_cluster_def
   by blast 
 
 lemma cons_cluster_neq_cons_cluster:
   \<comment> \<open>Some consensus clusters are not strong consensus clusters and have no superset that is a strong consensus cluster.\<close>
   shows "is_cons_cluster I \<and> (\<forall> J . I \<subseteq> J \<longrightarrow> \<not>strong_consensus_cluster J)" nitpick[falsify=false, card 'node=3, expect=genuine]
   oops
 
 text \<open>Next we show that the union of two consensus clusters that intersect is a consensus cluster.\<close>
 
 theorem cluster_union:
   assumes "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
   shows "is_cons_cluster (C\<^sub>1\<union> C\<^sub>2)"
 proof -
   have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
     using assms(1) assms(2) is_cons_cluster_def by auto 
   moreover
   have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q" 
     using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def
     by (meson UnE le_supI1 le_supI2)
   moreover
   have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
     if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2" 
     for Q\<^sub>1 Q\<^sub>2
   proof -
     have "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
       using \<open>is_cons_cluster C\<^sub>1\<close> \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1\<close> \<open>quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2\<close> that
       unfolding quorum_of_set_def is_cons_cluster_def by metis
     moreover
     have \<open>W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "is_cons_cluster C\<^sub>1" and "is_cons_cluster C\<^sub>2"
       and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
     for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
     proof -
       obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2" 
         using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>is_cons_cluster C\<^sub>2\<close> unfolding is_cons_cluster_def by blast
       have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
         unfolding is_cons_cluster_def quorum_of_set_def
         by (metis Int_assoc Int_iff inf_bot_right)
       hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast 
       thus "W \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>is_cons_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
         unfolding is_cons_cluster_def by blast
     qed
     ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto 
   qed
   ultimately show ?thesis using assms
     unfolding is_cons_cluster_def by simp
 qed
 
 text \<open>Similarly, the union of two strong consensus clusters is a strong consensus cluster.\<close>
 lemma strong_cluster_union:
   assumes "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2" and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}"
   shows "strong_consensus_cluster (C\<^sub>1\<union> C\<^sub>2)"
 proof -
   have "C\<^sub>1 \<union> C\<^sub>2 \<subseteq> W"
     using assms(1) assms(2) strong_consensus_cluster_def by auto 
   moreover
   have "\<forall> p \<in> (C\<^sub>1\<union>C\<^sub>2) . \<exists> Q \<subseteq> (C\<^sub>1\<union>C\<^sub>2) . quorum_of p Q" 
     using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def
     by (meson UnE le_supI1 le_supI2)
   moreover
   have "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}"
     if "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>1" and "quorum_of_set (C\<^sub>1\<union>C\<^sub>2) Q\<^sub>2" 
     for Q\<^sub>1 Q\<^sub>2
   proof -
     have "C \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
       using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> that
       unfolding quorum_of_set_def strong_consensus_cluster_def by metis
     hence "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" if "quorum_of_set C Q\<^sub>1" and "quorum_of_set C Q\<^sub>2" and "C = C\<^sub>1 \<or> C = C\<^sub>2" for C
       by (metis Int_Un_distrib2 disjoint_eq_subset_Compl sup.boundedE that)
     moreover
     have \<open>(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}\<close>  if "strong_consensus_cluster C\<^sub>1" and "strong_consensus_cluster C\<^sub>2"
       and "C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}" and "quorum_of_set C\<^sub>1 Q\<^sub>1" and "quorum_of_set C\<^sub>2 Q\<^sub>2"
     for C\<^sub>1 C\<^sub>2 \<comment> \<open>We generalize to avoid repeating the argument twice\<close>
     proof -
       obtain p Q where "quorum_of p Q" and "p \<in> C\<^sub>1 \<inter> C\<^sub>2" and "Q \<subseteq> C\<^sub>2" 
         using \<open>C\<^sub>1 \<inter> C\<^sub>2 \<noteq> {}\<close> \<open>strong_consensus_cluster C\<^sub>2\<close> unfolding strong_consensus_cluster_def by blast
       have "Q \<inter> Q\<^sub>1 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>1\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> \<open>quorum_of p Q\<close> \<open>p \<in> C\<^sub>1 \<inter> C\<^sub>2\<close>
         unfolding strong_consensus_cluster_def quorum_of_set_def
         by (metis Int_assoc Int_iff inf_bot_right)
       hence "quorum_of_set C\<^sub>2 Q\<^sub>1"  using \<open>Q \<subseteq> C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>1 Q\<^sub>1\<close> quorum_assm unfolding quorum_of_set_def by blast 
       thus "(C\<^sub>1\<union>C\<^sub>2) \<inter> Q\<^sub>1 \<inter> Q\<^sub>2 \<noteq> {}" using \<open>strong_consensus_cluster C\<^sub>2\<close> \<open>quorum_of_set C\<^sub>2 Q\<^sub>2\<close>
         unfolding strong_consensus_cluster_def by blast
     qed
     ultimately show ?thesis using assms that unfolding quorum_of_set_def by auto 
   qed
   ultimately show ?thesis using assms
     unfolding strong_consensus_cluster_def by simp
 qed
 
 end
 
 section "Stellar quorum systems"
 
 locale stellar =
   fixes slices :: "'node \<Rightarrow> 'node set set" \<comment> \<open>the quorum slices\<close>
     and W :: "'node set" \<comment> \<open>the well-behaved nodes\<close>
   assumes slices_ne:"\<And>p . p \<in> W \<Longrightarrow> slices p \<noteq> {}"
 begin
 
 definition quorum where
   "quorum Q \<equiv> \<forall> p \<in> Q \<inter> W . (\<exists> Sl \<in> slices p . Sl \<subseteq> Q)"
 
 definition quorum_of where "quorum_of p Q \<equiv> quorum Q \<and> (p \<notin> W \<or> (\<exists> Sl \<in> slices p . Sl \<subseteq> Q))"
   \<comment> \<open>TODO: @{term "p\<notin>W"} needed?\<close>
 
 lemma quorum_union:"quorum Q \<Longrightarrow> quorum Q' \<Longrightarrow> quorum (Q \<union> Q')"
   unfolding quorum_def
   by (metis IntE Int_iff UnE inf_sup_aci(1) sup.coboundedI1 sup.coboundedI2)
 
 lemma l1:
   assumes "\<And> p . p \<in> S \<Longrightarrow> \<exists> Q \<subseteq> S . quorum_of p Q" and "p\<in> S"
   shows "quorum_of p S" using assms unfolding quorum_of_def quorum_def
   by (meson Int_iff subset_trans)
 
 lemma is_pbqs:
   assumes "quorum_of p Q" and "p' \<in> Q"
   shows "quorum_of p' Q" 
   \<comment> \<open>This is the property required of a PBQS.\<close>
   using assms
   by (simp add: quorum_def quorum_of_def)
 
 interpretation with_w quorum_of 
   \<comment> \<open>Stellar quorums form a personal quorum system.\<close>
   unfolding with_w_def personal_quorums_def 
   quorum_def quorum_of_def by simp
 
 lemma quorum_is_quorum_of_some_slice:
   assumes "quorum_of p Q" and "p \<in> W"
   obtains S where "S \<in> slices p" and "S \<subseteq> Q"
     and "\<And> p' . p' \<in> S \<inter> W \<Longrightarrow> quorum_of p' Q"
   using assms unfolding quorum_def quorum_of_def by fastforce
 
 lemma "is_cons_cluster C \<Longrightarrow> quorum C" 
   \<comment> \<open>Every consensus cluster is a quorum.\<close>
   unfolding is_cons_cluster_def
   by (metis inf.order_iff l1 quorum_of_def stellar.quorum_def stellar_axioms) 
 
 subsection \<open>Properties of blocking sets\<close>
 
 inductive blocking_min where
   \<comment> \<open>This is the set of correct participants that are eventually blocked by a set @{term R} when byzantine processors do not take steps.\<close>
   "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl\<inter>W . q \<in> R \<or> blocking_min R q\<rbrakk> \<Longrightarrow> blocking_min R p"
 inductive_cases blocking_min_elim:"blocking_min R p"
 
 inductive blocking_max where
   \<comment> \<open>This is the set of participants that are eventually blocked by a set @{term R} when byzantine processors help epidemic propagation.\<close>
   "\<lbrakk>p \<in> W; \<forall> Sl \<in> slices p . \<exists> q \<in> Sl . q \<in> R\<union>B \<or> blocking_max R q\<rbrakk> \<Longrightarrow> blocking_max R p"
 inductive_cases "blocking_max R p"
 
 text \<open>Next we show that if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} and @{term p} belongs to a consensus cluster @{term S}, then @{term \<open>R \<inter> S \<noteq> {}\<close>}.\<close>
 
 text \<open>We first prove two auxiliary lemmas:\<close>
 
 lemma cons_cluster_wb:"p \<in> C \<Longrightarrow> is_cons_cluster C \<Longrightarrow> p\<in>W"
   using is_cons_cluster_def  by fastforce 
 
 lemma cons_cluster_has_ne_slices:
   assumes "is_cons_cluster C" and "p\<in>C"
     and "Sl \<in> slices p" 
   shows "Sl \<noteq> {}"
   using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
   by (metis empty_iff inf_bot_left inf_bot_right subset_refl)
 
 lemma cons_cluster_has_cons_cluster_slice:
   assumes "is_cons_cluster C" and "p\<in>C"
   obtains Sl where "Sl \<in> slices p" and "Sl \<subseteq> C"
   using assms unfolding is_cons_cluster_def quorum_of_set_def quorum_of_def quorum_def
   by (metis Int_commute  empty_iff inf.order_iff  inf_bot_right le_infI1)
 
 theorem blocking_max_intersects_intact:
   \<comment> \<open>if @{term \<open>R\<close>} blocks @{term \<open>p\<close>} when malicious participants help epidemic propagation, 
 and @{term p} belongs to a consensus cluster @{term C}, then @{term \<open>R \<inter> C \<noteq> {}\<close>}\<close>
   assumes  "blocking_max R p" and "is_cons_cluster C" and "p \<in> C"
   shows "R \<inter> C \<noteq> {}" using assms
 proof (induct)
   case (1 p R)
   obtain Sl where "Sl \<in> slices p" and "Sl \<subseteq> C" using cons_cluster_has_cons_cluster_slice
     using "1.prems" by blast
   moreover have "Sl \<subseteq> W" using assms(2) calculation(2) is_cons_cluster_def by auto 
   ultimately show ?case
     using "1.hyps" assms(2) by fastforce
 qed
 
 text \<open>Now we show that if @{term \<open>p \<in> C\<close>}, @{term C} is a consensus cluster, and quorum @{term Q} is such that @{term \<open>Q \<inter> C \<noteq> {}\<close>},
     then @{term \<open>Q \<inter> W\<close>} blocks @{term p}. 
 
 We start by defining the set of participants reachable from a participant through correct participants.
 Their union trivially forms a quorum. 
 Moreover, if @{term p} is not blocked by a set @{term R}, 
 then we show that the set of participants reachable from @{term p} and not blocked by @{term R} forms a quorum disjoint from @{term R}.
 It follows that if @{term p } is a member of a consensus cluster @{term C} and @{term Q} is a quorum of a member of @{term C}, then @{term "Q\<inter>W"}
  must block @{term p}, as otherwise quorum intersection would be violated. \<close>
 
 inductive not_blocked for p R where
   "\<lbrakk>Sl \<in> slices p; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
 | "\<lbrakk>not_blocked p R p'; p' \<in> W; Sl \<in> slices p'; \<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q; q \<in> Sl\<rbrakk> \<Longrightarrow> not_blocked p R q"
 inductive_cases not_blocked_cases:"not_blocked p R q"
 
 lemma l4:
   fixes Q p R
   defines "Q \<equiv> {q . not_blocked p R q}"
   shows "quorum Q"
 proof -
   have "\<exists> S \<in> slices n . S \<subseteq> Q" if "n\<in>Q\<inter>W" for n
   proof-
     have "not_blocked p R n" using assms that by blast
     hence "n \<notin> R" and "\<not>blocking_min R n" by (metis Int_iff not_blocked.simps that)+
     thus ?thesis  using blocking_min.intros not_blocked.intros(2) that unfolding Q_def 
       by (simp; metis mem_Collect_eq subsetI)
   qed
   thus ?thesis by (simp add: quorum_def)
 qed
 
 
 lemma l5:
   fixes Q p R
   defines "Q \<equiv> {q . not_blocked p R q}"
   assumes  "\<not>blocking_min R p" and \<open>p\<in>C\<close> and \<open>is_cons_cluster C\<close>
   shows "quorum_of p Q" 
 proof -
   have "p\<in>W"
     using assms(3,4) cons_cluster_wb by blast 
   obtain Sl where "Sl \<in> slices p" and "\<forall> q \<in> Sl\<inter>W . q \<notin> R \<and> \<not>blocking_min R q"
     by (meson \<open>p \<in> W\<close> assms(2) blocking_min.intros)
   hence "Sl \<subseteq> Q" unfolding Q_def using not_blocked.intros(1) by blast
   with l4 \<open>Sl \<in> slices p\<close> show "quorum_of p Q"
     using Q_def  quorum_of_def by blast
 qed
 
 lemma cons_cluster_ne_slices:
   assumes "is_cons_cluster C" and "p\<in>C" and "Sl \<in> slices p"
   shows "Sl\<noteq>{}"
   using assms cons_cluster_has_ne_slices cons_cluster_wb stellar.quorum_of_def stellar_axioms by fastforce
 
 lemma l6:
   fixes Q p R
   defines "Q \<equiv> {q . not_blocked p R q}"
   shows "Q \<inter> R \<inter> W = {}"
 proof -
   have "q \<notin> R" if "not_blocked p R q" and "q\<in> W" for q using that
     by (metis Int_iff not_blocked.simps)
   thus ?thesis unfolding Q_def by auto
 qed
 
 theorem quorum_blocks_cons_cluster:
   assumes "quorum_of_set C Q" and "p\<in>C" and "is_cons_cluster C"
   shows "blocking_min (Q \<inter> W) p"
 proof (rule ccontr) 
   assume "\<not> blocking_min (Q \<inter> W) p"
   have "p\<in>W" using assms(2,3) is_cons_cluster_def by auto 
   define Q' where "Q' \<equiv> {q . not_blocked p (Q\<inter>W) q}"
   have "quorum_of p Q'" using Q'_def \<open>\<not> blocking_min (Q \<inter> W) p\<close> assms(2) assms(3) l5(1) by blast
   moreover have "Q' \<inter> Q \<inter> W = {}"
     using Q'_def l6 by fastforce
   ultimately show False using assms unfolding is_cons_cluster_def
     by (metis Int_commute inf_sup_aci(2) quorum_of_set_def) 
 qed
 
 subsection \<open>Reachability through a set\<close>
 
 text \<open>Here we define the part of a quorum @{term Q} of @{term p} that is reachable through correct
 participants from @{term p}. We show that if @{term p} and @{term p'} are members of the same consensus cluster and @{term Q} is a quorum of @{term p}
  and @{term Q'} is a quorum of @{term p'},
 then the intersection @{term "Q\<inter>Q'\<inter>W"} is reachable from both @{term p} and @{term p'} through the consensus cluster.\<close>
 
 inductive reachable_through for p S where
   "reachable_through p S p"
 | "\<lbrakk>reachable_through p S p'; p' \<in> W; Sl \<in> slices p'; Sl \<subseteq> S; p'' \<in> Sl\<rbrakk> \<Longrightarrow> reachable_through p S p''"
 
 definition truncation where "truncation p S \<equiv> {p' . reachable_through p S p'}"
 
 lemma l13:
   assumes "quorum_of p Q" and "p \<in> W" and "reachable_through p Q p'"
   shows "quorum_of p' Q"
   using assms using quorum_assm reachable_through.cases
   by (metis is_pbqs subset_iff)
 
 lemma l14:
   assumes "quorum_of p Q" and "p \<in> W"
   shows "quorum (truncation p Q)"
 proof -
   have "\<exists> S \<in> slices p' . \<forall> q \<in> S . reachable_through p Q q" if "reachable_through p Q p'" and "p' \<in> W" for p'
     by (meson assms l13 quorum_is_quorum_of_some_slice stellar.reachable_through.intros(2) stellar_axioms that)
   thus ?thesis
     by (metis IntE mem_Collect_eq stellar.quorum_def stellar_axioms subsetI truncation_def)  
 qed
 
 lemma l15:
   assumes "is_cons_cluster I" and "quorum_of p Q" and "quorum_of p' Q'" and "p \<in> I" and "p' \<in> I" and "Q \<inter> Q' \<inter> W \<noteq> {}"
   shows "W \<inter> (truncation p Q) \<inter> (truncation p' Q') \<noteq> {}" 
 proof -
   have "quorum (truncation p Q)" and "quorum (truncation p' Q')" using l14 assms is_cons_cluster_def by auto
   moreover have "quorum_of_set I (truncation p Q)" and "quorum_of_set I (truncation p' Q')"
     by (metis IntI assms(4,5) calculation mem_Collect_eq quorum_def quorum_of_def quorum_of_set_def reachable_through.intros(1) truncation_def)+
   moreover note \<open>is_cons_cluster I\<close>
   ultimately show ?thesis unfolding is_cons_cluster_def by auto
 qed
 
 end
 
 subsection "Elementary quorums"
 
 text \<open>In this section we define the notion of elementary quorum, which is a quorum that has no strict subset that is a quorum.
   It follows directly from the definition that every finite quorum contains an elementary quorum. Moreover, we show 
 that if @{term Q} is an elementary quorum and @{term n\<^sub>1} and @{term n\<^sub>2} are members of @{term Q}, then @{term n\<^sub>2} is reachable from @{term n\<^sub>1} 
 in the directed graph over participants defined as the set of edges @{term "(n,m)"} such that @{term m} is a member of a slice of @{term n}.
 This lemma is used in the companion paper to show that probabilistic leader-election is feasible.\<close>
 
 locale elementary = stellar
 begin 
 
 definition elementary where
   "elementary s \<equiv> quorum s \<and> (\<forall> s' . s' \<subset> s \<longrightarrow> \<not>quorum s')"
 
 lemma finite_subset_wf:
   shows "wf {(X, Y). X \<subset> Y \<and> finite Y}"
   by (metis finite_psubset_def wf_finite_psubset)
 
 lemma quorum_contains_elementary:
   assumes "finite s" and  "\<not> elementary s" and "quorum s" 
   shows "\<exists> s' . s' \<subset> s \<and> elementary s'" using assms
 proof (induct s rule:wf_induct[where ?r="{(X, Y). X \<subset> Y \<and> finite Y}"])
   case 1
   then show ?case using finite_subset_wf by simp
 next
   case (2 x)
   then show ?case
     by (metis (full_types) elementary_def finite_psubset_def finite_subset in_finite_psubset less_le psubset_trans)
 qed
 
 inductive path where
   "path []"
 | "\<And> x . path [x]"
 | "\<And> l n . \<lbrakk>path l; S \<in> Q (hd l); n \<in> S\<rbrakk> \<Longrightarrow> path (n#l)"
 
 theorem elementary_connected:
   assumes "elementary s" and "n\<^sub>1 \<in> s" and "n\<^sub>2 \<in> s" and "n\<^sub>1 \<in> W" and "n\<^sub>2 \<in> W"
   shows "\<exists> l . hd (rev l) = n\<^sub>1 \<and> hd l = n\<^sub>2 \<and> path l" (is ?P)
 proof -
   { assume "\<not>?P"
     define x where "x \<equiv> {n \<in> s . \<exists> l . l \<noteq> [] \<and> hd (rev l) = n\<^sub>1 \<and> hd l = n \<and> path l}"
     have "n\<^sub>2 \<notin> x" using \<open>\<not>?P\<close> x_def by auto 
     have "n\<^sub>1 \<in> x" unfolding x_def using assms(2) path.intros(2) by force
     have "quorum x"
     proof -
       { fix n
         assume "n \<in> x"
         have "\<exists> S . S \<in> slices n \<and> S \<subseteq> x"
         proof -
           obtain S where "S \<in> slices n" and "S \<subseteq> s" using \<open>elementary s\<close> \<open>n \<in> x\<close> unfolding x_def
             by (force simp add:elementary_def quorum_def)
           have "S \<subseteq> x"
           proof -
             { assume "\<not> S \<subseteq> x"
               obtain m where "m \<in> S" and "m \<notin> x" using \<open>\<not> S \<subseteq> x\<close> by auto
               obtain l' where "hd (rev l') = n\<^sub>1" and "hd l' = n" and "path l'" and "l' \<noteq> []"
                 using \<open>n \<in> x\<close> x_def by blast 
               have "path (m # l')" using \<open>path l'\<close> \<open>m\<in> S\<close> \<open>S \<in> slices n\<close> \<open>hd l' = n\<close>
                 using path.intros(3) by fastforce
               moreover have "hd (rev (m # l')) = n\<^sub>1" using \<open>hd (rev l') = n\<^sub>1\<close> \<open>l' \<noteq> []\<close> by auto
               ultimately have "m \<in> x" using \<open>m \<in> S\<close> \<open>S \<subseteq> s\<close> x_def by auto 
               hence False using \<open>m \<notin> x\<close> by blast }
             thus ?thesis by blast
           qed
           thus ?thesis
             using \<open>S \<in> slices n\<close> by blast
         qed }
       thus ?thesis by (meson Int_iff quorum_def)
     qed 
     moreover have "x \<subset> s"
       using \<open>n\<^sub>2 \<notin> x\<close> assms(3) x_def by blast
     ultimately have False using \<open>elementary s\<close>
       using elementary_def by auto
   }
   thus ?P by blast  
 qed
 
 
 end
 
 subsection \<open>The intact sets of the Stellar Whitepaper\<close>
 
 definition project where 
   "project slices S n \<equiv> {Sl \<inter> S | Sl . Sl \<in> slices n}" 
   \<comment> \<open>Projecting on @{term S} is the same as deleting the complement of @{term S}, where deleting is understood as in the Stellar Whitepaper.\<close>
 
 subsubsection \<open>Intact and the Cascade Theorem\<close>
 
 locale intact = \<comment> \<open>Here we fix an intact set @{term I} and prove the cascade theorem.\<close>
   orig:stellar slices W 
   + proj:stellar "project slices I" W \<comment> \<open>We consider the projection of the system on @{term I}.\<close>
   for slices W I +  \<comment> \<open>An intact set is a set @{term I} satisfying the three assumptions below:\<close>
   assumes intact_wb:"I \<subseteq> W"
     and q_avail:"orig.quorum I" \<comment> \<open>@{term I} is a quorum in the original system.\<close>
     and q_inter:"\<And> Q Q' . \<lbrakk>proj.quorum Q; proj.quorum Q'; Q \<inter> I \<noteq> {}; Q' \<inter> I \<noteq> {}\<rbrakk>  \<Longrightarrow> Q \<inter> Q' \<inter> I \<noteq> {}" 
     \<comment> \<open>Any two sets that intersect @{term I} and that are quorums in the projected system intersect in @{term I}.
 Note that requiring that @{text \<open>Q \<inter> Q' \<noteq> {}\<close>} instead of @{text \<open>Q \<inter> Q' \<inter> I \<noteq> {}\<close>} would be equivalent.\<close>
 begin
 
 theorem blocking_safe: \<comment> \<open>A set that blocks an intact node contains an intact node. 
 If this were not the case, quorum availability would trivially be violated.\<close>
   fixes S n
   assumes "n\<in>I" and "\<forall> Sl\<in> slices n .Sl\<inter>S \<noteq> {}"
   shows "S \<inter> I \<noteq> {}"
   using assms q_avail intact_wb unfolding orig.quorum_def 
   by auto (metis inf.absorb_iff2 inf_assoc inf_bot_right inf_sup_aci(1)) 
 
 theorem cascade:
 \<comment> \<open>If @{term U} is a quorum of an intact node and @{term S} is a super-set of @{term U}, then either @{term S} includes 
 all intact nodes or there is an intact node outside of @{term S} which is blocked by the intact members of @{term S}.
 This shows that, in SCP, once the intact members of a quorum accept a statement, 
 a cascading effect occurs and all intact nodes eventually accept it regardless of what befouled and faulty nodes do.\<close>
   fixes U S
   assumes "orig.quorum U" and "U \<inter> I \<noteq> {}" and "U \<subseteq> S"
   obtains "I \<subseteq> S" | "\<exists> n \<in> I - S . \<forall> Sl \<in> slices n . Sl \<inter> S \<inter> I \<noteq> {}"
 proof -
   have False if 1:"\<forall> n \<in> I - S . \<exists> Sl \<in> slices n . Sl \<inter> S \<inter> I = {}" and 2:"\<not>(I \<subseteq> S)"
   proof -
     text \<open>First we show that @{term \<open>I-S\<close>} is a quorum in the projected system. This is immediate from the definition of quorum and assumption 1.\<close>
     have "proj.quorum (I-S)" using 1
-      unfolding proj.quorum_def project_def 
-      by (auto; smt DiffI Diff_Compl Diff_Int_distrib Diff_eq Diff_eq_empty_iff Int_commute)
+      by (simp add: proj.quorum_def project_def) (metis DiffI IntE IntI empty_iff subsetI)
     text \<open>Then we show that U is also a quorum in the projected system:\<close>
     moreover have "proj.quorum U" using \<open>orig.quorum U\<close> 
       unfolding proj.quorum_def orig.quorum_def project_def 
       by (simp; meson Int_commute inf.coboundedI2)
     text \<open>Since quorums of @{term I} must intersect, we get a contradiction:\<close>
     ultimately show False using \<open>U \<subseteq> S\<close> \<open>U \<inter> I \<noteq> {}\<close> \<open>\<not>(I\<subseteq>S)\<close> q_inter by auto
   qed
   thus ?thesis using that by blast
 qed
 
 end
 
 subsubsection "The Union Theorem"
 
 text \<open>Here we prove that the union of two intact sets that intersect is intact.
 This implies that maximal intact sets are disjoint.\<close>
 
 locale intersecting_intact = 
   i1:intact slices W I\<^sub>1 + i2:intact slices W I\<^sub>2 \<comment> \<open>We fix two intersecting intact sets @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
   + proj:stellar "project slices (I\<^sub>1\<union>I\<^sub>2)" W \<comment> \<open>We consider the projection of the system on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
   for slices W I\<^sub>1 I\<^sub>2 +
 assumes inter:"I\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}"
 begin
 
 theorem union_quorum: "i1.orig.quorum (I\<^sub>1\<union>I\<^sub>2)" \<comment> \<open>@{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} is a quorum in the original system.\<close>
   using i1.intact_axioms i2.intact_axioms
   unfolding  intact_def stellar_def intact_axioms_def i1.orig.quorum_def
   by (metis Int_iff Un_iff le_supI1 le_supI2)
 
 theorem union_quorum_intersection: 
   assumes "proj.quorum Q\<^sub>1" and "proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}" and "Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
   shows "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
     \<comment> \<open>Any two sets that intersect @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} and that are quorums in the system projected on @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>} intersect in @{term \<open>I\<^sub>1\<union>I\<^sub>2\<close>}.\<close>
 proof -
   text \<open>First we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} are quorums in the projections on @{term I\<^sub>1} and @{term I\<^sub>2}.\<close>
   have "i1.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close> 
     unfolding i1.proj.quorum_def proj.quorum_def project_def
     by auto (metis Int_Un_distrib Int_iff Un_subset_iff) 
   moreover have "i2.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close> 
     unfolding i2.proj.quorum_def proj.quorum_def project_def
     by auto (metis Int_Un_distrib Int_iff Un_subset_iff) 
   moreover have "i2.proj.quorum Q\<^sub>1" using \<open>proj.quorum Q\<^sub>1\<close>
     unfolding proj.quorum_def i2.proj.quorum_def project_def
     by auto (metis Int_Un_distrib Int_iff Un_subset_iff) 
   moreover have "i1.proj.quorum Q\<^sub>2" using \<open>proj.quorum Q\<^sub>2\<close>
     unfolding proj.quorum_def i1.proj.quorum_def project_def
     by auto (metis Int_Un_distrib Int_iff Un_subset_iff) 
   text \<open>Next we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of, respectively, @{term I\<^sub>1} and @{term I\<^sub>2}. 
 This is the only interesting part of the proof.\<close> 
   moreover have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}" 
     if "i1.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "i2.proj.quorum Q\<^sub>1"
       and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
     for Q\<^sub>1 Q\<^sub>2
   proof -
     have "i1.proj.quorum I\<^sub>2" 
     proof -
       have "i1.orig.quorum I\<^sub>2" by (simp add: i2.q_avail)
       thus ?thesis unfolding i1.orig.quorum_def i1.proj.quorum_def project_def
         by auto (meson Int_commute Int_iff inf_le2 subset_trans)
     qed
     moreover note \<open>i1.proj.quorum Q\<^sub>1\<close>
     ultimately have "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" using i1.q_inter inter \<open>Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}\<close> by blast
 
     moreover note \<open>i2.proj.quorum Q\<^sub>2\<close>  
     moreover note \<open>i2.proj.quorum Q\<^sub>1\<close>
     ultimately have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}" using i2.q_inter \<open>Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}\<close> by blast 
     thus ?thesis by (simp add: inf_sup_distrib1)
   qed
   text \<open>Next  we show that @{term Q\<^sub>1} and @{term Q\<^sub>2} intersect if they are quorums of the same intact set. This is obvious.\<close>
   moreover
   have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}" 
     if "i1.proj.quorum Q\<^sub>1" and "i1.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>1 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>1 \<noteq> {}"
     for Q\<^sub>1 Q\<^sub>2
     by (simp add: Int_Un_distrib i1.q_inter that)  
   moreover
   have "Q\<^sub>1 \<inter> Q\<^sub>2 \<inter> (I\<^sub>1\<union>I\<^sub>2) \<noteq> {}"
     if "i2.proj.quorum Q\<^sub>1" and "i2.proj.quorum Q\<^sub>2" and "Q\<^sub>1 \<inter> I\<^sub>2 \<noteq> {}" and "Q\<^sub>2 \<inter> I\<^sub>2 \<noteq> {}"
     for Q\<^sub>1 Q\<^sub>2
     by (simp add: Int_Un_distrib i2.q_inter that)
   text \<open>Finally we have covered all the cases and get the final result:\<close>
   ultimately
   show ?thesis
-    by (smt Int_Un_distrib Int_commute assms(3,4) sup_bot.right_neutral) 
+    by (smt (verit, best) Int_Un_distrib Int_commute assms(3) assms(4) sup_eq_bot_iff)
 qed
 
 end
 
 end
diff --git a/thys/Sumcheck_Protocol/Generalized_Sumcheck_Protocol/Substitutions.thy b/thys/Sumcheck_Protocol/Generalized_Sumcheck_Protocol/Substitutions.thy
--- a/thys/Sumcheck_Protocol/Generalized_Sumcheck_Protocol/Substitutions.thy
+++ b/thys/Sumcheck_Protocol/Generalized_Sumcheck_Protocol/Substitutions.thy
@@ -1,104 +1,104 @@
 (*******************************************************************************
 
   Project: Sumcheck Protocol
 
   Authors: Azucena Garvia Bosshard <zucegb@gmail.com>
            Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>
            Jonathan Bootle, IBM Research Europe <jbt@zurich.ibm.com>
 
 *******************************************************************************)
 
 section \<open>Substitutions\<close>
 
 theory Substitutions
   imports
     Main
     "HOL-Library.FuncSet"
 begin
 
 type_synonym ('v, 'a) subst = "'v \<rightharpoonup> 'a"
 
 definition substs :: "'v set \<Rightarrow> 'a set \<Rightarrow> ('v, 'a) subst set" where
   "substs V H = {\<sigma>. dom \<sigma> = V \<and> ran \<sigma> \<subseteq> H}"
 
 text \<open>Small lemmas about the set of substitutions\<close>
 
 lemma substE [elim]: "\<lbrakk> \<sigma> \<in> substs V H; \<lbrakk> dom \<sigma> = V; ran \<sigma> \<subseteq> H \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by (simp add: substs_def)
 
 lemma substs_empty_dom [simp]: "substs {} H = {Map.empty}"
   by (auto simp add: substs_def)
 
 lemma substs_finite: "\<lbrakk> finite V; finite H \<rbrakk> \<Longrightarrow> finite (substs V H)"
   by (simp add: finite_set_of_finite_maps substs_def)
 
 lemma substs_nonempty:
   assumes "H \<noteq> {}"
   shows "substs V H \<noteq> {}" 
 proof -
   obtain h where A1: "h \<in> H" using assms by(auto)
   obtain \<rho> where A2: "\<rho> = (\<lambda>v. if v \<in> V then Some h else None)" by(simp)
   have "\<rho> \<in> substs V H" using A1 A2 by(auto simp add: substs_def ran_def dom_def)
   then show ?thesis by(auto)
 qed
 
 lemma subst_dom: \<open>\<lbrakk> \<rho> \<in> substs V H; x \<notin> V \<rbrakk> \<Longrightarrow> x \<notin> dom \<rho>\<close>
   by(auto simp add: substs_def)
 
 lemma subst_add:
   assumes  "x \<in> V" and "\<rho> \<in> substs (V - {x}) H" and "a \<in> H"
   shows "\<rho>(x \<mapsto> a) \<in> substs V H"
   using assms
   by(simp add: substs_def)
     (auto simp add: dom_def ran_def)
 
 lemma subst_im:
   assumes "x \<in> V" and "\<rho> \<in> substs V H"
   shows "the (\<rho> x) \<in> H"
   using assms
   by(auto simp add: substs_def dom_def ran_def)
 
 lemma subst_restr:
   assumes "x \<in> V" and "\<rho> \<in> substs V H"
   shows "\<rho> |` (dom \<rho> - {x}) \<in> substs (V - {x}) H"
   using assms
   by(auto simp add: substs_def ran_def dom_def restrict_map_def)
 
 
 text \<open>Bijection between sets of substitutions\<close>
 
 lemma restrict_map_dom: "\<sigma> |` dom \<sigma> = \<sigma>"
   by (metis (no_types, lifting) domIff map_le_antisym map_le_def restrict_in restrict_out)
    
 
 lemma bij_betw_set_substs:
   assumes "x \<in> V" 
   defines "f \<equiv> \<lambda>(a, \<sigma>::'v \<rightharpoonup> 'a). \<sigma>(x \<mapsto> a)" 
       and "g \<equiv> \<lambda>\<theta>::'v \<rightharpoonup> 'a. (the (\<theta> x), \<theta>|`(dom \<theta> - {x}))"
     shows "bij_betw f
                     (H \<times> substs (V - {x}) H) 
                     (substs V H)"
 proof (intro bij_betwI) 
   show "f \<in> H \<times> substs (V - {x}) H \<rightarrow> substs V H"
     using assms
     by(auto simp add: f_def subst_add)
 next 
   show "g \<in> substs V H \<rightarrow> H \<times> substs (V - {x}) H" 
     using assms
     by(auto simp add: g_def subst_im subst_restr)
 next 
   fix xa
   assume "xa \<in> H \<times> substs (V - {x}) H"
   then show "g (f xa) = xa" using assms
-    by (smt (z3) Diff_empty Diff_insert0 Diff_insert_absorb SigmaE case_prod_conv 
-            fun_upd_None_restrict fun_upd_same fun_upd_upd mk_disjoint_insert option.sel 
-            restrict_map_dom subst_dom)
+    by (smt (verit, ccfv_threshold) Diff_insert_absorb SigmaE case_prod_conv domI
+        fun_upd_None_restrict fun_upd_same fun_upd_upd mk_disjoint_insert option.sel restrict_map_dom
+        subst_dom)
 next
   fix y
   assume "y \<in> substs V H"
   then show "f (g y) = y" using assms 
     by(auto simp add: g_def f_def)
       (metis domIff fun_upd_restrict map_upd_triv option.exhaust_sel restrict_map_dom substE)
 qed
 
 end
\ No newline at end of file